Run the complete backend (Stg -> .S) incrementally on each StgBinding

This is so that we can process the Stg code in constant space.  Before
we were generating all the C-- up front, leading to a large space
leak.

I haven't converted the LLVM or C back ends to the incremental scheme,
but it's not hard to do.

compiler/cmm/CmmBuildInfoTables.hs

@@ -63,6 +63,12 @@ import Data.Set (Set)
 import qualified Data.Set as Set
 import qualified FiniteMap as Map
 
+#if __GLASGOW_HASKELL__ < 704
+foldSet = Set.fold
+#else
+foldSet = Set.foldr
+#endif
+
 ----------------------------------------------------------------
 -- Building InfoTables
 
@@ -206,8 +212,8 @@ cafLattice = DataflowLattice "live cafs" Set.empty add
 cafTransfers :: Platform -> BwdTransfer CmmNode CAFSet
 cafTransfers platform = mkBTransfer3 first middle last
   where first  _ live = live
-        middle m live = {-# SCC middle #-} foldExpDeep addCaf m live
-        last   l live = {-# SCC last #-} foldExpDeep addCaf l (joinOutFacts cafLattice l live)
+        middle m live = foldExpDeep addCaf m live
+        last   l live = foldExpDeep addCaf l (joinOutFacts cafLattice l live)
         addCaf e set = case e of
                CmmLit (CmmLabel c)              -> add c set
                CmmLit (CmmLabelOff c _)         -> add c set
@@ -276,7 +282,7 @@ buildSRTs topSRT topCAFMap cafs =
          -- For each label referring to a function f without a static closure,
          -- replace it with the CAFs that are reachable from f.
          sub_srt topSRT localCafs =
-           let cafs = Set.elems (Set.foldr liftCAF Set.empty localCafs)
+           let cafs = Set.elems (foldSet liftCAF Set.empty localCafs)
                mkSRT topSRT =
                  do localSRTs <- procpointSRT (lbl topSRT) (elt_map topSRT) cafs
                     return (topSRT, localSRTs)
@@ -379,9 +385,9 @@ mkTopCAFInfo localCAFs = foldl addToTop Map.empty g
           let (lbls, cafsets) = unzip nodes
               cafset  = foldr Set.delete (foldl Set.union Set.empty cafsets) lbls
           in foldl (\env l -> Map.insert l (flatten env cafset) env) env lbls
-        flatten env cafset = Set.foldr (lookup env) Set.empty cafset
+        flatten env cafset = foldSet (lookup env) Set.empty cafset
         lookup env caf cafset' =
-          case Map.lookup caf env of Just cafs -> Set.foldr add cafset' cafs
+          case Map.lookup caf env of Just cafs -> foldSet add cafset' cafs
                                      Nothing -> add caf cafset'
         add caf cafset' = Set.insert caf cafset'
         g = stronglyConnCompFromEdgedVertices

compiler/cmm/CmmInfo.hs

@@ -19,6 +19,8 @@ import CmmUtils
 import CLabel
 import SMRep
 import Bitmap
+import Stream (Stream)
+import qualified Stream
 
 import Maybes
 import Constants
@@ -38,10 +40,16 @@ mkEmptyContInfoTable info_lbl
                  , cit_prof = NoProfilingInfo
                  , cit_srt  = NoC_SRT }
 
-cmmToRawCmm :: Platform -> [Old.CmmGroup] -> IO [Old.RawCmmGroup]
+cmmToRawCmm :: Platform -> Stream IO Old.CmmGroup ()
+            -> IO (Stream IO Old.RawCmmGroup ())
 cmmToRawCmm platform cmms
   = do { uniqs <- mkSplitUniqSupply 'i'
-       ; return (initUs_ uniqs (mapM (concatMapM (mkInfoTable platform)) cmms)) }
+       ; let do_one uniqs cmm = do
+                case initUs uniqs $ concatMapM (mkInfoTable platform) cmm of
+                  (b,uniqs') -> return (uniqs',b)
+                  -- NB. strictness fixes a space leak.  DO NOT REMOVE.
+       ; return (Stream.mapAccumL do_one uniqs cmms >> return ())
+       }
 
 -- Make a concrete info table, represented as a list of CmmStatic
 -- (it can't be simply a list of Word, because the SRT field is

compiler/cmm/CmmPipeline.hs

@@ -56,10 +56,10 @@ import StaticFlags
 --    we actually need to do the initial pass.
 cmmPipeline  :: HscEnv -- Compilation env including
                        -- dynamic flags: -dcmm-lint -ddump-cps-cmm
-             -> (TopSRT, [CmmGroup])    -- SRT table and accumulating list of compiled procs
+             -> TopSRT     -- SRT table and accumulating list of compiled procs
              -> CmmGroup             -- Input C-- with Procedures
-             -> IO (TopSRT, [CmmGroup]) -- Output CPS transformed C--
-cmmPipeline hsc_env (topSRT, rst) prog =
+             -> IO (TopSRT, CmmGroup) -- Output CPS transformed C--
+cmmPipeline hsc_env topSRT prog =
   do let dflags = hsc_dflags hsc_env
      --
      showPass dflags "CPSZ"
@@ -77,7 +77,7 @@ cmmPipeline hsc_env (topSRT, rst) prog =
 
      dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (pprPlatform (targetPlatform dflags) cmms)
 
-     return (topSRT, cmms : rst)
+     return (topSRT, cmms)
 
 {- [Note global fuel]
 ~~~~~~~~~~~~~~~~~~~~~

compiler/codeGen/StgCmm.hs

@@ -46,6 +46,13 @@ import TyCon
 import Module
 import ErrUtils
 import Outputable
+import Stream
+
+import OrdList
+import MkGraph
+
+import Data.IORef
+import Control.Monad (when)
 
 codeGen :: DynFlags
 	 -> Module
@@ -53,39 +60,51 @@ codeGen :: DynFlags
          -> CollectedCCs                -- (Local/global) cost-centres needing declaring/registering.
 	 -> [(StgBinding,[(Id,[Id])])]	-- Bindings to convert, with SRTs
 	 -> HpcInfo
-         -> IO [CmmGroup]         -- Output
+         -> Stream IO CmmGroup ()       -- Output as a stream, so codegen can
+                                        -- be interleaved with output
 
 codeGen dflags this_mod data_tycons
         cost_centre_info stg_binds hpc_info
-  = do  { showPass dflags "New CodeGen"
-
--- Why?
---   ; mapM_ (\x -> seq x (return ())) data_tycons
-
-        ; code_stuff <- initC dflags this_mod $ do 
-                { cmm_binds  <- mapM (getCmm . cgTopBinding dflags) stg_binds
-                ; cmm_tycons <- mapM cgTyCon data_tycons
-                ; cmm_init   <- getCmm (mkModuleInit cost_centre_info
-                                             this_mod hpc_info)
-                ; return (cmm_init : cmm_binds ++ cmm_tycons)
-                }
+  = do  { liftIO $ showPass dflags "New CodeGen"
+
+              -- cg: run the code generator, and yield the resulting CmmGroup
+              -- Using an IORef to store the state is a bit crude, but otherwise
+              -- we would need to add a state monad layer.
+        ; cgref <- liftIO $ newIORef =<< initC
+        ; let cg :: FCode () -> Stream IO CmmGroup ()
+              cg fcode = do
+                cmm <- liftIO $ do
+                         st <- readIORef cgref
+                         let (a,st') = runC dflags this_mod st (getCmm fcode)
+
+                         -- NB. stub-out cgs_tops and cgs_stmts.  This fixes
+                         -- a big space leak.  DO NOT REMOVE!
+                         writeIORef cgref $! st'{ cgs_tops = nilOL,
+                                                  cgs_stmts = mkNop }
+                         return a
+                yield cmm
+
+               -- Note [codegen-split-init] the cmm_init block must come
+               -- FIRST.  This is because when -split-objs is on we need to
+               -- combine this block with its initialisation routines; see
+               -- Note [pipeline-split-init].
+        ; cg (mkModuleInit cost_centre_info this_mod hpc_info)
+
+        ; mapM_ (cg . cgTopBinding dflags) stg_binds
+
                 -- Put datatype_stuff after code_stuff, because the
                 -- datatype closure table (for enumeration types) to
                 -- (say) PrelBase_True_closure, which is defined in
                 -- code_stuff
-
-                -- N.B. returning '[Cmm]' and not 'Cmm' here makes it
-                -- possible for object splitting to split up the
-                -- pieces later.
-
-                -- Note [codegen-split-init] the cmm_init block must
-                -- come FIRST.  This is because when -split-objs is on
-                -- we need to combine this block with its
-                -- initialisation routines; see Note
-                -- [pipeline-split-init].
-
-        ; return code_stuff }
-
+        ; let do_tycon tycon = do
+                -- Generate a table of static closures for an
+                -- enumeration type Note that the closure pointers are
+                -- tagged.
+                 when (isEnumerationTyCon tycon) $ cg (cgEnumerationTyCon tycon)
+                 mapM_ (cg . cgDataCon) (tyConDataCons tycon)
+
+        ; mapM_ do_tycon data_tycons
+        }
 
 ---------------------------------------------------------------
 --	Top-level bindings
@@ -107,7 +126,7 @@ cgTopBinding dflags (StgNonRec id rhs, _srts)
 	; info <- cgTopRhs id' rhs
 	; addBindC (cg_id info) info -- Add the *un-externalised* Id to the envt,
 				     -- so we find it when we look up occurrences
-	}
+        }
 
 cgTopBinding dflags (StgRec pairs, _srts)
   = do	{ let (bndrs, rhss) = unzip pairs
@@ -116,7 +135,7 @@ cgTopBinding dflags (StgRec pairs, _srts)
 	; fixC_(\ new_binds -> do 
 		{ addBindsC new_binds
 		; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' })
-	; return () }
+        ; return () }
 
 -- Urgh!  I tried moving the forkStatics call from the rhss of cgTopRhs
 -- to enclose the listFCs in cgTopBinding, but that tickled the
@@ -186,65 +205,19 @@ mkModuleInit cost_centre_info this_mod hpc_info
         ; emitDecl (CmmData Data (Statics (mkPlainModuleInitLabel this_mod) []))
         }
 
+
 ---------------------------------------------------------------
 --	Generating static stuff for algebraic data types
 ---------------------------------------------------------------
 
-{-	[These comments are rather out of date]
-
-Macro  		    	     Kind of constructor
-CONST_INFO_TABLE@	Zero arity (no info -- compiler uses static closure)
-CHARLIKE_INFO_TABLE	Charlike   (no info -- compiler indexes fixed array)
-INTLIKE_INFO_TABLE	Intlike; the one macro generates both info tbls
-SPEC_INFO_TABLE		SPECish, and bigger than or equal to MIN_UPD_SIZE
-GEN_INFO_TABLE		GENish (hence bigger than or equal to MIN_UPD_SIZE@)
 
-Possible info tables for constructor con:
-
-* _con_info:
-  Used for dynamically let(rec)-bound occurrences of
-  the constructor, and for updates.  For constructors
-  which are int-like, char-like or nullary, when GC occurs,
-  the closure tries to get rid of itself.
-
-* _static_info:
-  Static occurrences of the constructor macro: STATIC_INFO_TABLE.
-
-For zero-arity constructors, \tr{con}, we NO LONGER generate a static closure;
-it's place is taken by the top level defn of the constructor.
-
-For charlike and intlike closures there is a fixed array of static
-closures predeclared.
--}
-
-cgTyCon :: TyCon -> FCode CmmGroup  -- All constructors merged together
-cgTyCon tycon
-  = do	{ constrs <- mapM (getCmm . cgDataCon) (tyConDataCons tycon)
-
-	    -- Generate a table of static closures for an enumeration type
-	    -- Put the table after the data constructor decls, because the
-	    -- datatype closure table (for enumeration types)
-	    -- to (say) PrelBase_$wTrue_closure, which is defined in code_stuff
-            -- Note that the closure pointers are tagged.
-
-            -- N.B. comment says to put table after constructor decls, but
-            -- code puts it before --- NR 16 Aug 2007
-	; extra <- cgEnumerationTyCon tycon
-
-        ; return (concat (extra ++ constrs))
-        }
-
-cgEnumerationTyCon :: TyCon -> FCode [CmmGroup]
+cgEnumerationTyCon :: TyCon -> FCode ()
 cgEnumerationTyCon tycon
-  | isEnumerationTyCon tycon
-  = do	{ tbl <- getCmm $ 
-		 emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)
-	      	   [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs) 
-				 (tagForCon con)
-    	      	   | con <- tyConDataCons tycon]
-	; return [tbl] }
-  | otherwise
-  = return []
+  = emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)
+             [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs)
+                           (tagForCon con)
+             | con <- tyConDataCons tycon]
+
 
 cgDataCon :: DataCon -> FCode ()
 -- Generate the entry code, info tables, and (for niladic constructor)

compiler/codeGen/StgCmmMonad.hs

@@ -17,7 +17,7 @@
 module StgCmmMonad (
 	FCode,	-- type
 
-	initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
+        initC, runC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
 	returnFC, fixC, fixC_, nopC, whenC, 
 	newUnique, newUniqSupply, 
 
@@ -77,6 +77,7 @@ import Unique
 import UniqSupply
 import FastString
 import Outputable
+import Util
 
 import Compiler.Hoopl hiding (Unique, (<*>), mkLabel, mkBranch, mkLast)
 
@@ -103,12 +104,12 @@ instance Monad FCode where
 {-# INLINE thenFC #-}
 {-# INLINE returnFC #-}
 
-initC :: DynFlags -> Module -> FCode a -> IO a
-initC dflags mod (FCode code)
-  = do	{ uniqs <- mkSplitUniqSupply 'c'
-	; case code (initCgInfoDown dflags mod) (initCgState uniqs) of
-	      (res, _) -> return res
-	}
+initC :: IO CgState
+initC  = do { uniqs <- mkSplitUniqSupply 'c'
+            ; return (initCgState uniqs) }
+
+runC :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState)
+runC dflags mod st (FCode code) = code (initCgInfoDown dflags mod) st
 
 returnFC :: a -> FCode a
 returnFC val = FCode (\_info_down state -> (val, state))

compiler/ghc.cabal.in

@@ -455,6 +455,7 @@ Library
         Pretty
         Serialized
         State
+        Stream
         StringBuffer
         UniqFM
         UniqSet

compiler/main/CodeOutput.lhs

@@ -30,6 +30,8 @@ import HscTypes
 import DynFlags
 import Config
 import SysTools
+import Stream           (Stream)
+import qualified Stream
 
 import ErrUtils		( dumpIfSet_dyn, showPass, ghcExit )
 import Outputable
@@ -55,35 +57,36 @@ codeOutput :: DynFlags
 	   -> ModLocation
 	   -> ForeignStubs
 	   -> [PackageId]
-           -> [RawCmmGroup]                       -- Compiled C--
+           -> Stream IO RawCmmGroup ()                       -- Compiled C--
            -> IO (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-})
 
-codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC
+codeOutput dflags this_mod location foreign_stubs pkg_deps cmm_stream
   = 
-    -- You can have C (c_output) or assembly-language (ncg_output),
-    -- but not both.  [Allowing for both gives a space leak on
-    -- flat_abstractC.  WDP 94/10]
-
-    -- Dunno if the above comment is still meaningful now.  JRS 001024.
-
-    do	{ when (dopt Opt_DoCmmLinting dflags) $ do
-		{ showPass dflags "CmmLint"
-		; let lints = map (cmmLint (targetPlatform dflags)) flat_abstractC
-		; case firstJusts lints of
+    do  {
+        -- Lint each CmmGroup as it goes past
+        ; let linted_cmm_stream =
+                 if dopt Opt_DoCmmLinting dflags
+                    then Stream.mapM do_lint cmm_stream
+                    else cmm_stream
+
+              do_lint cmm = do
+                { showPass dflags "CmmLint"
+                ; case cmmLint (targetPlatform dflags) cmm of
 			Just err -> do { printDump err
 				       ; ghcExit dflags 1
 				       }
 			Nothing  -> return ()
-		}
+                ; return cmm
+                }
 
 	; showPass dflags "CodeOutput"
 	; let filenm = hscOutName dflags 
 	; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs
 	; case hscTarget dflags of {
              HscInterpreted -> return ();
-             HscAsm         -> outputAsm dflags filenm flat_abstractC;
-             HscC           -> outputC dflags filenm flat_abstractC pkg_deps;
-             HscLlvm        -> outputLlvm dflags filenm flat_abstractC;
+             HscAsm         -> outputAsm dflags filenm linted_cmm_stream;
+             HscC           -> outputC dflags filenm linted_cmm_stream pkg_deps;
+             HscLlvm        -> outputLlvm dflags filenm linted_cmm_stream;
              HscNothing     -> panic "codeOutput: HscNothing"
 	  }
 	; return stubs_exist
@@ -103,12 +106,16 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
 \begin{code}
 outputC :: DynFlags
         -> FilePath
-        -> [RawCmmGroup]
+        -> Stream IO RawCmmGroup ()
         -> [PackageId]
         -> IO ()
 
-outputC dflags filenm flat_absC packages
+outputC dflags filenm cmm_stream packages
   = do 
+       -- ToDo: make the C backend consume the C-- incrementally, by
+       -- pushing the cmm_stream inside (c.f. nativeCodeGen)
+       rawcmms <- Stream.collect cmm_stream
+
        -- figure out which header files to #include in the generated .hc file:
        --
        --   * extra_includes from packages
@@ -130,7 +137,7 @@ outputC dflags filenm flat_absC packages
        doOutput filenm $ \ h -> do
 	  hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
 	  hPutStr h cc_injects
-	  writeCs dflags h flat_absC
+          writeCs dflags h rawcmms
 \end{code}
 
 
@@ -141,14 +148,14 @@ outputC dflags filenm flat_absC packages
 %************************************************************************
 
 \begin{code}
-outputAsm :: DynFlags -> FilePath -> [RawCmmGroup] -> IO ()
-outputAsm dflags filenm flat_absC
+outputAsm :: DynFlags -> FilePath -> Stream IO RawCmmGroup () -> IO ()
+outputAsm dflags filenm cmm_stream
  | cGhcWithNativeCodeGen == "YES"
   = do ncg_uniqs <- mkSplitUniqSupply 'n'
 
        {-# SCC "OutputAsm" #-} doOutput filenm $
            \f -> {-# SCC "NativeCodeGen" #-}
-                 nativeCodeGen dflags f ncg_uniqs flat_absC
+                 nativeCodeGen dflags f ncg_uniqs cmm_stream
 
  | otherwise
   = panic "This compiler was built without a native code generator"
@@ -162,12 +169,17 @@ outputAsm dflags filenm flat_absC
 %************************************************************************
 
 \begin{code}
-outputLlvm :: DynFlags -> FilePath -> [RawCmmGroup] -> IO ()
-outputLlvm dflags filenm flat_absC
+outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup () -> IO ()
+outputLlvm dflags filenm cmm_stream
   = do ncg_uniqs <- mkSplitUniqSupply 'n'
+
+       -- ToDo: make the LLVM backend consume the C-- incrementally,
+       -- by pushing the cmm_stream inside (c.f. nativeCodeGen)
+       rawcmms <- Stream.collect cmm_stream
+
        {-# SCC "llvm_output" #-} doOutput filenm $
            \f -> {-# SCC "llvm_CodeGen" #-}
-                 llvmCodeGen dflags f ncg_uniqs flat_absC
+                 llvmCodeGen dflags f ncg_uniqs rawcmms
 \end{code}
 
 

compiler/main/HscMain.hs

@@ -115,7 +115,8 @@ import TyCon
 import Name
 import SimplStg         ( stg2stg )
 import CodeGen          ( codeGen )
-import OldCmm as Old    ( CmmGroup )
+import qualified OldCmm as Old
+import qualified Cmm as New
 import PprCmm           ( pprCmms )
 import CmmParse         ( parseCmmFile )
 import CmmBuildInfoTables
@@ -143,6 +144,10 @@ import UniqFM           ( emptyUFM )
 import UniqSupply       ( initUs_ )
 import Bag
 import Exception
+import qualified Stream
+import Stream (Stream)
+
+import CLabel
 
 import Data.List
 import Control.Monad
@@ -1210,19 +1215,26 @@ hscGenHardCode cgguts mod_summary = do
                              stg_binds hpc_info
                     else {-# SCC "CodeGen" #-}
                          codeGen dflags this_mod data_tycons
-                             cost_centre_info
-                             stg_binds hpc_info
+                               cost_centre_info
+                               stg_binds hpc_info >>= return . Stream.fromList
+
 
         ------------------  Code output -----------------------
-        rawcmms <- {-# SCC "cmmToRawCmm" #-}
+        rawcmms0 <- {-# SCC "cmmToRawCmm" #-}
                    cmmToRawCmm platform cmms
-        dumpIfSet_dyn dflags Opt_D_dump_raw_cmm "Raw Cmm" (pprPlatform platform rawcmms)
+
+        let dump a = do dumpIfSet_dyn dflags Opt_D_dump_raw_cmm "Raw Cmm"
+                           (pprPlatform platform a)
+                        return a
+            rawcmms1 = Stream.mapM dump rawcmms0
+
         (_stub_h_exists, stub_c_exists)
             <- {-# SCC "codeOutput" #-}
                codeOutput dflags this_mod location foreign_stubs
-               dependencies rawcmms
+               dependencies rawcmms1
         return stub_c_exists
 
+
 hscInteractive :: (ModIface, ModDetails, CgGuts)
                -> ModSummary
                -> Hsc (InteractiveStatus, ModIface, ModDetails)
@@ -1267,7 +1279,7 @@ hscCompileCmmFile hsc_env filename = runHsc hsc_env $ do
     let dflags = hsc_dflags hsc_env
     cmm <- ioMsgMaybe $ parseCmmFile dflags filename
     liftIO $ do
-        rawCmms <- cmmToRawCmm (targetPlatform dflags) [cmm]
+        rawCmms <- cmmToRawCmm (targetPlatform dflags) (Stream.yield cmm)
         _ <- codeOutput dflags no_mod no_loc NoStubs [] rawCmms
         return ()
   where
@@ -1282,28 +1294,55 @@ tryNewCodeGen   :: HscEnv -> Module -> [TyCon]
                 -> CollectedCCs
                 -> [(StgBinding,[(Id,[Id])])]
                 -> HpcInfo
-                -> IO [Old.CmmGroup]
+                -> IO (Stream IO Old.CmmGroup ())
+         -- Note we produce a 'Stream' of CmmGroups, so that the
+         -- backend can be run incrementally.  Otherwise it generates all
+         -- the C-- up front, which has a significant space cost.
 tryNewCodeGen hsc_env this_mod data_tycons
               cost_centre_info stg_binds hpc_info = do
     let dflags = hsc_dflags hsc_env
         platform = targetPlatform dflags
-    prog <- {-# SCC "StgCmm" #-}
+
+    let cmm_stream :: Stream IO New.CmmGroup ()
+        cmm_stream = {-# SCC "StgCmm" #-}
             StgCmm.codeGen dflags this_mod data_tycons
                            cost_centre_info stg_binds hpc_info
-    dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen"
-                  (pprCmms platform prog)
+
+        -- codegen consumes a stream of CmmGroup, and produces a new
+        -- stream of CmmGroup (not necessarily synchronised: one
+        -- CmmGroup on input may produce many CmmGroups on output due
+        -- to proc-point splitting).
+
+    let dump1 a = do dumpIfSet_dyn dflags Opt_D_dump_cmmz
+                       "Cmm produced by new codegen"
+                       (pprPlatform platform a)
+                     return a
+
+        ppr_stream1 = Stream.mapM dump1 cmm_stream
 
     -- We are building a single SRT for the entire module, so
     -- we must thread it through all the procedures as we cps-convert them.
     us <- mkSplitUniqSupply 'S'
     let initTopSRT = initUs_ us emptySRT
-    (topSRT, prog) <- {-# SCC "cmmPipeline" #-}
-                      foldM (cmmPipeline hsc_env) (initTopSRT, []) prog
 
-    let prog' = {-# SCC "cmmOfZgraph" #-}
-                map cmmOfZgraph (srtToData topSRT : prog)
-    dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (pprPlatform platform prog')
-    return prog'
+    let run_pipeline topSRT cmmgroup = do
+           (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT cmmgroup
+           return (topSRT,cmmOfZgraph cmmgroup)
+
+    let pipeline_stream = {-# SCC "cmmPipeline" #-} do
+          topSRT <- Stream.mapAccumL run_pipeline initTopSRT ppr_stream1
+          Stream.yield (cmmOfZgraph (srtToData topSRT))
+
+    let
+        dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" $
+                       pprPlatform platform a
+                     return a
+
+        ppr_stream2 = Stream.mapM dump2 pipeline_stream
+
+    return ppr_stream2
+
+
 
 myCoreToStg :: DynFlags -> Module -> CoreProgram
             -> IO ( [(StgBinding,[(Id,[Id])])] -- output program

compiler/nativeGen/AsmCodeGen.lhs

@@ -79,6 +79,8 @@ import FastString
 import UniqSet
 import ErrUtils
 import Module
+import Stream (Stream)
+import qualified Stream
 
 -- DEBUGGING ONLY
 --import OrdList
@@ -155,7 +157,7 @@ data NcgImpl statics instr jumpDest = NcgImpl {
     }
 
 --------------------
-nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmmGroup] -> IO ()
+nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> Stream IO RawCmmGroup () -> IO ()
 nativeCodeGen dflags h us cmms
  = let platform = targetPlatform dflags
        nCG' :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO ()
@@ -217,16 +219,16 @@ nativeCodeGen dflags h us cmms
 nativeCodeGen' :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr)
                => DynFlags
                -> NcgImpl statics instr jumpDest
-               -> Handle -> UniqSupply -> [RawCmmGroup] -> IO ()
+               -> Handle -> UniqSupply -> Stream IO RawCmmGroup () -> IO ()
 nativeCodeGen' dflags ncgImpl h us cmms
  = do
 	let platform = targetPlatform dflags
-	    split_cmms	= concat $ map add_split cmms
+            split_cmms  = Stream.map add_split cmms
         -- BufHandle is a performance hack.  We could hide it inside
         -- Pretty if it weren't for the fact that we do lots of little
         -- printDocs here (in order to do codegen in constant space).
         bufh <- newBufHandle h
- 	(imports, prof) <- cmmNativeGens dflags ncgImpl bufh us split_cmms [] [] 0
+        (imports, prof) <- cmmNativeGenStream dflags ncgImpl bufh us split_cmms [] [] 0
         bFlush bufh
 
 	let (native, colorStats, linearStats)
@@ -279,6 +281,34 @@ nativeCodeGen' dflags ncgImpl h us cmms
 	split_marker = CmmProc Nothing mkSplitMarkerLabel (ListGraph [])
 
 
+cmmNativeGenStream :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr)
+              => DynFlags
+              -> NcgImpl statics instr jumpDest
+              -> BufHandle
+              -> UniqSupply
+              -> Stream IO RawCmmGroup ()
+              -> [[CLabel]]
+              -> [ ([NatCmmDecl statics instr],
+                   Maybe [Color.RegAllocStats statics instr],
+                   Maybe [Linear.RegAllocStats]) ]
+              -> Int
+              -> IO ( [[CLabel]],
+                      [([NatCmmDecl statics instr],
+                      Maybe [Color.RegAllocStats statics instr],
+                      Maybe [Linear.RegAllocStats])] )
+
+cmmNativeGenStream dflags ncgImpl h us cmm_stream impAcc profAcc count
+ = do
+        r <- Stream.runStream cmm_stream
+        case r of
+          Left () -> return (reverse impAcc, reverse profAcc)
+          Right (cmms, cmm_stream') -> do
+            (impAcc,profAcc) <- cmmNativeGens dflags ncgImpl h us cmms
+                                              impAcc profAcc count
+            cmmNativeGenStream dflags ncgImpl h us cmm_stream'
+                                              impAcc profAcc count
+
+
 -- | Do native code generation on all these cmms.
 --
 cmmNativeGens :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr)
@@ -298,7 +328,7 @@ cmmNativeGens :: (PlatformOutputable statics, PlatformOutputable instr, Instruct