diff options
Diffstat (limited to 'compiler/codeGen')
| -rw-r--r-- | compiler/codeGen/StgCmmBind.hs | 4 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmExpr.hs | 20 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmExtCode.hs | 14 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmForeign.hs | 3 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmHeap.hs | 8 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmLayout.hs | 14 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmMonad.hs | 88 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmUtils.hs | 50 |
8 files changed, 132 insertions, 69 deletions
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 3c17160750..da87f965d5 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -553,7 +553,9 @@ mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node' (mkLblExpr fast_lbl) (map (CmmReg . CmmLocal) (node : arg_regs)) (initUpdFrameOff dflags) - emitProcWithConvention Slow Nothing slow_lbl (node : arg_regs) jump + tscope <- getTickScope + emitProcWithConvention Slow Nothing slow_lbl + (node : arg_regs) (jump, tscope) | otherwise = return () ----------------------------------------- diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 4a11fc98d8..ee635508fb 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -47,6 +47,7 @@ import FastString import Outputable import Control.Monad (when,void) +import Control.Arrow (first) #if __GLASGOW_HASKELL__ >= 709 import Prelude hiding ((<*>)) @@ -130,8 +131,8 @@ cgLetNoEscapeRhs cgLetNoEscapeRhs join_id local_cc bndr rhs = do { (info, rhs_code) <- cgLetNoEscapeRhsBody local_cc bndr rhs ; let (bid, _) = expectJust "cgLetNoEscapeRhs" $ maybeLetNoEscape info - ; let code = do { body <- getCode rhs_code - ; emitOutOfLine bid (body <*> mkBranch join_id) } + ; let code = do { (_, body) <- getCodeScoped rhs_code + ; emitOutOfLine bid (first (<*> mkBranch join_id) body) } ; return (info, code) } @@ -588,8 +589,8 @@ cgAlts _ _ _ _ = panic "cgAlts" ------------------- cgAlgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [StgAlt] - -> FCode ( Maybe CmmAGraph - , [(ConTagZ, CmmAGraph)] ) + -> FCode ( Maybe CmmAGraphScoped + , [(ConTagZ, CmmAGraphScoped)] ) cgAlgAltRhss gc_plan bndr alts = do { tagged_cmms <- cgAltRhss gc_plan bndr alts @@ -608,14 +609,14 @@ cgAlgAltRhss gc_plan bndr alts ------------------- cgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [StgAlt] - -> FCode [(AltCon, CmmAGraph)] + -> FCode [(AltCon, CmmAGraphScoped)] cgAltRhss gc_plan bndr alts = do dflags <- getDynFlags let base_reg = idToReg dflags bndr - cg_alt :: StgAlt -> FCode (AltCon, CmmAGraph) + cg_alt :: StgAlt -> FCode (AltCon, CmmAGraphScoped) cg_alt (con, bndrs, _uses, rhs) - = getCodeR $ + = getCodeScoped $ maybeAltHeapCheck gc_plan $ do { _ <- bindConArgs con base_reg bndrs ; _ <- cgExpr rhs @@ -840,11 +841,12 @@ emitEnter fun = do -- inlined in the RHS of the R1 assignment. ; let entry = entryCode dflags (closureInfoPtr dflags (CmmReg nodeReg)) the_call = toCall entry (Just lret) updfr_off off outArgs regs + ; tscope <- getTickScope ; emit $ copyout <*> mkCbranch (cmmIsTagged dflags (CmmReg nodeReg)) lret lcall <*> - outOfLine lcall the_call <*> - mkLabel lret <*> + outOfLine lcall (the_call,tscope) <*> + mkLabel lret tscope <*> copyin ; return (ReturnedTo lret off) } diff --git a/compiler/codeGen/StgCmmExtCode.hs b/compiler/codeGen/StgCmmExtCode.hs index ef6540534b..03f6a47d87 100644 --- a/compiler/codeGen/StgCmmExtCode.hs +++ b/compiler/codeGen/StgCmmExtCode.hs @@ -31,7 +31,7 @@ module StgCmmExtCode ( code, emit, emitLabel, emitAssign, emitStore, - getCode, getCodeR, + getCode, getCodeR, getCodeScoped, emitOutOfLine, withUpdFrameOff, getUpdFrameOff ) @@ -110,7 +110,8 @@ instance HasDynFlags CmmParse where loopDecls :: CmmParse a -> CmmParse a loopDecls (EC fcode) = EC $ \c e globalDecls -> do - (_, a) <- F.fixC (\ ~(decls, _) -> fcode c (addListToUFM e decls) globalDecls) + (_, a) <- F.fixC $ \ ~(decls, _) -> + fcode c (addListToUFM e decls) globalDecls return (globalDecls, a) @@ -219,7 +220,7 @@ emit :: CmmAGraph -> CmmParse () emit = code . F.emit emitLabel :: BlockId -> CmmParse () -emitLabel = code. F.emitLabel +emitLabel = code . F.emitLabel emitAssign :: CmmReg -> CmmExpr -> CmmParse () emitAssign l r = code (F.emitAssign l r) @@ -237,7 +238,12 @@ getCodeR (EC ec) = EC $ \c e s -> do ((s', r), gr) <- F.getCodeR (ec c e s) return (s', (r,gr)) -emitOutOfLine :: BlockId -> CmmAGraph -> CmmParse () +getCodeScoped :: CmmParse a -> CmmParse (a, CmmAGraphScoped) +getCodeScoped (EC ec) = EC $ \c e s -> do + ((s', r), gr) <- F.getCodeScoped (ec c e s) + return (s', (r,gr)) + +emitOutOfLine :: BlockId -> CmmAGraphScoped -> CmmParse () emitOutOfLine l g = code (F.emitOutOfLine l g) withUpdFrameOff :: UpdFrameOffset -> CmmParse () -> CmmParse () diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index c2e276ed0b..c38519ed13 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -228,6 +228,7 @@ emitForeignCall safety results target args k <- newLabelC let (off, _, copyout) = copyInOflow dflags NativeReturn (Young k) results [] -- see Note [safe foreign call convention] + tscope <- getTickScope emit $ ( mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth dflags))) (CmmLit (CmmBlock k)) @@ -238,7 +239,7 @@ emitForeignCall safety results target args , ret_args = off , ret_off = updfr_off , intrbl = playInterruptible safety }) - <*> mkLabel k + <*> mkLabel k tscope <*> copyout ) return (ReturnedTo k off) diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index eca118fd25..0e9eb6d658 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -420,7 +420,8 @@ altOrNoEscapeHeapCheck checkYield regs code = do lret <- newLabelC let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) regs [] lcont <- newLabelC - emitOutOfLine lret (copyin <*> mkBranch lcont) + tscope <- getTickScope + emitOutOfLine lret (copyin <*> mkBranch lcont, tscope) emitLabel lcont cannedGCReturnsTo checkYield False gc regs lret off code @@ -651,8 +652,9 @@ do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do CmmLit (zeroCLit dflags)] emit =<< mkCmmIfGoto yielding gc_id - emitOutOfLine gc_id $ - do_gc -- this is expected to jump back somewhere + tscope <- getTickScope + emitOutOfLine gc_id + (do_gc, tscope) -- this is expected to jump back somewhere -- Test for stack pointer exhaustion, then -- bump heap pointer, and test for heap exhaustion diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index af2d6619ea..c3d8873cfb 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -120,7 +120,8 @@ emitCallWithExtraStack (callConv, retConv) fun args extra_stack (off, _, copyin) = copyInOflow dflags retConv area res_regs [] copyout = mkCallReturnsTo dflags fun callConv args k off updfr_off extra_stack - emit (copyout <*> mkLabel k <*> copyin) + tscope <- getTickScope + emit (copyout <*> mkLabel k tscope <*> copyin) return (ReturnedTo k off) } @@ -224,15 +225,16 @@ slowCall fun stg_args let correct_arity = cmmEqWord dflags (funInfoArity dflags fun_iptr) (mkIntExpr dflags n_args) + tscope <- getTickScope emit (mkCbranch (cmmIsTagged dflags funv) is_tagged_lbl slow_lbl - <*> mkLabel is_tagged_lbl + <*> mkLabel is_tagged_lbl tscope <*> mkCbranch correct_arity fast_lbl slow_lbl - <*> mkLabel fast_lbl + <*> mkLabel fast_lbl tscope <*> fast_code <*> mkBranch end_lbl - <*> mkLabel slow_lbl + <*> mkLabel slow_lbl tscope <*> slow_code - <*> mkLabel end_lbl) + <*> mkLabel end_lbl tscope) return r else do @@ -536,7 +538,7 @@ emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body emitClosureAndInfoTable :: CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode () emitClosureAndInfoTable info_tbl conv args body - = do { blks <- getCode body + = do { (_, blks) <- getCodeScoped body ; let entry_lbl = toEntryLbl (cit_lbl info_tbl) ; emitProcWithConvention conv (Just info_tbl) entry_lbl args blks } diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 252a815ee6..cf78d512cc 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -23,7 +23,7 @@ module StgCmmMonad ( emitTick, getCmm, aGraphToGraph, - getCodeR, getCode, getHeapUsage, + getCodeR, getCode, getCodeScoped, getHeapUsage, mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto, mkCall, mkCmmCall, @@ -36,6 +36,7 @@ module StgCmmMonad ( withSequel, getSequel, setTickyCtrLabel, getTickyCtrLabel, + tickScope, getTickScope, withUpdFrameOff, getUpdFrameOff, initUpdFrameOff, @@ -181,10 +182,11 @@ data CgInfoDownwards -- information only passed *downwards* by the monad 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 - cgd_self_loop :: Maybe SelfLoopInfo -- Which tail calls can be compiled + cgd_self_loop :: Maybe SelfLoopInfo,-- Which tail calls can be compiled -- as local jumps? See Note -- [Self-recursive tail calls] in -- StgCmmExpr + cgd_tick_scope:: CmmTickScope -- Tick scope for new blocks & ticks } type CgBindings = IdEnv CgIdInfo @@ -305,7 +307,8 @@ initCgInfoDown dflags mod , cgd_updfr_off = initUpdFrameOff dflags , cgd_ticky = mkTopTickyCtrLabel , cgd_sequel = initSequel - , cgd_self_loop = Nothing } + , cgd_self_loop = Nothing + , cgd_tick_scope= GlobalScope } initSequel :: Sequel initSequel = Return False @@ -557,6 +560,27 @@ setTickyCtrLabel ticky code = do info <- getInfoDown withInfoDown code (info {cgd_ticky = ticky}) +-- ---------------------------------------------------------------------------- +-- Manage tick scopes + +-- | The current tick scope. We will assign this to generated blocks. +getTickScope :: FCode CmmTickScope +getTickScope = do + info <- getInfoDown + return (cgd_tick_scope info) + +-- | Places blocks generated by the given code into a fresh +-- (sub-)scope. This will make sure that Cmm annotations in our scope +-- will apply to the Cmm blocks generated therein - but not the other +-- way around. +tickScope :: FCode a -> FCode a +tickScope code = do + info <- getInfoDown + if not (gopt Opt_Debug (cgd_dflags info)) then code else do + u <- newUnique + let scope' = SubScope u (cgd_tick_scope info) + withInfoDown code info{ cgd_tick_scope = scope' } + -------------------------------------------------------- -- Forking @@ -645,6 +669,20 @@ getCodeR fcode getCode :: FCode a -> FCode CmmAGraph getCode fcode = do { (_,stmts) <- getCodeR fcode; return stmts } +-- | Generate code into a fresh tick (sub-)scope and gather generated code +getCodeScoped :: FCode a -> FCode (a, CmmAGraphScoped) +getCodeScoped fcode + = do { state1 <- getState + ; ((a, tscope), state2) <- + tickScope $ + flip withState state1 { cgs_stmts = mkNop } $ + do { a <- fcode + ; scp <- getTickScope + ; return (a, scp) } + ; setState $ state2 { cgs_stmts = cgs_stmts state1 } + ; return (a, (cgs_stmts state2, tscope)) } + + -- 'getHeapUsage' applies a function to the amount of heap that it uses. -- It initialises the heap usage to zeros, and passes on an unchanged -- heap usage. @@ -675,7 +713,8 @@ emitCgStmt stmt } emitLabel :: BlockId -> FCode () -emitLabel id = emitCgStmt (CgLabel id) +emitLabel id = do tscope <- getTickScope + emitCgStmt (CgLabel id tscope) emitComment :: FastString -> FCode () #if 0 /* def DEBUG */ @@ -708,8 +747,8 @@ emitDecl decl = do { state <- getState ; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } } -emitOutOfLine :: BlockId -> CmmAGraph -> FCode () -emitOutOfLine l stmts = emitCgStmt (CgFork l stmts) +emitOutOfLine :: BlockId -> CmmAGraphScoped -> FCode () +emitOutOfLine l (stmts, tscope) = emitCgStmt (CgFork l stmts tscope) emitProcWithStackFrame :: Convention -- entry convention @@ -717,7 +756,7 @@ emitProcWithStackFrame -> CLabel -- label for the proc -> [CmmFormal] -- stack frame -> [CmmFormal] -- arguments - -> CmmAGraph -- code + -> CmmAGraphScoped -- code -> Bool -- do stack layout? -> FCode () @@ -725,26 +764,29 @@ emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False = do { dflags <- getDynFlags ; emitProc_ mb_info lbl [] blocks (widthInBytes (wordWidth dflags)) False } -emitProcWithStackFrame conv mb_info lbl stk_args args blocks True -- do layout +emitProcWithStackFrame conv mb_info lbl stk_args args (graph, tscope) True + -- do layout = do { dflags <- getDynFlags ; let (offset, live, entry) = mkCallEntry dflags conv args stk_args - ; emitProc_ mb_info lbl live (entry MkGraph.<*> blocks) offset True + graph' = entry MkGraph.<*> graph + ; emitProc_ mb_info lbl live (graph', tscope) offset True } emitProcWithStackFrame _ _ _ _ _ _ _ = panic "emitProcWithStackFrame" emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel -> [CmmFormal] - -> CmmAGraph + -> CmmAGraphScoped -> FCode () emitProcWithConvention conv mb_info lbl args blocks = emitProcWithStackFrame conv mb_info lbl [] args blocks True -emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraph -> Int -> FCode () +emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped + -> Int -> FCode () emitProc mb_info lbl live blocks offset = emitProc_ mb_info lbl live blocks offset True -emitProc_ :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraph -> Int -> Bool - -> FCode () +emitProc_ :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped + -> Int -> Bool -> FCode () emitProc_ mb_info lbl live blocks offset do_layout = do { dflags <- getDynFlags ; l <- newLabelC @@ -779,24 +821,27 @@ getCmm code mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> FCode CmmAGraph mkCmmIfThenElse e tbranch fbranch = do + tscp <- getTickScope endif <- newLabelC tid <- newLabelC fid <- newLabelC - return $ mkCbranch e tid fid MkGraph.<*> - mkLabel tid MkGraph.<*> tbranch MkGraph.<*> mkBranch endif MkGraph.<*> - mkLabel fid MkGraph.<*> fbranch MkGraph.<*> mkLabel endif + return $ catAGraphs [ mkCbranch e tid fid + , mkLabel tid tscp, tbranch, mkBranch endif + , mkLabel fid tscp, fbranch, mkLabel endif tscp ] mkCmmIfGoto :: CmmExpr -> BlockId -> FCode CmmAGraph mkCmmIfGoto e tid = do endif <- newLabelC - return $ mkCbranch e tid endif MkGraph.<*> mkLabel endif + tscp <- getTickScope + return $ catAGraphs [ mkCbranch e tid endif, mkLabel endif tscp ] mkCmmIfThen :: CmmExpr -> CmmAGraph -> FCode CmmAGraph mkCmmIfThen e tbranch = do endif <- newLabelC tid <- newLabelC - return $ mkCbranch e tid endif MkGraph.<*> - mkLabel tid MkGraph.<*> tbranch MkGraph.<*> mkLabel endif + tscp <- getTickScope + return $ catAGraphs [ mkCbranch e tid endif + , mkLabel tid tscp, tbranch, mkLabel endif tscp ] mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmActual] @@ -804,10 +849,11 @@ mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmActual] mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do dflags <- getDynFlags k <- newLabelC + tscp <- getTickScope let area = Young k (off, _, copyin) = copyInOflow dflags retConv area results [] copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack - return (copyout MkGraph.<*> mkLabel k MkGraph.<*> copyin) + return $ catAGraphs [copyout, mkLabel k tscp, copyin] mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmActual] -> UpdFrameOffset -> FCode CmmAGraph @@ -818,7 +864,7 @@ mkCmmCall f results actuals updfr_off -- ---------------------------------------------------------------------------- -- turn CmmAGraph into CmmGraph, for making a new proc. -aGraphToGraph :: CmmAGraph -> FCode CmmGraph +aGraphToGraph :: CmmAGraphScoped -> FCode CmmGraph aGraphToGraph stmts = do { l <- newLabelC ; return (labelAGraph l stmts) } diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index d47a01661a..5e8944df4a 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -453,11 +453,12 @@ mustFollow :: Stmt -> Stmt -> Bool ------------------------------------------------------------------------- -emitSwitch :: CmmExpr -- Tag to switch on - -> [(ConTagZ, CmmAGraph)] -- Tagged branches - -> Maybe CmmAGraph -- Default branch (if any) - -> ConTagZ -> ConTagZ -- Min and Max possible values; behaviour - -- outside this range is undefined +emitSwitch :: CmmExpr -- Tag to switch on + -> [(ConTagZ, CmmAGraphScoped)] -- Tagged branches + -> Maybe CmmAGraphScoped -- Default branch (if any) + -> ConTagZ -> ConTagZ -- Min and Max possible values; + -- behaviour outside this range is + -- undefined -> FCode () emitSwitch tag_expr branches mb_deflt lo_tag hi_tag = do { dflags <- getDynFlags @@ -467,18 +468,19 @@ emitSwitch tag_expr branches mb_deflt lo_tag hi_tag | otherwise = False -mkCmmSwitch :: Bool -- True <=> never generate a - -- conditional tree - -> CmmExpr -- Tag to switch on - -> [(ConTagZ, CmmAGraph)] -- Tagged branches - -> Maybe CmmAGraph -- Default branch (if any) - -> ConTagZ -> ConTagZ -- Min and Max possible values; behaviour - -- outside this range is undefined +mkCmmSwitch :: Bool -- True <=> never generate a + -- conditional tree + -> CmmExpr -- Tag to switch on + -> [(ConTagZ, CmmAGraphScoped)] -- Tagged branches + -> Maybe CmmAGraphScoped -- Default branch (if any) + -> ConTagZ -> ConTagZ -- Min and Max possible values; + -- behaviour outside this range is + -- undefined -> FCode () -- First, two rather common cases in which there is no work to do -mkCmmSwitch _ _ [] (Just code) _ _ = emit code -mkCmmSwitch _ _ [(_,code)] Nothing _ _ = emit code +mkCmmSwitch _ _ [] (Just code) _ _ = emit (fst code) +mkCmmSwitch _ _ [(_,code)] Nothing _ _ = emit (fst code) -- Right, off we go mkCmmSwitch via_C tag_expr branches mb_deflt lo_tag hi_tag = do @@ -634,17 +636,17 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C is_lo (t,_) = t < mid_tag -------------- -emitCmmLitSwitch :: CmmExpr -- Tag to switch on - -> [(Literal, CmmAGraph)] -- Tagged branches - -> CmmAGraph -- Default branch (always) - -> FCode () -- Emit the code +emitCmmLitSwitch :: CmmExpr -- Tag to switch on + -> [(Literal, CmmAGraphScoped)] -- Tagged branches + -> CmmAGraphScoped -- Default branch (always) + -> FCode () -- Emit the code -- Used for general literals, whose size might not be a word, -- where there is always a default case, and where we don't know -- the range of values for certain. For simplicity we always generate a tree. -- -- ToDo: for integers we could do better here, perhaps by generalising -- mk_switch and using that. --SDM 15/09/2004 -emitCmmLitSwitch _scrut [] deflt = emit deflt +emitCmmLitSwitch _scrut [] deflt = emit $ fst deflt emitCmmLitSwitch scrut branches deflt = do scrut' <- assignTemp' scrut join_lbl <- newLabelC @@ -685,7 +687,7 @@ mk_lit_switch scrut deflt_blk_id branches -------------- -label_default :: BlockId -> Maybe CmmAGraph -> FCode (Maybe BlockId) +label_default :: BlockId -> Maybe CmmAGraphScoped -> FCode (Maybe BlockId) label_default _ Nothing = return Nothing label_default join_lbl (Just code) @@ -693,7 +695,7 @@ label_default join_lbl (Just code) return (Just lbl) -------------- -label_branches :: BlockId -> [(a,CmmAGraph)] -> FCode [(a,BlockId)] +label_branches :: BlockId -> [(a,CmmAGraphScoped)] -> FCode [(a,BlockId)] label_branches _join_lbl [] = return [] label_branches join_lbl ((tag,code):branches) @@ -702,14 +704,14 @@ label_branches join_lbl ((tag,code):branches) return ((tag,lbl):branches') -------------- -label_code :: BlockId -> CmmAGraph -> FCode BlockId +label_code :: BlockId -> CmmAGraphScoped -> FCode BlockId -- label_code J code -- generates -- [L: code; goto J] -- and returns L -label_code join_lbl code = do +label_code join_lbl (code,tsc) = do lbl <- newLabelC - emitOutOfLine lbl (code MkGraph.<*> mkBranch join_lbl) + emitOutOfLine lbl (code MkGraph.<*> mkBranch join_lbl, tsc) return lbl -------------- |