X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FStgCmmMonad.hs;h=919a5d0eee0bae1418cb586e3dab81f2d9ddd328;hp=2249a463df45dab1568352185e856d9354814209;hb=e2e0785eb7f4efd9f7791d913cdfdfd03148cd86;hpb=e6243a818496aad82b6f47511d3bd9bc800f747d diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 2249a46..919a5d0 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -10,7 +10,7 @@ module StgCmmMonad ( FCode, -- type initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs, - returnFC, fixC, nopC, whenC, + returnFC, fixC, fixC_, nopC, whenC, newUnique, newUniqSupply, emit, emitData, emitProc, emitProcWithConvention, emitSimpleProc, @@ -51,10 +51,11 @@ module StgCmmMonad ( import StgCmmClosure import DynFlags -import MkZipCfgCmm -import ZipCfgCmmRep (UpdFrameOffset) +import MkGraph import BlockId -import Cmm +import CmmDecl +import CmmExpr +import CmmNode (UpdFrameOffset) import CLabel import TyCon ( PrimRep ) import SMRep @@ -63,7 +64,6 @@ import Id import VarEnv import OrdList import Unique -import Util() import UniqSupply import FastString(sLit) import Outputable @@ -149,6 +149,8 @@ fixC fcode = FCode ( result ) +fixC_ :: (a -> FCode a) -> FCode () +fixC_ fcode = fixC fcode >> return () -------------------------------------------------------- -- The code generator environment @@ -209,12 +211,13 @@ data Sequel | AssignTo [LocalReg] -- Put result(s) in these regs and fall through -- NB: no void arguments here - C_SRT -- Here are the statics live in the continuation - -- E.g. case (case x# of 0# -> a; DEFAULT -> b) of { - -- r -> - -- When compiling the nested case, remember to put the - -- result in r, and fall through - + Bool -- Should we adjust the heap pointer back to recover + -- space that's unused on this path? + -- We need to do this only if the expression may + -- allocate (e.g. it's a foreign call or allocating primOp) +instance Show Sequel where + show (Return _) = "Sequel: Return" + show (AssignTo _ _) = "Sequel: Assign" initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards initCgInfoDown dflags mod @@ -241,7 +244,7 @@ data CgState = MkCgState { cgs_stmts :: CmmAGraph, -- Current procedure - cgs_tops :: OrdList CmmTopZ, + cgs_tops :: OrdList CmmTop, -- Other procedures and data blocks in this compilation unit -- Both are ordered only so that we can -- reduce forward references, when it's easy to do so @@ -257,7 +260,9 @@ data CgState data HeapUsage = HeapUsage { virtHp :: VirtualHpOffset, -- Virtual offset of highest-allocated word + -- Incremented whenever we allocate realHp :: VirtualHpOffset -- realHp: Virtual offset of real heap ptr + -- Used in instruction addressing modes } type VirtualHpOffset = WordOff @@ -506,7 +511,7 @@ forkProc body_code = do { info_down <- getInfoDown ; us <- newUniqSupply ; state <- getState - ; let info_down' = info_down { cgd_sequel = initSequel } + ; let info_down' = info_down -- { cgd_sequel = initSequel } fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } (result, fork_state_out) = doFCode body_code info_down' fork_state_in ; setState $ state `addCodeBlocksFrom` fork_state_out @@ -532,22 +537,22 @@ forkAlts :: [FCode a] -> FCode [a] -- that the virtual Hp is moved on to the worst virtual Hp for the branches forkAlts branch_fcodes - = do { info_down <- getInfoDown - ; us <- newUniqSupply - ; state <- getState - ; let compile us branch - = (us2, doFCode branch info_down branch_state) - where - (us1,us2) = splitUniqSupply us - branch_state = (initCgState us1) { - cgs_binds = cgs_binds state, - cgs_hp_usg = cgs_hp_usg state } - - (_us, results) = mapAccumL compile us branch_fcodes - (branch_results, branch_out_states) = unzip results - ; setState $ foldl stateIncUsage state branch_out_states - -- NB foldl. state is the *left* argument to stateIncUsage - ; return branch_results } + = do { info_down <- getInfoDown + ; us <- newUniqSupply + ; state <- getState + ; let compile us branch + = (us2, doFCode branch info_down branch_state) + where + (us1,us2) = splitUniqSupply us + branch_state = (initCgState us1) { + cgs_binds = cgs_binds state, + cgs_hp_usg = cgs_hp_usg state } + + (_us, results) = mapAccumL compile us branch_fcodes + (branch_results, branch_out_states) = unzip results + ; setState $ foldl stateIncUsage state branch_out_states + -- NB foldl. state is the *left* argument to stateIncUsage + ; return branch_results } -- collect the code emitted by an FCode computation getCodeR :: FCode a -> FCode (a, CmmAGraph) @@ -595,24 +600,25 @@ emitData sect lits where data_block = CmmData sect lits -emitProcWithConvention :: Convention -> CmmInfo -> CLabel -> CmmFormals -> +emitProcWithConvention :: Convention -> CmmInfoTable -> CLabel -> CmmFormals -> CmmAGraph -> FCode () emitProcWithConvention conv info lbl args blocks = do { us <- newUniqSupply - ; let (offset, entry) = mkEntry (mkBlockId $ uniqFromSupply us) conv args - blks = initUs_ us $ lgraphOfAGraph offset $ entry <*> blocks - ; let proc_block = CmmProc info lbl args blks + ; let (offset, entry) = mkCallEntry conv args + blks = initUs_ us $ lgraphOfAGraph $ entry <*> blocks + ; let sinfo = StackInfo {arg_space = offset, updfr_space = Just initUpdFrameOff} + proc_block = CmmProc (TopInfo {info_tbl=info, stack_info=sinfo}) lbl blks ; state <- getState ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } } -emitProc :: CmmInfo -> CLabel -> CmmFormals -> CmmAGraph -> FCode () -emitProc = emitProcWithConvention Native +emitProc :: CmmInfoTable -> CLabel -> CmmFormals -> CmmAGraph -> FCode () +emitProc = emitProcWithConvention NativeNodeCall emitSimpleProc :: CLabel -> CmmAGraph -> FCode () emitSimpleProc lbl code = - emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] code + emitProc CmmNonInfoTable lbl [] code -getCmm :: FCode () -> FCode CmmZ +getCmm :: FCode () -> FCode Cmm -- Get all the CmmTops (there should be no stmts) -- Return a single Cmm which may be split from other Cmms by -- object splitting (at a later stage) @@ -632,5 +638,5 @@ getCmm code cgStmtsToBlocks :: CmmAGraph -> FCode CmmGraph cgStmtsToBlocks stmts = do { us <- newUniqSupply - ; return (initUs_ us (lgraphOfAGraph 0 stmts)) } + ; return (initUs_ us (lgraphOfAGraph stmts)) }