Commit 46a772f8 authored by Simon Marlow's avatar Simon Marlow

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.
parent 88745c91
......@@ -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
......
......@@ -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
......
......@@ -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]
~~~~~~~~~~~~~~~~~~~~~
......
......@@ -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)
......
......@@ -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))
......
......@@ -455,6 +455,7 @@ Library
Pretty
Serialized
State
Stream
StringBuffer
UniqFM
UniqSet
......
......@@ -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}
......
......@@ -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
......
......@@ -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
Maybe [Linear.RegAllocStats])] )
cmmNativeGens _ _ _ _ [] impAcc profAcc _