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,
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
import VarEnv
import OrdList
import Unique
-import Util()
import UniqSupply
import FastString(sLit)
import Outputable
result
)
+fixC_ :: (a -> FCode a) -> FCode ()
+fixC_ fcode = fixC fcode >> return ()
--------------------------------------------------------
-- The code generator environment
| 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 -> <blah>
- -- 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
= 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
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
= 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
-- 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)
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)
cgStmtsToBlocks :: CmmAGraph -> FCode CmmGraph
cgStmtsToBlocks stmts
= do { us <- newUniqSupply
- ; return (initUs_ us (lgraphOfAGraph 0 stmts)) }
+ ; return (initUs_ us (lgraphOfAGraph stmts)) }
projects / ghc-hetmet.git / blobdiff