X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FStgCmmExpr.hs;h=eee4a08bc78b72780abb80eb20baa02d767f7704;hp=3b6aac97906c589c86bc6f659f998060df7ca929;hb=c0687066474aa4ce4912f31a5c09c1bcd673fb06;hpb=6bc92166180824bf046d31e378359e3c386150f9 diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 3b6aac9..eee4a08 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -27,21 +27,24 @@ import StgCmmClosure import StgSyn -import MkZipCfgCmm +import MkGraph import BlockId -import Cmm() import CmmExpr import CoreSyn import DataCon import ForeignCall import Id import PrimOp +import SMRep import TyCon +import Type import CostCentre ( CostCentreStack, currentCCS ) +import Control.Monad (when) import Maybes import Util import FastString import Outputable +import UniqSupply ------------------------------------------------------------------------ -- cgExpr: the main function @@ -57,8 +60,13 @@ cgExpr (StgTick m n expr) = do { emit (mkTickBox m n); cgExpr expr } cgExpr (StgLit lit) = do cmm_lit <- cgLit lit emitReturn [CmmLit cmm_lit] -cgExpr (StgLet binds expr) = do { cgBind binds; cgExpr expr } -cgExpr (StgLetNoEscape _ _ binds expr) = do { cgLneBinds binds; cgExpr expr } +cgExpr (StgLet binds expr) = do { cgBind binds; cgExpr expr } +cgExpr (StgLetNoEscape _ _ binds expr) = + do { us <- newUniqSupply + ; let join_id = mkBlockId (uniqFromSupply us) + ; cgLneBinds join_id binds + ; cgExpr expr + ; emit $ mkLabel join_id} cgExpr (StgCase expr _live_vars _save_vars bndr srt alt_type alts) = cgCase expr bndr srt alt_type alts @@ -84,37 +92,42 @@ bound only to stable things like stack locations.. The 'e' part will execute *next*, just like the scrutinee of a case. -} ------------------------- -cgLneBinds :: StgBinding -> FCode () -cgLneBinds (StgNonRec bndr rhs) - = do { local_cc <- saveCurrentCostCentre - -- See Note [Saving the current cost centre] - ; info <- cgLetNoEscapeRhs local_cc bndr rhs - ; addBindC (cg_id info) info } - -cgLneBinds (StgRec pairs) - = do { local_cc <- saveCurrentCostCentre - ; new_bindings <- fixC (\ new_bindings -> do - { addBindsC new_bindings - ; listFCs [ cgLetNoEscapeRhs local_cc b e - | (b,e) <- pairs ] }) - - ; addBindsC new_bindings } +cgLneBinds :: BlockId -> StgBinding -> FCode () +cgLneBinds join_id (StgNonRec bndr rhs) + = do { local_cc <- saveCurrentCostCentre + -- See Note [Saving the current cost centre] + ; info <- cgLetNoEscapeRhs join_id local_cc bndr rhs + ; addBindC (cg_id info) info } + +cgLneBinds join_id (StgRec pairs) + = do { local_cc <- saveCurrentCostCentre + ; new_bindings <- fixC (\ new_bindings -> do + { addBindsC new_bindings + ; listFCs [ cgLetNoEscapeRhs join_id local_cc b e + | (b,e) <- pairs ] }) + ; addBindsC new_bindings } ------------------------- -cgLetNoEscapeRhs, cgLetNoEscapeRhsBody - :: Maybe LocalReg -- Saved cost centre +cgLetNoEscapeRhs + :: BlockId -- join point for successor of let-no-escape + -> Maybe LocalReg -- Saved cost centre -> Id -> StgRhs -> FCode CgIdInfo -cgLetNoEscapeRhs local_cc bndr rhs = +cgLetNoEscapeRhs join_id local_cc bndr rhs = do { (info, rhs_body) <- getCodeR $ cgLetNoEscapeRhsBody local_cc bndr rhs ; let (bid, _) = expectJust "cgLetNoEscapeRhs" $ maybeLetNoEscape info - ; emit (outOfLine $ mkLabel bid emptyStackInfo <*> rhs_body) + ; emit (outOfLine $ mkLabel bid <*> rhs_body <*> mkBranch join_id) ; return info } +cgLetNoEscapeRhsBody + :: Maybe LocalReg -- Saved cost centre + -> Id + -> StgRhs + -> FCode CgIdInfo cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd _ args body) = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args) @@ -269,24 +282,65 @@ cgCase (OpApp ) bndr srt AlgAlt [(DataAlt flase, a2] = -} + -- Note [ticket #3132]: we might be looking at a case of a lifted Id + -- that was cast to an unlifted type. The Id will always be bottom, + -- but we don't want the code generator to fall over here. If we + -- just emit an assignment here, the assignment will be + -- type-incorrect Cmm. Hence, we emit the usual enter/return code, + -- (and because bottom must be untagged, it will be entered and the + -- program will crash). + -- The Sequel is a type-correct assignment, albeit bogus. + -- The (dead) continuation loops; it would be better to invoke some kind + -- of panic function here. + -- + -- However, we also want to allow an assignment to be generated + -- in the case when the types are compatible, because this allows + -- some slightly-dodgy but occasionally-useful casts to be used, + -- such as in RtClosureInspect where we cast an HValue to a MutVar# + -- so we can print out the contents of the MutVar#. If we generate + -- 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 + ; emit (mkAssign (CmmLocal (idToReg (NonVoid bndr))) (idInfoToAmode v_info)) + ; _ <- bindArgsToRegs [NonVoid bndr] + ; cgAlts NoGcInAlts (NonVoid bndr) alt_type alts } + where + reps_compatible = idCgRep v == idCgRep bndr + +cgCase scrut@(StgApp v []) _ _ (PrimAlt _) _ + = -- fail at run-time, not compile-time + do { mb_cc <- maybeSaveCostCentre True + ; withSequel (AssignTo [idToReg (NonVoid v)] False) (cgExpr scrut) + ; restoreCurrentCostCentre mb_cc + ; emit $ mkComment $ mkFastString "should be unreachable code" + ; emit $ withFreshLabel "l" (\l -> mkLabel l <*> mkBranch l)} + cgCase scrut bndr srt alt_type alts - = do { up_hp_usg <- getVirtHp -- Upstream heap usage - ; let ret_bndrs = chooseReturnBndrs bndr alt_type alts - alt_regs = map idToReg ret_bndrs - simple_scrut = isSimpleScrut scrut alt_type - gcInAlts | not simple_scrut = True - | isSingleton alts = False - | up_hp_usg > 0 = False - | otherwise = True - gc_plan = if gcInAlts then GcInAlts alt_regs srt else NoGcInAlts - - ; mb_cc <- maybeSaveCostCentre simple_scrut - ; withSequel (AssignTo alt_regs gcInAlts) (cgExpr scrut) - ; restoreCurrentCostCentre mb_cc + = -- the general case + do { up_hp_usg <- getVirtHp -- Upstream heap usage + ; let ret_bndrs = chooseReturnBndrs bndr alt_type alts + alt_regs = map idToReg ret_bndrs + simple_scrut = isSimpleScrut scrut alt_type + gcInAlts | not simple_scrut = True + | isSingleton alts = False + | up_hp_usg > 0 = False + | otherwise = True + gc_plan = if gcInAlts then GcInAlts alt_regs srt else NoGcInAlts + + ; mb_cc <- maybeSaveCostCentre simple_scrut + ; withSequel (AssignTo alt_regs gcInAlts) (cgExpr scrut) + ; restoreCurrentCostCentre mb_cc -- JD: We need Note: [Better Alt Heap Checks] - ; bindArgsToRegs ret_bndrs - ; cgAlts gc_plan (NonVoid bndr) alt_type alts } + ; _ <- bindArgsToRegs ret_bndrs + ; cgAlts gc_plan (NonVoid bndr) alt_type alts } ----------------- maybeSaveCostCentre :: Bool -> FCode (Maybe LocalReg) @@ -309,8 +363,8 @@ isSimpleScrut _ _ = False isSimpleOp :: StgOp -> Bool -- True iff the op cannot block or allocate isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) = not (playSafe safe) -isSimpleOp (StgFCallOp (DNCall _) _) = False -- Safe! isSimpleOp (StgPrimOp op) = not (primOpOutOfLine op) +isSimpleOp (StgPrimCallOp _) = False ----------------- chooseReturnBndrs :: Id -> AltType -> [StgAlt] -> [NonVoid Id] @@ -396,15 +450,13 @@ cgAltRhss gc_plan bndr alts cg_alt (con, bndrs, _uses, rhs) = getCodeR $ maybeAltHeapCheck gc_plan $ - do { pprTrace "binding args for" (ppr bndr <+> ppr con) $ bindConArgs con base_reg bndrs + do { _ <- bindConArgs con base_reg bndrs ; cgExpr rhs ; return con } maybeAltHeapCheck :: GcPlan -> FCode a -> FCode a -maybeAltHeapCheck NoGcInAlts code - = code -maybeAltHeapCheck (GcInAlts regs _) code - = altHeapCheck regs code +maybeAltHeapCheck NoGcInAlts code = code +maybeAltHeapCheck (GcInAlts regs _) code = altHeapCheck regs code ----------------------------------------------------------------------------- -- Tail calls @@ -442,8 +494,9 @@ cgLneJump blk_id lne_regs args -- Join point; discard sequel <*> mkBranch blk_id) } cgTailCall :: Id -> CgIdInfo -> [StgArg] -> FCode () -cgTailCall fun_id fun_info args - = case (getCallMethod fun_name (idCafInfo fun_id) lf_info (length args)) of +cgTailCall fun_id fun_info args = do + dflags <- getDynFlags + case (getCallMethod dflags fun_name (idCafInfo fun_id) lf_info (length args)) of -- A value in WHNF, so we can just return it. ReturnIt -> emitReturn [fun] -- ToDo: does ReturnIt guarantee tagged? @@ -452,8 +505,9 @@ cgTailCall fun_id fun_info args do { let fun' = CmmLoad fun (cmmExprType fun) ; [ret,call] <- forkAlts [ getCode $ emitReturn [fun], -- Is tagged; no need to untag - getCode $ do emit (mkAssign nodeReg fun) - emitCall Native (entryCode fun') []] -- Not tagged + getCode $ do -- emit (mkAssign nodeReg fun) + emitCall (NativeNodeCall, NativeReturn) + (entryCode fun') [fun]] -- Not tagged ; emit (mkCmmIfThenElse (cmmIsTagged fun) ret call) } SlowCall -> do -- A slow function call via the RTS apply routines @@ -468,8 +522,6 @@ cgTailCall fun_id fun_info args do emit $ mkComment $ mkFastString "directEntry" emit (mkAssign nodeReg fun) directCall lbl arity args - -- directCall lbl (arity+1) (StgVarArg fun_id : args)) - -- >>= (emit . (mkComment (mkFastString "DirectEntry") <*>)) else do emit $ mkComment $ mkFastString "directEntry else" directCall lbl arity args } @@ -495,8 +547,8 @@ if the assignment to the binder will be dead code (use isDeadBndr). The following example illustrates how badly the code turns out: STG: case <=## [ww_s7Hx y_s7HD] of wild2_sbH8 { - GHC.Bool.False -> // sbH8 dead - GHC.Bool.True -> // sbH8 dead + GHC.Types.False -> // sbH8 dead + GHC.Types.True -> // sbH8 dead }; Cmm: _s7HD::F64 = F64[_sbH7::I64 + 7]; // MidAssign @@ -556,3 +608,4 @@ we should still generate the same code: L2: -} +