[clean up Main, make Ho and CollectedHo separate types. move binary code to Ho.Binary for reading/writing ho files
John Meacham <john@repetae.net>**20061129222306] addfile ./Ho/Binary.hs
hunk ./FrontEnd/FrontEnd.hs 34
-               -> (Ho -> Ho -> IO Ho) -- ^ Process initial data loaded from ho files
-               -> (Ho -> Ho -> Tc.TiData -> IO (Ho,Ho))  -- ^ routine which takes the global ho, the partial local ho and the output of the front end, and returns the completed ho.
-               -> IO (Ho,Ho)     -- ^ (the final combined ho,all the loaded ho data)
+               -> (CollectedHo -> Ho -> IO CollectedHo) -- ^ Process initial data loaded from ho files
+               -> (CollectedHo -> Ho -> Tc.TiData -> IO (CollectedHo,Ho))  -- ^ routine which takes the global ho, the partial local ho and the output of the front end, and returns the completed ho.
+               -> IO (CollectedHo,Ho)     -- ^ (the final combined ho,all the loaded ho data)
hunk ./FrontEnd/FrontEnd.hs 52
-doModules :: (Ho -> Ho -> Tc.TiData -> IO (Ho,Ho)) -> Ho -> [HsModule] -> IO (Ho,Ho)
+doModules :: (CollectedHo -> Ho -> Tc.TiData -> IO (CollectedHo,Ho)) -> CollectedHo -> [HsModule] -> IO (CollectedHo,Ho)
hunk ./FrontEnd/FrontEnd.hs 59
-    ms <- determineExports [ (x,y,z) | (x,(y,z)) <- Map.toList $ hoDefs ho] (Map.toList $ hoExports ho) ms
+    ms <- determineExports [ (x,y,z) | (x,(y,z)) <- Map.toList $ hoDefs $ choHo ho] (Map.toList $ hoExports $ choHo ho) ms
hunk ./FrontEnd/Tc/Module.hs 110
-tiModules' ::  Ho -> [ModInfo] -> IO (Ho,TiData)
-tiModules' me ms = do
+tiModules' ::  CollectedHo -> [ModInfo] -> IO (Ho,TiData)
+tiModules' (CollectedHo me) ms = do
hunk ./Ho/Binary.hs 1
+module Ho.Binary where
+
+
+import Ho.Type
+import Binary
+import PackedString(PackedString)
+import HsSyn(Module)
+import Name.Binary
+
+data HoHeader = HoHeader {
+    -- * Haskell Source files depended on
+    hohDepends    :: [FileDep],
+    -- * Other objects depended on
+    hohModDepends :: [(Module,FileDep)],
+    -- * metainformation, filled for hl-files, empty for normal objects.
+    hohMetaInfo   :: [(PackedString,PackedString)]
+    }
+
+instance Binary HoHeader where
+    put_ bh (HoHeader ab ac ad) = do
+	    put_ bh ab
+	    lazyPut bh ac
+	    lazyPut bh ad
+    get bh = do
+    ab <- get bh
+    ac <- lazyGet bh
+    ad <- lazyGet bh
+    return (HoHeader ab ac ad)
+
+instance Binary Ho where
+    put_ bh (Ho aa ab ac ad ae af ag ah ai aj ak al am an) = do
+	    lazyPut bh aa
+	    lazyPut bh ab
+	    lazyPut bh ac
+	    lazyPut bh ad
+	    lazyPut bh ae
+	    lazyPut bh af
+	    lazyPut bh ag
+	    lazyPut bh ah
+	    lazyPut bh ai
+	    lazyPut bh aj
+	    lazyPut bh ak
+	    lazyPut bh al
+	    lazyPut bh am
+	    lazyPut bh an
+    get bh = do
+    aa <- lazyGet bh
+    ab <- lazyGet bh
+    ac <- lazyGet bh
+    ad <- lazyGet bh
+    ae <- lazyGet bh
+    af <- lazyGet bh
+    ag <- lazyGet bh
+    ah <- lazyGet bh
+    ai <- lazyGet bh
+    aj <- lazyGet bh
+    ak <- lazyGet bh
+    al <- lazyGet bh
+    am <- lazyGet bh
+    an <- lazyGet bh
+    return (Ho aa ab ac ad ae af ag ah ai aj ak al am an)
+
+instance Binary FileDep where
+    put_ bh (FileDep aa ab ac ad ae) = do
+        put_ bh aa
+        put_ bh ab
+        put_ bh ac
+        put_ bh ad
+        put_ bh ae
+    get bh = do
+        aa <- get bh
+        ab <- get bh
+        ac <- get bh
+        ad <- get bh
+        ae <- get bh
+        return (FileDep aa ab ac ad ae)
+
hunk ./Ho/Build.hs 49
+import Ho.Binary
hunk ./Ho/Build.hs 107
-findModule :: Ho                                  -- ^ Accumulated Ho
+findModule :: CollectedHo                                  -- ^ Accumulated Ho
hunk ./Ho/Build.hs 109
-              -> (Ho -> Ho -> IO Ho)              -- ^ Process initial ho loaded from file
-              -> (Ho -> [HsModule] -> IO (Ho,Ho)) -- ^ Process set of mutually recursive modules to produce final Ho
-              -> IO (Ho,Ho)                       -- ^ (Final accumulated ho,just the ho read to satisfy this command)
-findModule have (Left m) ifunc _
-    | m `mmember` (hoExports have) = return (have,mempty)
-findModule have need ifunc func  = do
+              -> (CollectedHo -> Ho -> IO CollectedHo)              -- ^ Process initial ho loaded from file
+              -> (CollectedHo -> [HsModule] -> IO (CollectedHo,Ho)) -- ^ Process set of mutually recursive modules to produce final Ho
+              -> IO (CollectedHo,Ho)                       -- ^ (Final accumulated ho,just the ho read to satisfy this command)
+findModule cho@(CollectedHo have) (Left m) ifunc _
+    | m `mmember` (hoExports have) = return (cho,mempty)
+findModule cho@(CollectedHo have) need ifunc func  = do
hunk ./Ho/Build.hs 124
-            (ho',newHo) <- func ho [ hs | (hs,_,_) <- sc ]
+            (ho'@(CollectedHo ho''),newHo) <- func ho [ hs | (hs,_,_) <- sc ]
hunk ./Ho/Build.hs 127
-                mdeps = [ (m,dep) | m <- mods', Left dep <- Map.lookup m (hoModules ho')]
+                mdeps = [ (m,dep) | m <- mods', Left dep <- Map.lookup m (hoModules ho'')]
hunk ./Ho/Build.hs 135
-            f (ho' `mappend` mempty { hoModules = hoModules newHo }) (readHo `mappend` newHo)  scs
-    ho <- ifunc have readHo
+            f (ho' `mappend` CollectedHo mempty { hoModules = hoModules newHo }) (readHo `mappend` newHo)  scs
+    ho <- ifunc cho readHo
hunk ./Ho/Library.hs 15
+import Ho.Binary
hunk ./Ho/Type.hs 21
-import Name.Binary
hunk ./Ho/Type.hs 30
-type LibraryName= String
+type LibraryName = String
hunk ./Ho/Type.hs 32
-
-data HoHeader = HoHeader {
-    -- * Haskell Source files depended on
-    hohDepends    :: [FileDep],
-    -- * Other objects depended on
-    hohModDepends :: [(Module,FileDep)],
-    -- * metainformation, filled for hl-files, empty for normal objects.
-    hohMetaInfo   :: [(PackedString,PackedString)]
-    }
-
-data Def = Def {
-    defTVr :: TVr,
-    defE :: E
-    }
-
-instance Binary Def where
-    put_ bh def = do
-        put_ bh (defTVr def)
-        lazyPut bh (defE def)
-    get bh = do
-        tvr <- get bh
-        e <- lazyGet bh
-        return Def { defTVr = tvr, defE = e }
+-- the collected information that is passed around
+newtype CollectedHo = CollectedHo { choHo :: Ho }
+    deriving(Monoid)
hunk ./Ho/Type.hs 36
+-- The raw data as ut appears on disk
hunk ./Ho/Type.hs 88
-    {-! derive: GhcBinary !-}
-
hunk ./Ho/Type.hs 90
-instance Binary HoHeader where
-    put_ bh (HoHeader ab ac ad) = do
-	    put_ bh ab
-	    lazyPut bh ac
-	    lazyPut bh ad
-    get bh = do
-    ab <- get bh
-    ac <- lazyGet bh
-    ad <- lazyGet bh
-    return (HoHeader ab ac ad)
hunk ./Ho/Type.hs 91
-instance Binary Ho where
-    put_ bh (Ho aa ab ac ad ae af ag ah ai aj ak al am an) = do
-	    lazyPut bh aa
-	    lazyPut bh ab
-	    lazyPut bh ac
-	    lazyPut bh ad
-	    lazyPut bh ae
-	    lazyPut bh af
-	    lazyPut bh ag
-	    lazyPut bh ah
-	    lazyPut bh ai
-	    lazyPut bh aj
-	    lazyPut bh ak
-	    lazyPut bh al
-	    lazyPut bh am
-	    lazyPut bh an
-    get bh = do
-    aa <- lazyGet bh
-    ab <- lazyGet bh
-    ac <- lazyGet bh
-    ad <- lazyGet bh
-    ae <- lazyGet bh
-    af <- lazyGet bh
-    ag <- lazyGet bh
-    ah <- lazyGet bh
-    ai <- lazyGet bh
-    aj <- lazyGet bh
-    ak <- lazyGet bh
-    al <- lazyGet bh
-    am <- lazyGet bh
-    an <- lazyGet bh
-    return (Ho aa ab ac ad ae af ag ah ai aj ak al am an)
hunk ./Main.hs 130
-    s <- Stats.new
-    (_,ho) <- parseFiles [] mods processInitialHo (processDecls s)
+    (_,ho) <- parseFiles [] mods processInitialHo processDecls
hunk ./Main.hs 149
-    s <- Stats.new
-    compileModEnv' s =<< parseFiles fs ms processInitialHo (processDecls s)
+    compileModEnv' =<< parseFiles fs ms processInitialHo processDecls
hunk ./Main.hs 201
-    Ho       -- ^ current accumulated ho
+    CollectedHo       -- ^ current accumulated ho
hunk ./Main.hs 203
-    -> IO Ho -- ^ final combined ho data.
-processInitialHo accumho ho = do
+    -> IO CollectedHo -- ^ final combined ho data.
+processInitialHo (CollectedHo accumho) ho = do
hunk ./Main.hs 213
-    return $ accumho' `mappend` ho { hoUsedIds = uids, hoEs = programEsMap prog }
+    return $ CollectedHo $ accumho' `mappend` ho { hoUsedIds = uids, hoEs = programEsMap prog }
hunk ./Main.hs 232
-    Stats.Stats    -- ^ statistics
-    -> Ho          -- ^ Collected ho
-    -> Ho          -- ^ preliminary haskell object  data
-    -> TiData      -- ^ front end output
-    -> IO (Ho,Ho)  -- ^ (new accumulated ho, final ho for this modules)
-processDecls stats ho ho' tiData = do
+    CollectedHo          -- ^ Collected ho
+    -> Ho                   -- ^ preliminary haskell object  data
+    -> TiData               -- ^ front end output
+    -> IO (CollectedHo,Ho)  -- ^ (new accumulated ho, final ho for this modules)
+processDecls (CollectedHo ho) ho' tiData = do
hunk ./Main.hs 435
-    {-
-
-    -- This is the main function that optimizes the routines before writing them out
-    let f (retds,(smap,annmap,idHist')) (rec,ns) = do
-        let names = [ n | (n,_) <- ns]
-        let namesInscope' = fromDistinctAscList (mkeys smap) `union` namesInscope
-        when coreMini $ putErrLn ("----\n" ++ pprint names)
-        cds <- annotateDs annmap (idann allRules mempty) letann lamann [ (t,e) | (t,e) <- ns]
-        --putStrLn "*** After annotate"
-        when miniCorePass $ mapM_ (\ (v,lc) -> printCheckName'' fullDataTable v lc) cds
-        let cm stats e = do
-            let sopt = mempty {  SS.so_boundVars = smap, SS.so_dataTable = fullDataTable }
-            let (e',_) = SS.collectOccurance' e
-            let (stat, e'') = SS.simplifyE sopt e'
-            when miniCorePass  $ printCheckName fullDataTable e''
-            Stats.tickStat stats stat
-            return e''
-        let mangle = mangle' (Just $ namesInscope' `union` fromList (map (tvrIdent . fst) cds)) fullDataTable
-        cds <- flip mapM cds $ \ (v,lc) -> do
-            lintCheckE onerrNone fullDataTable v lc
-            (v,lc) <- Stats.runStatIO stats (runNameMT $ etaExpandDef' fullDataTable 0 v lc)
-            lc <- doopt mangle coreMini stats ("SuperSimplify 1: " ++ pprint v) cm lc
-            lc <- mangle (return ()) coreMini ("Barendregt: " ++ pprint v) (return . barendregt) lc
-            lc <- doopt mangle coreMini stats "Float Inward..." (\stats x -> return (floatInward x)) lc
-            lintCheckE onerrNone fullDataTable v lc
-            return (v,lc)
-        wdump FD.Core $ mapM_ (\ (v,lc) -> printCheckName'' fullDataTable v lc) cds
-        cds <- Demand.solveDs fullDataTable cds
-        cds <- flip mapM cds $ \ (v,lc) -> do
-            lintCheckE onerrNone fullDataTable v lc
-            (v,lc) <- Stats.runStatIO stats (runNameMT $ etaExpandDef' fullDataTable 0 v lc)
-            lc <- doopt mangle coreMini stats ("SuperSimplify 2: " ++ pprint v) cm lc
-            lc <- mangle (return ()) coreMini ("Barendregt: " ++ pprint v) (return . barendregt) lc
-            lintCheckE onerrNone fullDataTable v lc
-            return (v,lc)
-
-        cds <- Demand.solveDs fullDataTable cds
-        cds <- return (E.CPR.cprAnalyzeDs fullDataTable cds)
-        when miniCorePass  $ mapM_ (\ (v,lc) -> printCheckName' fullDataTable v lc) cds
-        sequence_ [lintCheckE onerrNone fullDataTable v e | (v,e) <- cds ]
-        let (cds',st) = performWorkWrap fullDataTable cds
-        Stats.tickStat stats st
-        let wws = length cds' - length cds
-        wdump FD.Progress $ putErr (replicate wws 'w')
-        when (miniCorePass && wws > 0) $ putErrLn "After WorkWrap" >> mapM_ (\ (v,lc) -> printCheckName' fullDataTable v lc) cds'
-        when (miniCorePass && wws > 0) $ putErrLn "^^^ After WorkWrap"
-
-        let graph = (newGraph cds' (\ (b,_) -> tvrIdent b) (\ (b,c) -> idSetToList $ bindingFreeVars b c))
-            (lb,os) = findLoopBreakers (const 1) nogood graph
-            nogood (b,_) = not $ getProperty prop_PLACEHOLDER b || getProperty prop_WRAPPER b
-            cds = [ if x `elem` fsts lb then (setProperty prop_NOINLINE x,y) else (x,y) | (x,y) <- os  ]
-        sequence_ [lintCheckE onerrNone fullDataTable v e | (v,e) <- cds ]
-        cds <- annotateDs annmap (\_ -> return) letann lamann cds
-        sequence_ [lintCheckE onerrNone fullDataTable v e | (v,e) <- cds ]
-
-        let mangle = mangle' (Just $ namesInscope' `union` fromList (map (tvrIdent . fst) cds')) fullDataTable
-        let dd  (ds,used) (v,lc) = do
-                let cm stats e = do
-                    let sopt = mempty {  SS.so_boundVars = fromList [ (tvrIdent v,(v,lc)) | (v,lc) <- ds] `union` smap,  SS.so_dataTable = fullDataTable }
-                    let (e',_) = SS.collectOccurance' e
-                    let (stat, e'') = SS.simplifyE sopt e'
-                    when miniCorePass  $ printCheckName' fullDataTable v e''
-                    Stats.tickStat stats stat
-                    return e''
-                let (lc', _) = runRename used lc
-                lc <- doopt mangle False stats ("SuperSimplify PostPWW: " ++ pprint v) cm lc'
-                let (lc', used') = runRename used lc
-                return ((v,lc'):ds,used' `mappend` used)
-        (cds,usedids) <- foldM dd ([],hoUsedIds ho) cds
-        --cds <- E.Strictness.solveDs cds
-        cds <- Demand.solveDs fullDataTable cds
-        cds <- return (E.CPR.cprAnalyzeDs fullDataTable cds)
-        cds <- annotateDs annmap (\_ -> return) letann lamann cds
-        wdump FD.Core $ mapM_ (\ (v,lc) -> printCheckName' fullDataTable v lc) cds
-        let nvls = [ (t,e)  | (t,e) <- cds ]
-
-        wdump FD.Progress $ putErr (if rec then "*" else ".")
-        return (nvls ++ retds, (fromList [ (tvrIdent v,(v,lc)) | (v,lc) <- nvls] `union` smap, fromList [ (tvrIdent v,(Just (EVar v))) | (v,_) <- nvls] `union` annmap , idHist' ))
-
-
-
-    let graph =  (newGraph (programDs prog) (\ (b,_) -> tvrIdent b) (\ (b,c) -> idSetToList $ bindingFreeVars b c))
-        fscc (Left n) = (False,[n])
-        fscc (Right ns) = (True,ns)
-
-    -- perform demand analysis
-    prog <- Demand.analyzeProgram prog
-
-    progress "Optimization pass with workwrapping/CPR"
-    (ds,_) <- foldM f ([],(fromList [ (tvrIdent v,(v,e)) | (v,e) <- Map.elems (hoEs ho)], initMap, Set.empty)) (map fscc $ scc graph)
-    progress "!"
-    prog <- return $ programSetDs ds prog
-    -}
hunk ./Main.hs 440
-    --prog <- if (fopts FO.TypeAnalysis) then do typeAnalyze True prog else return prog
-    --prog <- transformProgram "typeAnalyze" DontIterate True (typeAnalyze True) prog
-
-
-{-
-    prog <- if True then do
-        prog <- barendregtProg prog
-        prog <- return $ etaAnnotateProgram prog
-        progress "Post typeanalyis/etaexpansion pass"
-        let graph =  (newGraph (programDs prog) (\ (b,_) -> tvrIdent b) (\ (b,c) -> idSetToList $ bindingFreeVars b c))
-            fscc (Left n) = (False,[n])
-            fscc (Right ns) = (True,ns)
-        (ds,_) <- foldM f ([],(fromList [ (tvrIdent v,(v,e)) | (v,e) <- Map.elems (hoEs ho)], initMap, Set.empty)) (map fscc $ scc graph)
-        progress "!"
-        return $ programSetDs ds prog
-      else return prog
-    prog <- programPrune prog
-    -}
hunk ./Main.hs 450
-    return (newHo `mappend` ho,newHo)
+    return (CollectedHo (newHo `mappend` ho),newHo)
hunk ./Main.hs 484
-compileModEnv' stats (ho,_) = do
+compileModEnv' (CollectedHo ho,_) = do
hunk ./Main.hs 561
-    st <- Stats.new
-
hunk ./Main.hs 571
-    st <- Stats.new
hunk ./Main.hs 636
-    wdump FD.OptimizationStats $ Stats.print "Optimization" stats