X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FStgCmmMonad.hs;h=919a5d0eee0bae1418cb586e3dab81f2d9ddd328;hp=365263941e9587c8c609b527b86e2008761144bc;hb=e2e0785eb7f4efd9f7791d913cdfdfd03148cd86;hpb=176fa33f17dd78355cc572e006d2ab26898e2c69 diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 3652639..919a5d0 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -10,10 +10,10 @@ 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, emitSimpleProc, + emit, emitData, emitProc, emitProcWithConvention, emitSimpleProc, getCmm, cgStmtsToBlocks, getCodeR, getCode, getHeapUsage, @@ -28,6 +28,8 @@ module StgCmmMonad ( setSRTLabel, getSRTLabel, setTickyCtrLabel, getTickyCtrLabel, + withUpdFrameOff, getUpdFrameOff, initUpdFrameOff, + HeapUsage(..), VirtualHpOffset, initHpUsage, getHpUsage, setHpUsage, heapHWM, setVirtHp, getVirtHp, setRealHp, @@ -49,9 +51,11 @@ module StgCmmMonad ( import StgCmmClosure import DynFlags -import MkZipCfgCmm +import MkGraph import BlockId -import Cmm +import CmmDecl +import CmmExpr +import CmmNode (UpdFrameOffset) import CLabel import TyCon ( PrimRep ) import SMRep @@ -60,7 +64,6 @@ import Id import VarEnv import OrdList import Unique -import Util() import UniqSupply import FastString(sLit) import Outputable @@ -146,6 +149,8 @@ fixC fcode = FCode ( result ) +fixC_ :: (a -> FCode a) -> FCode () +fixC_ fcode = fixC fcode >> return () -------------------------------------------------------- -- The code generator environment @@ -157,12 +162,13 @@ fixC fcode = FCode ( data CgInfoDownwards -- information only passed *downwards* by the monad = MkCgInfoDown { - cgd_dflags :: DynFlags, - cgd_mod :: Module, -- Module being compiled - cgd_statics :: CgBindings, -- [Id -> info] : static environment - cgd_srt_lbl :: CLabel, -- Label of the current top-level SRT - cgd_ticky :: CLabel, -- Current destination for ticky counts - cgd_sequel :: Sequel -- What to do at end of basic block + cgd_dflags :: DynFlags, + cgd_mod :: Module, -- Module being compiled + cgd_statics :: CgBindings, -- [Id -> info] : static environment + cgd_srt_lbl :: CLabel, -- Label of the current top-level SRT + cgd_updfr_off :: UpdFrameOffset, -- Size of current update frame + cgd_ticky :: CLabel, -- Current destination for ticky counts + cgd_sequel :: Sequel -- What to do at end of basic block } type CgBindings = IdEnv CgIdInfo @@ -173,10 +179,10 @@ data CgIdInfo -- Can differ from the Id at occurrence sites by -- virtue of being externalised, for splittable C , cg_lf :: LambdaFormInfo - , cg_loc :: CgLoc + , cg_loc :: CgLoc -- CmmExpr for the *tagged* value , cg_rep :: PrimRep -- Cache for (idPrimRep id) , cg_tag :: {-# UNPACK #-} !DynTag -- Cache for (lfDynTag cg_lf) - } + } data CgLoc = CmmLoc CmmExpr -- A stable CmmExpr; that is, one not mentioning @@ -205,22 +211,30 @@ 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 - - + 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 - = MkCgInfoDown { cgd_dflags = dflags, - cgd_mod = mod, - cgd_statics = emptyVarEnv, - cgd_srt_lbl = error "initC: srt_lbl", - cgd_ticky = mkTopTickyCtrLabel, - cgd_sequel = initSequel } + = MkCgInfoDown { cgd_dflags = dflags, + cgd_mod = mod, + cgd_statics = emptyVarEnv, + cgd_srt_lbl = error "initC: srt_lbl", + cgd_updfr_off = initUpdFrameOff, + cgd_ticky = mkTopTickyCtrLabel, + cgd_sequel = initSequel } initSequel :: Sequel initSequel = Return False +initUpdFrameOff :: UpdFrameOffset +initUpdFrameOff = widthInBytes wordWidth -- space for the RA + -------------------------------------------------------- -- The code generator state @@ -230,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 @@ -240,23 +254,25 @@ data CgState -- the info-down part cgs_hp_usg :: HeapUsage, - + cgs_uniqs :: UniqSupply } 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 initCgState :: UniqSupply -> CgState initCgState uniqs - = MkCgState { cgs_stmts = mkNop, cgs_tops = nilOL, - cgs_binds = emptyVarEnv, - cgs_hp_usg = initHpUsage, - cgs_uniqs = uniqs } + = MkCgState { cgs_stmts = mkNop, cgs_tops = nilOL, + cgs_binds = emptyVarEnv, + cgs_hp_usg = initHpUsage, + cgs_uniqs = uniqs } stateIncUsage :: CgState -> CgState -> CgState -- stateIncUsage@ e1 e2 incorporates in e1 @@ -408,6 +424,26 @@ setSRTLabel srt_lbl code withInfoDown code (info { cgd_srt_lbl = srt_lbl}) -- ---------------------------------------------------------------------------- +-- Get/set the size of the update frame + +-- We keep track of the size of the update frame so that we +-- can set the stack pointer to the proper address on return +-- (or tail call) from the closure. +-- There should be at most one update frame for each closure. +-- Note: I'm including the size of the original return address +-- in the size of the update frame -- hence the default case on `get'. + +withUpdFrameOff :: UpdFrameOffset -> FCode () -> FCode () +withUpdFrameOff size code + = do { info <- getInfoDown + ; withInfoDown code (info {cgd_updfr_off = size }) } + +getUpdFrameOff :: FCode UpdFrameOffset +getUpdFrameOff + = do { info <- getInfoDown + ; return $ cgd_updfr_off info } + +-- ---------------------------------------------------------------------------- -- Get/set the current ticky counter label getTickyCtrLabel :: FCode CLabel @@ -440,7 +476,8 @@ forkClosureBody body_code = do { info <- getInfoDown ; us <- newUniqSupply ; state <- getState - ; let body_info_down = info { cgd_sequel = initSequel } + ; let body_info_down = info { cgd_sequel = initSequel + , cgd_updfr_off = initUpdFrameOff } fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } ((),fork_state_out) = doFCode body_code body_info_down fork_state_in @@ -455,8 +492,9 @@ forkStatics body_code = do { info <- getInfoDown ; us <- newUniqSupply ; state <- getState - ; let rhs_info_down = info { cgd_statics = cgs_binds state, - cgd_sequel = initSequel } + ; let rhs_info_down = info { cgd_statics = cgs_binds state + , cgd_sequel = initSequel + , cgd_updfr_off = initUpdFrameOff } (result, fork_state_out) = doFCode body_code rhs_info_down (initCgState us) ; setState (state `addCodeBlocksFrom` fork_state_out) @@ -473,9 +511,9 @@ forkProc body_code = do { info_down <- getInfoDown ; us <- newUniqSupply ; state <- getState - ; let fork_state_in = (initCgState us) - { cgs_binds = cgs_binds state } - (result, fork_state_out) = doFCode body_code info_down fork_state_in + ; 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 ; return result } @@ -499,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) @@ -562,22 +600,25 @@ emitData sect lits where data_block = CmmData sect lits -emitProc :: CmmInfo -> CLabel -> CmmFormals -> CmmAGraph -> FCode () -emitProc info lbl args blocks +emitProcWithConvention :: Convention -> CmmInfoTable -> CLabel -> CmmFormals -> + CmmAGraph -> FCode () +emitProcWithConvention conv info lbl args blocks = do { us <- newUniqSupply - ; let (offset, entry) = mkEntry (mkBlockId $ uniqFromSupply us) Native args - blks = initUs_ us $ lgraphOfAGraph offset $ entry <*> blocks - -- ; blks <- cgStmtsToBlocks 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 :: CmmInfoTable -> CLabel -> CmmFormals -> CmmAGraph -> FCode () +emitProc = emitProcWithConvention NativeNodeCall + emitSimpleProc :: CLabel -> CmmAGraph -> FCode () --- Emit a procedure whose body is the specified code; no info table -emitSimpleProc lbl code - = emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] code +emitSimpleProc 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) @@ -597,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)) }