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
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
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)
=
-}
+ -- 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)
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]
cg_alt (con, bndrs, _uses, rhs)
= getCodeR $
maybeAltHeapCheck gc_plan $
- do { 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
<*> 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?
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
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 }
The following example illustrates how badly the code turns out:
STG:
case <=## [ww_s7Hx y_s7HD] of wild2_sbH8 {
- GHC.Bool.False -> <true code> // sbH8 dead
- GHC.Bool.True -> <false code> // sbH8 dead
+ GHC.Types.False -> <true code> // sbH8 dead
+ GHC.Types.True -> <false code> // sbH8 dead
};
Cmm:
_s7HD::F64 = F64[_sbH7::I64 + 7]; // MidAssign
L2:
<default-case code>
-}
+