diff options
Diffstat (limited to 'compiler/codeGen')
| -rw-r--r-- | compiler/codeGen/CgInfoTbls.hs | 2 | ||||
| -rw-r--r-- | compiler/codeGen/CgMonad.lhs | 13 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmBind.hs | 2 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmClosure.hs | 2 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmLayout.hs | 2 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmMonad.hs | 20 |
6 files changed, 26 insertions, 15 deletions
diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs index 80b3b06ce3..133d78d371 100644 --- a/compiler/codeGen/CgInfoTbls.hs +++ b/compiler/codeGen/CgInfoTbls.hs @@ -366,5 +366,5 @@ emitInfoTableAndCode -> Code emitInfoTableAndCode entry_ret_lbl info args blocks - = emitProc info entry_ret_lbl args blocks + = emitProc (Just info) entry_ret_lbl args blocks diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs index 71da9e9ae0..f776af3b3b 100644 --- a/compiler/codeGen/CgMonad.lhs +++ b/compiler/codeGen/CgMonad.lhs @@ -709,11 +709,16 @@ emitDecl decl = do state <- getState setState $ state { cgs_tops = cgs_tops state `snocOL` decl } -emitProc :: CmmInfoTable -> CLabel -> [CmmFormal] -> [CmmBasicBlock] -> Code -emitProc info lbl [] blocks = do - let proc_block = CmmProc info lbl (ListGraph blocks) +emitProc :: Maybe CmmInfoTable -> CLabel -> [CmmFormal] -> [CmmBasicBlock] -> Code +emitProc mb_info lbl [] blocks = do + let proc_block = CmmProc infos lbl (ListGraph blocks) state <- getState setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } + where + infos = case (blocks,mb_info) of + (b:_, Just info) -> mapSingleton (blockId b) info + _other -> mapEmpty + emitProc _ _ (_:_) _ = panic "emitProc called with nonempty args" -- Emit a procedure whose body is the specified code; no info table @@ -721,7 +726,7 @@ emitSimpleProc :: CLabel -> Code -> Code emitSimpleProc lbl code = do stmts <- getCgStmts code blks <- cgStmtsToBlocks stmts - emitProc CmmNonInfoTable lbl [] blks + emitProc Nothing lbl [] blks -- Get all the CmmTops (there should be no stmts) -- Return a single Cmm which may be split from other Cmms by diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 2bec4208a1..55307216c3 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -470,7 +470,7 @@ mkSlowEntryCode cl_info arg_regs -- function closure is already in `Node' jump = mkDirectJump (mkLblExpr fast_lbl) (map (CmmReg . CmmLocal) arg_regs) initUpdFrameOff - emitProcWithConvention Slow CmmNonInfoTable slow_lbl arg_regs jump + emitProcWithConvention Slow Nothing slow_lbl arg_regs jump | otherwise = return () ----------------------------------------- diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index 73b3d1639e..7a9c8414ee 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -934,5 +934,3 @@ staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool staticClosureNeedsLink has_srt CmmInfoTable{ cit_rep = smrep } | isConRep smrep = not (isStaticNoCafCon smrep) | otherwise = has_srt -- needsSRT (cit_srt info_tbl) -staticClosureNeedsLink _ _ = False - diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index 0e9cebfea4..5bcb67f82b 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -542,7 +542,7 @@ emitClosureAndInfoTable :: emitClosureAndInfoTable info_tbl conv args body = do { blks <- getCode body ; let entry_lbl = toEntryLbl (cit_lbl info_tbl) - ; emitProcWithConvention conv info_tbl entry_lbl args blks + ; emitProcWithConvention conv (Just info_tbl) entry_lbl args blks } ----------------------------------------------------------------------------- diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 602bdebcad..d1732ed2b7 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -66,6 +66,7 @@ module StgCmmMonad ( import Cmm import StgCmmClosure import DynFlags +import Hoopl import MkGraph import BlockId import CLabel @@ -639,23 +640,30 @@ emitDecl decl emitOutOfLine :: BlockId -> CmmAGraph -> FCode () emitOutOfLine l stmts = emitCgStmt (CgFork l stmts) -emitProcWithConvention :: Convention -> CmmInfoTable -> CLabel -> [CmmFormal] -> - CmmAGraph -> FCode () -emitProcWithConvention conv info lbl args blocks +emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel + -> [CmmFormal] -> CmmAGraph -> FCode () +emitProcWithConvention conv mb_info lbl args blocks = do { us <- newUniqSupply ; 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 + tinfo = TopInfo {info_tbls = infos, stack_info=sinfo} + proc_block = CmmProc tinfo lbl blks + + infos | Just info <- mb_info + = mapSingleton (g_entry blks) info + | otherwise + = mapEmpty + ; state <- getState ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } } -emitProc :: CmmInfoTable -> CLabel -> [CmmFormal] -> CmmAGraph -> FCode () +emitProc :: Maybe CmmInfoTable -> CLabel -> [CmmFormal] -> CmmAGraph -> FCode () emitProc = emitProcWithConvention NativeNodeCall emitSimpleProc :: CLabel -> CmmAGraph -> FCode () emitSimpleProc lbl code = - emitProc CmmNonInfoTable lbl [] code + emitProc Nothing lbl [] code getCmm :: FCode () -> FCode CmmGroup -- Get all the CmmTops (there should be no stmts) |