Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : unboxed-tuple-arguments
http://hackage.haskell.org/trac/ghc/changeset/feeedb3ccf4977eb028924d072244237ff6e3984 >--------------------------------------------------------------- commit feeedb3ccf4977eb028924d072244237ff6e3984 Author: Max Bolingbroke <[email protected]> Date: Wed Mar 7 16:30:28 2012 +0000 Attempt to preemptively fix bugs in the StgCmm codepath >--------------------------------------------------------------- compiler/codeGen/StgCmmExpr.hs | 60 +++++++++++++++++++-------------------- 1 files changed, 29 insertions(+), 31 deletions(-) diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 2dd254a..0490182 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -313,29 +313,27 @@ cgCase (OpApp ) bndr srt AlgAlt [(DataAlt flase, a2] -- code that enters the HValue, then we'll get a runtime panic, because -- the HValue really is a MutVar#. The types are compatible though, -- so we can just generate an assignment. -cgCase (StgApp v []) bndr _ alt_type@(PrimAlt _) alts - | isUnLiftedType (idType v) - || reps_compatible - = -- assignment suffices for unlifted types - do { when (not reps_compatible) $ - panic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?" - ; v_info <- getCgIdInfo v - ; regs <- idToReg bndr - ; zipWithM_ (\reg expr -> emit (mkAssign (CmmLocal reg) expr)) regs (idInfoToAmodes v_info) - ; bindArgToReg bndr regs - ; cgAlts NoGcInAlts regs bndr alt_type alts } +cgCase (StgApp v []) bndr _ alt_type alts + | case alt_type of PrimAlt _ -> True; UbxTupAlt _ -> True; _ -> False + = if isUnLiftedType (idType v) || reps_compatible + then -- assignment suffices for unlifted types + do { when (not reps_compatible) $ + panic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?" + ; v_info <- getCgIdInfo v + ; regs <- idToReg bndr + ; zipWithM_ (\reg expr -> emit (mkAssign (CmmLocal reg) expr)) regs (idInfoToAmodes v_info) + ; bindArgToReg bndr regs + ; cgAlts NoGcInAlts regs bndr alt_type alts } + else -- fail at run-time, not compile-time + do { mb_cc <- maybeSaveCostCentre True + ; regs <- idToReg v + ; withSequel (AssignTo regs False) (cgExpr (StgApp v [])) + ; restoreCurrentCostCentre mb_cc + ; emit $ mkComment $ mkFastString "should be unreachable code" + ; emit $ withFreshLabel "l" (\l -> mkLabel l <*> mkBranch l)} where reps_compatible = idPrimRep v == idPrimRep bndr -cgCase scrut@(StgApp v []) _ _ (PrimAlt _) _ - = -- fail at run-time, not compile-time - do { mb_cc <- maybeSaveCostCentre True - ; regs <- idToReg v - ; withSequel (AssignTo regs False) (cgExpr scrut) - ; restoreCurrentCostCentre mb_cc - ; emit $ mkComment $ mkFastString "should be unreachable code" - ; emit $ withFreshLabel "l" (\l -> mkLabel l <*> mkBranch l)} - {- case seq# a s of v (# s', a' #) -> e @@ -348,17 +346,16 @@ case a of v (taking advantage of the fact that the return convention for (# State#, a #) is the same as the return convention for just 'a') -} -cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr srt alt_type alts - = -- handle seq#, same return convention as vanilla 'a'. - cgCase (StgApp a []) bndr srt alt_type alts - cgCase scrut bndr srt alt_type alts = -- the general case do { up_hp_usg <- getVirtHp -- Upstream heap usage - ; let ret_bndrs = chooseReturnBndrs bndr alt_type alts + -- handle seq#, same return convention as vanilla 'a'. + ; let scrut' = case scrut of (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) -> StgApp a [] + _ -> scrut + ret_bndrs = chooseReturnBndrs bndr alt_type alts ; alts_regss <- mapM idToReg ret_bndrs ; let alt_regs = concat alts_regss - simple_scrut = isSimpleScrut scrut alt_type + simple_scrut = isSimpleScrut scrut' alt_type gcInAlts | not simple_scrut = True | isSingleton alts = False | up_hp_usg > 0 = False @@ -366,7 +363,7 @@ cgCase scrut bndr srt alt_type alts gc_plan = if gcInAlts then GcInAlts alt_regs srt else NoGcInAlts ; mb_cc <- maybeSaveCostCentre simple_scrut - ; withSequel (AssignTo alt_regs gcInAlts) (cgExpr scrut) + ; withSequel (AssignTo alt_regs gcInAlts) (cgExpr scrut') ; restoreCurrentCostCentre mb_cc -- JD: We need Note: [Better Alt Heap Checks] @@ -386,10 +383,11 @@ isSimpleScrut :: StgExpr -> AltType -> Bool -- heap usage from alternatives into the stuff before the case -- NB: if you get this wrong, and claim that the expression doesn't allocate -- when it does, you'll deeply mess up allocation -isSimpleScrut (StgOpApp op _ _) _ = isSimpleOp op -isSimpleScrut (StgLit _) _ = True -- case 1# of { 0# -> ..; ... } -isSimpleScrut (StgApp _ []) (PrimAlt _) = True -- case x# of { 0# -> ..; ... } -isSimpleScrut _ _ = False +isSimpleScrut (StgOpApp op _ _) _ = isSimpleOp op +isSimpleScrut (StgLit _) _ = True -- case 1# of { 0# -> ..; ... } +isSimpleScrut (StgApp _ []) (PrimAlt _) = True -- case x# of { 0# -> ..; ... } +isSimpleScrut (StgApp _ []) (UbxTupAlt _) = True -- case x of { (# a, b #) -> .. } +isSimpleScrut _ _ = False isSimpleOp :: StgOp -> Bool -- True iff the op cannot block or allocate _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
