diff options
Diffstat (limited to 'compiler/codeGen')
| -rw-r--r-- | compiler/codeGen/StgCmmHeap.hs | 7 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmMonad.hs | 40 |
2 files changed, 35 insertions, 12 deletions
diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index ebff4402d0..aa8855660b 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -636,7 +636,8 @@ do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do case mb_stk_hwm of Nothing -> return () - Just stk_hwm -> tickyStackCheck >> (emit =<< mkCmmIfGoto (sp_oflo stk_hwm) gc_id) + Just stk_hwm -> tickyStackCheck + >> (emit =<< mkCmmIfGoto' (sp_oflo stk_hwm) gc_id (Just False) ) -- Emit new label that might potentially be a header -- of a self-recursive tail call. @@ -651,14 +652,14 @@ do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do then do tickyHeapCheck emitAssign hpReg bump_hp - emit =<< mkCmmIfThen hp_oflo (alloc_n <*> mkBranch gc_id) + emit =<< mkCmmIfThen' hp_oflo (alloc_n <*> mkBranch gc_id) (Just False) else do when (checkYield && not (gopt Opt_OmitYields dflags)) $ do -- Yielding if HpLim == 0 let yielding = CmmMachOp (mo_wordEq dflags) [CmmReg (CmmGlobal HpLim), CmmLit (zeroCLit dflags)] - emit =<< mkCmmIfGoto yielding gc_id + emit =<< mkCmmIfGoto' yielding gc_id (Just False) tscope <- getTickScope emitOutOfLine gc_id diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 836bf30f29..2184e12a8c 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -26,6 +26,8 @@ module StgCmmMonad ( getCodeR, getCode, getCodeScoped, getHeapUsage, mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto, + mkCmmIfThenElse', mkCmmIfThen', mkCmmIfGoto', + mkCall, mkCmmCall, forkClosureBody, forkLneBody, forkAlts, codeOnly, @@ -833,30 +835,50 @@ getCmm code mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> FCode CmmAGraph -mkCmmIfThenElse e tbranch fbranch = do +mkCmmIfThenElse e tbranch fbranch = mkCmmIfThenElse' e tbranch fbranch Nothing + +mkCmmIfThenElse' :: CmmExpr -> CmmAGraph -> CmmAGraph + -> Maybe Bool -> FCode CmmAGraph +mkCmmIfThenElse' e tbranch fbranch likely = do tscp <- getTickScope endif <- newLabelC tid <- newLabelC fid <- newLabelC - return $ catAGraphs [ mkCbranch e tid fid Nothing - , mkLabel tid tscp, tbranch, mkBranch endif - , mkLabel fid tscp, fbranch, mkLabel endif tscp ] + + let + (test, then_, else_, likely') = case likely of + Just False | Just e' <- maybeInvertCmmExpr e + -- currently NCG doesn't know about likely + -- annotations. We manually switch then and + -- else branch so the likely false branch + -- becomes a fallthrough. + -> (e', fbranch, tbranch, Just True) + _ -> (e, tbranch, fbranch, likely) + + return $ catAGraphs [ mkCbranch test tid fid likely' + , mkLabel tid tscp, then_, mkBranch endif + , mkLabel fid tscp, else_, mkLabel endif tscp ] mkCmmIfGoto :: CmmExpr -> BlockId -> FCode CmmAGraph -mkCmmIfGoto e tid = do +mkCmmIfGoto e tid = mkCmmIfGoto' e tid Nothing + +mkCmmIfGoto' :: CmmExpr -> BlockId -> Maybe Bool -> FCode CmmAGraph +mkCmmIfGoto' e tid l = do endif <- newLabelC tscp <- getTickScope - return $ catAGraphs [ mkCbranch e tid endif Nothing, mkLabel endif tscp ] + return $ catAGraphs [ mkCbranch e tid endif l, mkLabel endif tscp ] mkCmmIfThen :: CmmExpr -> CmmAGraph -> FCode CmmAGraph -mkCmmIfThen e tbranch = do +mkCmmIfThen e tbranch = mkCmmIfThen' e tbranch Nothing + +mkCmmIfThen' :: CmmExpr -> CmmAGraph -> Maybe Bool -> FCode CmmAGraph +mkCmmIfThen' e tbranch l = do endif <- newLabelC tid <- newLabelC tscp <- getTickScope - return $ catAGraphs [ mkCbranch e tid endif Nothing + return $ catAGraphs [ mkCbranch e tid endif l , mkLabel tid tscp, tbranch, mkLabel endif tscp ] - mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmExpr] -> UpdFrameOffset -> [CmmExpr] -> FCode CmmAGraph mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do |