%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgClosure.lhs,v 1.28 1999/04/23 09:51:24 simonm Exp $
+% $Id: CgClosure.lhs,v 1.29 1999/05/11 16:44:02 keithw Exp $
%
\section[CgClosure]{Code generation for closures}
mkRednCountsLabel, mkStdEntryLabel
)
import ClosureInfo -- lots and lots of stuff
-import CmdLineOpts ( opt_GranMacros, opt_SccProfilingOn )
+import CmdLineOpts ( opt_GranMacros, opt_SccProfilingOn, opt_DoTickyProfiling )
import CostCentre
import Id ( Id, idName, idType, idPrimRep )
import Name ( Name )
import CmdLineOpts ( opt_SccProfilingOn )
import Outputable
+import Name ( nameOccName )
+import OccName ( occNameFS )
+
getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)"
\end{code}
\begin{code}
-blackHoleIt :: ClosureInfo -> Bool -> Code -- Only called for thunks
+blackHoleIt :: ClosureInfo -> Bool -> Code -- Only called for closures with no args
+
blackHoleIt closure_info node_points
= if blackHoleOnEntry closure_info && node_points
then
\end{code}
\begin{code}
-setupUpdate :: ClosureInfo -> Code -> Code -- Only called for thunks
+setupUpdate :: ClosureInfo -> Code -> Code -- Only called for closures with no args
-- Nota Bene: this function does not change Node (even if it's a CAF),
-- so that the cost centre in the original closure can still be
-- extracted by a subsequent ENTER_CC_TCL
+-- I've tidied up the code for this function, but it should still do the same as
+-- it did before (modulo ticky stuff). KSW 1999-04.
setupUpdate closure_info code
- = if (closureUpdReqd closure_info) then
- link_caf_if_needed `thenFC` \ update_closure ->
- pushUpdateFrame update_closure code
+ = if closureReEntrant closure_info
+ then
+ code
else
- profCtrC SLIT("TICK_UPDF_OMITTED") [] `thenC`
- code
+ case (closureUpdReqd closure_info, isStaticClosure closure_info) of
+ (False,False) -> profCtrC SLIT("TICK_UPDF_OMITTED") [] `thenC`
+ code
+ (False,True ) -> (if opt_DoTickyProfiling
+ then
+ -- blackhole the SE CAF
+ link_caf seCafBlackHoleClosureInfo `thenFC` \ _ -> nopC
+ else
+ nopC) `thenC`
+ profCtrC SLIT("TICK_UPD_CAF_BH_SINGLE_ENTRY") [CString cl_name] `thenC`
+ profCtrC SLIT("TICK_UPDF_OMITTED") [] `thenC`
+ code
+ (True ,False) -> pushUpdateFrame (CReg node) code
+ (True ,True ) -> -- blackhole the (updatable) CAF:
+ link_caf cafBlackHoleClosureInfo `thenFC` \ update_closure ->
+ profCtrC SLIT("TICK_UPD_CAF_BH_UPDATABLE") [CString cl_name] `thenC`
+ pushUpdateFrame update_closure code
where
- link_caf_if_needed :: FCode CAddrMode -- Returns amode for closure to be updated
- link_caf_if_needed
- = if not (isStaticClosure closure_info) then
- returnFC (CReg node)
- else
-
- -- First we must allocate a black hole, and link the
- -- CAF onto the CAF list
-
- -- Alloc black hole specifying CC_HDR(Node) as the cost centre
- -- Hack Warning: Using a CLitLit to get CAddrMode !
- let
- use_cc = CLitLit SLIT("CCS_HDR(R1.p)") PtrRep
- blame_cc = use_cc
- in
- allocDynClosure (blackHoleClosureInfo closure_info) use_cc blame_cc []
- `thenFC` \ heap_offset ->
- getHpRelOffset heap_offset `thenFC` \ hp_rel ->
- let amode = CAddr hp_rel
- in
- absC (CMacroStmt UPD_CAF [CReg node, amode])
- `thenC`
- returnFC amode
+ cl_name :: FAST_STRING
+ cl_name = (occNameFS . nameOccName . closureName) closure_info
+
+ link_caf :: (ClosureInfo -> ClosureInfo) -- function yielding BH closure_info
+ -> FCode CAddrMode -- Returns amode for closure to be updated
+ link_caf bhCI
+ = -- To update a CAF we must allocate a black hole, link the CAF onto the
+ -- CAF list, then update the CAF to point to the fresh black hole.
+ -- This function returns the address of the black hole, so it can be
+ -- updated with the new value when available.
+
+ -- Alloc black hole specifying CC_HDR(Node) as the cost centre
+ -- Hack Warning: Using a CLitLit to get CAddrMode !
+ let
+ use_cc = CLitLit SLIT("CCS_HDR(R1.p)") PtrRep
+ blame_cc = use_cc
+ in
+ allocDynClosure (bhCI closure_info) use_cc blame_cc [] `thenFC` \ heap_offset ->
+ getHpRelOffset heap_offset `thenFC` \ hp_rel ->
+ let amode = CAddr hp_rel
+ in
+ absC (CMacroStmt UPD_CAF [CReg node, amode]) `thenC`
+ returnFC amode
\end{code}
%************************************************************************
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: ClosureInfo.lhs,v 1.36 1999/03/22 16:58:20 simonm Exp $
+% $Id: ClosureInfo.lhs,v 1.37 1999/05/11 16:44:02 keithw Exp $
%
\section[ClosureInfo]{Data structures which describe closures}
isStaticClosure,
allocProfilingMsg,
- blackHoleClosureInfo,
+ cafBlackHoleClosureInfo, seCafBlackHoleClosureInfo,
maybeSelectorInfo,
infoTblNeedsSRT,
import CLabel ( CLabel, mkStdEntryLabel, mkFastEntryLabel,
mkInfoTableLabel,
mkConInfoTableLabel, mkStaticClosureLabel,
- mkBlackHoleInfoTableLabel,
+ mkCAFBlackHoleInfoTableLabel,
+ mkSECAFBlackHoleInfoTableLabel,
mkStaticInfoTableLabel, mkStaticConEntryLabel,
mkConEntryLabel, mkClosureLabel,
mkSelectorInfoLabel, mkSelectorEntryLabel,
mkReturnPtLabel
)
import CmdLineOpts ( opt_SccProfilingOn, opt_OmitBlackHoling,
- opt_Parallel )
+ opt_Parallel, opt_DoTickyProfiling )
import Id ( Id, idType, getIdArity )
import DataCon ( DataCon, dataConTag, fIRST_TAG,
isNullaryDataCon, isTupleCon, dataConName
Int -- arity;
| LFBlackHole -- Used for the closures allocated to hold the result
-
-- of a CAF. We want the target of the update frame to
-- be in the heap, so we make a black hole to hold it.
+ CLabel -- Flavour (info label, eg CAF_BLACKHOLE_info).
data StandardFormInfo -- Tells whether this thunk has one of a small number
\begin{code}
mkLFArgument = LFArgument
-mkLFBlackHole = LFBlackHole
mkLFLetNoEscape = LFLetNoEscape
mkLFImported :: Id -> LambdaFormInfo
-> returnFC True
-- Node must point to any standard-form thunk.
- LFArgument -> returnFC True
- LFImported -> returnFC True
- LFBlackHole -> returnFC True
+ LFArgument -> returnFC True
+ LFImported -> returnFC True
+ LFBlackHole _ -> returnFC True
-- BH entry may require Node to point
LFLetNoEscape _ -> returnFC False
StdEntry (mkConEntryLabel (dataConName tup))
LFThunk _ _ _ updatable std_form_info _ _
- -> if updatable
+ -> if updatable || opt_DoTickyProfiling -- to catch double entry
then ViaNode
- else StdEntry (thunkEntryLabel name std_form_info updatable)
+ else StdEntry (thunkEntryLabel name std_form_info updatable)
- LFArgument -> ViaNode
- LFImported -> ViaNode
- LFBlackHole -> ViaNode -- Presumably the black hole has by now
- -- been updated, but we don't know with
- -- what, so we enter via Node
+ LFArgument -> ViaNode
+ LFImported -> ViaNode
+ LFBlackHole _ -> ViaNode -- Presumably the black hole has by now
+ -- been updated, but we don't know with
+ -- what, so we enter via Node
LFLetNoEscape 0
-> StdEntry (mkReturnPtLabel (nameUnique name))
LFThunk _ _ no_fvs updatable _ _ _
-> if updatable
then not opt_OmitBlackHoling
- else not no_fvs
+ else opt_DoTickyProfiling || not no_fvs
+ -- the former to catch double entry,
+ -- and the latter to plug space-leaks. KSW/SDM 1999-04.
+
other -> panic "blackHoleOnEntry" -- Should never happen
isStandardFormThunk :: LambdaFormInfo -> Bool
closureUpdReqd :: ClosureInfo -> Bool
closureUpdReqd (MkClosureInfo _ (LFThunk _ _ _ upd _ _ _) _) = upd
-closureUpdReqd (MkClosureInfo _ LFBlackHole _) = True
+closureUpdReqd (MkClosureInfo _ (LFBlackHole _) _) = True
-- Black-hole closures are allocated to receive the results of an
-- alg case with a named default... so they need to be updated.
closureUpdReqd other_closure = False
infoTableLabelFromCI :: ClosureInfo -> CLabel
infoTableLabelFromCI (MkClosureInfo id lf_info rep)
= case lf_info of
- LFCon con _ -> mkConInfoPtr con rep
- LFTuple tup _ -> mkConInfoPtr tup rep
+ LFCon con _ -> mkConInfoPtr con rep
+ LFTuple tup _ -> mkConInfoPtr tup rep
- LFBlackHole -> mkBlackHoleInfoTableLabel
+ LFBlackHole info -> info
LFThunk _ _ _ upd_flag (SelectorThunk offset) _ _ ->
mkSelectorInfoLabel upd_flag offset
LFReEntrant _ _ _ _ _ _ -> SLIT("TICK_ALLOC_FUN")
LFCon _ _ -> SLIT("TICK_ALLOC_CON")
LFTuple _ _ -> SLIT("TICK_ALLOC_CON")
- LFThunk _ _ _ _ _ _ _ -> SLIT("TICK_ALLOC_THK")
- LFBlackHole -> SLIT("TICK_ALLOC_BH")
+ LFThunk _ _ _ True _ _ _ -> SLIT("TICK_ALLOC_UP_THK") -- updatable
+ LFThunk _ _ _ False _ _ _ -> SLIT("TICK_ALLOC_SE_THK") -- nonupdatable
+ LFBlackHole _ -> SLIT("TICK_ALLOC_BH")
LFImported -> panic "TICK_ALLOC_IMP"
\end{code}
We need a black-hole closure info to pass to @allocDynClosure@ when we
-want to allocate the black hole on entry to a CAF.
+want to allocate the black hole on entry to a CAF. These are the only
+ways to build an LFBlackHole, maintaining the invariant that it really
+is a black hole and not something else.
\begin{code}
-blackHoleClosureInfo (MkClosureInfo name _ _)
- = MkClosureInfo name LFBlackHole BlackHoleRep
+cafBlackHoleClosureInfo (MkClosureInfo name _ _)
+ = MkClosureInfo name (LFBlackHole mkCAFBlackHoleInfoTableLabel) BlackHoleRep
+
+seCafBlackHoleClosureInfo (MkClosureInfo name _ _)
+ = MkClosureInfo name (LFBlackHole mkSECAFBlackHoleInfoTableLabel) BlackHoleRep
\end{code}
%************************************************************************
import Id ( Id, mkSysLocal, idType,
externallyVisibleId, setIdUnique, idName, getIdDemandInfo
)
-import Var ( modifyIdInfo )
+import Var ( Var, varType, modifyIdInfo )
import IdInfo ( setDemandInfo )
+import UsageSPUtils ( primOpUsgTys )
import DataCon ( DataCon, dataConName, dataConId )
import Name ( Name, nameModule, isLocallyDefinedName )
import Module ( isDynamicModule )
import Const ( Con(..), Literal, isLitLitLit )
import VarEnv
import Const ( Con(..), isWHNFCon, Literal(..) )
-import PrimOp ( PrimOp(..) )
-import Type ( isUnLiftedType, isUnboxedTupleType, Type )
+import PrimOp ( PrimOp(..), primOpUsg )
+import Type ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe,
+ UsageAnn(..), tyUsg, applyTy )
import TysPrim ( intPrimTy )
import Demand
import Unique ( Unique, Uniquable(..) )
import UniqSupply -- all of it, really
+import Util
+import Maybes
import Outputable
\end{code}
are unique across a module. (Simplifier doesn't maintain this
invariant any longer.)
+A binder to be floated out becomes an @StgFloatBind@.
+
\begin{code}
type StgEnv = IdEnv Id
-data StgFloatBind
- = LetBind Id StgExpr
- | CaseBind Id StgExpr
+data StgFloatBind = StgFloatBind Id StgExpr RhsDemand
+\end{code}
+
+A @RhsDemand@ gives the demand on an RHS: strict (@isStrictDem@) and
+thus case-bound, or if let-bound, at most once (@isOnceDem@) or
+otherwise.
+
+\begin{code}
+data RhsDemand = RhsDemand { isStrictDem :: Bool, -- True => used at least once
+ isOnceDem :: Bool -- True => used at most once
+ }
+
+tyDem :: Type -> RhsDemand
+-- derive RhsDemand (assuming let-binding)
+tyDem ty = case tyUsg ty of
+ UsOnce -> RhsDemand False True
+ UsMany -> RhsDemand False False
+ UsVar _ -> pprPanic "CoreToStg.tyDem: UsVar unexpected:" $ ppr ty
+
+bdrDem :: Var -> RhsDemand
+bdrDem = tyDem . varType
+
+safeDem, onceDem :: RhsDemand
+safeDem = RhsDemand False False -- always safe to use this
+onceDem = RhsDemand False True -- used at most once
\end{code}
No free/live variable information is pinned on in this pass; it's added
-> [StgBinding] -- output
topCoreBindsToStg us core_binds
- = initUs us (coreBindsToStg emptyVarEnv core_binds)
+ = initUs_ us (coreBindsToStg emptyVarEnv core_binds)
where
coreBindsToStg :: StgEnv -> [CoreBind] -> UniqSM [StgBinding]
StgEnv) -- Floats
coreBindToStg env (NonRec binder rhs)
- = coreRhsToStg env rhs `thenUs` \ stg_rhs ->
- newLocalId env binder `thenUs` \ (new_env, new_binder) ->
+ = coreRhsToStg env rhs (bdrDem binder) `thenUs` \ stg_rhs ->
+ newLocalId env binder `thenUs` \ (new_env, new_binder) ->
returnUs ([StgNonRec new_binder stg_rhs], new_env)
coreBindToStg env (Rec pairs)
- = newLocalIds env binders `thenUs` \ (env', binders') ->
- mapUs (coreRhsToStg env') rhss `thenUs` \ stg_rhss ->
+ = newLocalIds env binders `thenUs` \ (env', binders') ->
+ mapUs (\ (bdr,rhs) -> coreRhsToStg env' rhs (bdrDem bdr) )
+ pairs `thenUs` \ stg_rhss ->
returnUs ([StgRec (binders' `zip` stg_rhss)], env')
where
(binders, rhss) = unzip pairs
%************************************************************************
\begin{code}
-coreRhsToStg :: StgEnv -> CoreExpr -> UniqSM StgRhs
+coreRhsToStg :: StgEnv -> CoreExpr -> RhsDemand -> UniqSM StgRhs
-coreRhsToStg env core_rhs
- = coreExprToStg env core_rhs `thenUs` \ stg_expr ->
- returnUs (exprToRhs stg_expr)
+coreRhsToStg env core_rhs dem
+ = coreExprToStg env core_rhs dem `thenUs` \ stg_expr ->
+ returnUs (exprToRhs dem stg_expr)
-exprToRhs (StgLet (StgNonRec var1 rhs) (StgApp var2 []))
+exprToRhs dem (StgLet (StgNonRec var1 rhs) (StgApp var2 []))
| var1 == var2
= rhs
-- This curious stuff is to unravel what a lambda turns into
constructors (ala C++ static class constructors) which will
then be run at load time to fix up static closures.
-}
-exprToRhs (StgCon (DataCon con) args _)
+exprToRhs dem (StgCon (DataCon con) args _)
| not is_dynamic &&
all (not.is_lit_lit) args = StgRhsCon noCCS con args
where
Literal l -> isLitLitLit l
_ -> False
-exprToRhs expr
+exprToRhs dem expr
= StgRhsClosure noCCS -- No cost centre (ToDo?)
stgArgOcc -- safe
noSRT -- figure out later
bOGUS_FVs
-
- Updatable -- Be pessimistic
+ (if isOnceDem dem then SingleEntry else Updatable)
[]
expr
%************************************************************************
\begin{code}
-coreArgsToStg :: StgEnv -> [CoreArg] -> UniqSM ([StgFloatBind], [StgArg])
+coreArgsToStg :: StgEnv -> [(CoreArg,RhsDemand)] -> UniqSM ([StgFloatBind], [StgArg])
+-- arguments are all value arguments (tyargs already removed), paired with their demand
coreArgsToStg env []
= returnUs ([], [])
-coreArgsToStg env (Type ty : as) -- Discard type arguments
- = coreArgsToStg env as
-
-coreArgsToStg env (a:as)
- = coreArgToStg env a `thenUs` \ (bs1, a') ->
- coreArgsToStg env as `thenUs` \ (bs2, as') ->
+coreArgsToStg env (ad:ads)
+ = coreArgToStg env ad `thenUs` \ (bs1, a') ->
+ coreArgsToStg env ads `thenUs` \ (bs2, as') ->
returnUs (bs1 ++ bs2, a' : as')
-- This is where we arrange that a non-trivial argument is let-bound
-coreArgToStg :: StgEnv -> CoreArg -> UniqSM ([StgFloatBind], StgArg)
+coreArgToStg :: StgEnv -> (CoreArg,RhsDemand) -> UniqSM ([StgFloatBind], StgArg)
-coreArgToStg env arg
- = coreExprToStgFloat env arg `thenUs` \ (binds, arg') ->
+coreArgToStg env (arg,dem)
+ = let
+ ty = coreExprType arg
+ dem' = if isUnLiftedType ty -- if it's unlifted, it's definitely strict
+ then dem { isStrictDem = True }
+ else dem
+ in
+ coreExprToStgFloat env arg dem' `thenUs` \ (binds, arg') ->
case (binds, arg') of
([], StgCon con [] _) | isWHNFCon con -> returnUs ([], StgConArg con)
([], StgApp v []) -> returnUs ([], StgVarArg v)
-- expressions by pulling out the floats.
(_, other) ->
newStgVar ty `thenUs` \ v ->
- if isUnLiftedType ty
- then returnUs (binds ++ [CaseBind v arg'], StgVarArg v)
- else returnUs ([LetBind v (mkStgBinds binds arg')], StgVarArg v)
- where
- ty = coreExprType arg
-
+ if isStrictDem dem'
+ then returnUs (binds ++ [StgFloatBind v arg' dem'], StgVarArg v)
+ else returnUs ([StgFloatBind v (mkStgBinds binds arg') dem'], StgVarArg v)
\end{code}
%************************************************************************
\begin{code}
-coreExprToStg :: StgEnv -> CoreExpr -> UniqSM StgExpr
+coreExprToStg :: StgEnv -> CoreExpr -> RhsDemand -> UniqSM StgExpr
-coreExprToStg env (Var var)
+coreExprToStg env (Var var) dem
= returnUs (StgApp (stgLookup env var) [])
\end{code}
%************************************************************************
\begin{code}
-coreExprToStg env expr@(Lam _ _)
+coreExprToStg env expr@(Lam _ _) dem
= let
(binders, body) = collectBinders expr
id_binders = filter isId binders
+ body_dem = trace "coreExprToStg: approximating body_dem in Lam"
+ safeDem
in
newLocalIds env id_binders `thenUs` \ (env', binders') ->
- coreExprToStg env' body `thenUs` \ stg_body ->
+ coreExprToStg env' body body_dem `thenUs` \ stg_body ->
if null id_binders then -- it was all type/usage binders; tossed
returnUs stg_body
%************************************************************************
\begin{code}
-coreExprToStg env (Let bind body)
- = coreBindToStg env bind `thenUs` \ (stg_binds, new_env) ->
- coreExprToStg new_env body `thenUs` \ stg_body ->
+coreExprToStg env (Let bind body) dem
+ = coreBindToStg env bind `thenUs` \ (stg_binds, new_env) ->
+ coreExprToStg new_env body dem `thenUs` \ stg_body ->
returnUs (foldr StgLet stg_body stg_binds)
\end{code}
Covert core @scc@ expression directly to STG @scc@ expression.
\begin{code}
-coreExprToStg env (Note (SCC cc) expr)
- = coreExprToStg env expr `thenUs` \ stg_expr ->
+coreExprToStg env (Note (SCC cc) expr) dem
+ = coreExprToStg env expr dem `thenUs` \ stg_expr ->
returnUs (StgSCC cc stg_expr)
\end{code}
\begin{code}
-coreExprToStg env (Note other_note expr) = coreExprToStg env expr
+coreExprToStg env (Note other_note expr) dem = coreExprToStg env expr dem
\end{code}
The rest are handled by coreExprStgFloat.
\begin{code}
-coreExprToStg env expr
- = coreExprToStgFloat env expr `thenUs` \ (binds,stg_expr) ->
+coreExprToStg env expr dem
+ = coreExprToStgFloat env expr dem `thenUs` \ (binds,stg_expr) ->
returnUs (mkStgBinds binds stg_expr)
\end{code}
%************************************************************************
\begin{code}
-coreExprToStgFloat env expr@(App _ _)
+coreExprToStgFloat env expr@(App _ _) dem
= let
- (fun,args) = collect_args expr []
+ (fun,rads,_) = collect_args expr
+ ads = reverse rads
in
- coreArgsToStg env args `thenUs` \ (binds, stg_args) ->
+ coreArgsToStg env ads `thenUs` \ (binds, stg_args) ->
-- Now deal with the function
case (fun, stg_args) of
(non_var_fun, []) -> -- No value args, so recurse into the function
ASSERT( null binds )
- coreExprToStg env non_var_fun `thenUs` \e ->
+ coreExprToStg env non_var_fun dem `thenUs` \e ->
returnUs ([], e)
other -> -- A non-variable applied to things; better let-bind it.
newStgVar (coreExprType fun) `thenUs` \ fun_id ->
- coreExprToStg env fun `thenUs` \ (stg_fun) ->
- let
- fun_rhs = StgRhsClosure noCCS -- No cost centre (ToDo?)
- stgArgOcc
- noSRT
- bOGUS_FVs
- SingleEntry -- Only entered once
- []
- stg_fun
- in
+ coreRhsToStg env fun onceDem `thenUs` \ fun_rhs ->
returnUs (binds,
StgLet (StgNonRec fun_id fun_rhs) $
StgApp fun_id stg_args)
where
- -- Collect arguments
- collect_args (App fun arg) args = collect_args fun (arg:args)
- collect_args (Note (Coerce _ _) expr) args = collect_args expr args
- collect_args (Note InlineCall expr) args = collect_args expr args
- collect_args fun args = (fun, args)
+ -- Collect arguments and demands (*in reverse order*)
+ collect_args :: CoreExpr -> (CoreExpr, [(CoreExpr,RhsDemand)], Type)
+ collect_args (App fun (Type tyarg)) = let (the_fun,ads,fun_ty) = collect_args fun
+ in (the_fun,ads,applyTy fun_ty tyarg)
+ collect_args (App fun arg ) = let (the_fun,ads,fun_ty) = collect_args fun
+ (arg_ty,res_ty) = expectJust "coreExprToStgFloat:collect_args" $
+ splitFunTy_maybe fun_ty
+ in (the_fun,(arg,tyDem arg_ty):ads,res_ty)
+ collect_args (Note (Coerce ty _) e) = let (the_fun,ads,_ ) = collect_args e
+ in (the_fun,ads,ty)
+ collect_args (Note InlineCall e) = collect_args e
+ collect_args (Note (TermUsg _) e) = collect_args e
+ collect_args fun = (fun,[],coreExprType fun)
\end{code}
%************************************************************************
%* *
%************************************************************************
+For data constructors, the demand on an argument is the demand on the
+constructor as a whole (see module UsageSPInf). For primops, the
+demand is derived from the type of the primop.
+
+If usage inference is off, we simply make all bindings updatable for
+speed.
+
\begin{code}
-coreExprToStgFloat env expr@(Con (PrimOp (CCallOp (Right _) a b c)) args)
- = getUniqueUs `thenUs` \ u ->
- coreArgsToStg env args `thenUs` \ (binds, stg_atoms) ->
- let con' = PrimOp (CCallOp (Right u) a b c) in
+coreExprToStgFloat env expr@(Con con args) dem
+ = let
+ args' = filter isValArg args
+ dems' = case con of
+ Literal _ -> ASSERT( null args' {-'cpp-} )
+ []
+ DEFAULT -> panic "coreExprToStgFloat: DEFAULT"
+ DataCon c -> repeat (if isOnceDem dem then onceDem else safeDem)
+ PrimOp p -> let tyargs = map (\ (Type ty) -> ty) $
+ takeWhile isTypeArg args
+ (arg_tys,_) = primOpUsgTys p tyargs
+ in ASSERT( length arg_tys == length args' {-'cpp-} )
+ -- primops always fully applied, so == not >=
+ map tyDem arg_tys
+ in
+ coreArgsToStg env (zip args' dems') `thenUs` \ (binds, stg_atoms) ->
+ (case con of -- must change unique if present
+ PrimOp (CCallOp (Right _) a b c) -> getUniqueUs `thenUs` \ u ->
+ returnUs (PrimOp (CCallOp (Right u) a b c))
+ _ -> returnUs con)
+ `thenUs` \ con' ->
returnUs (binds, StgCon con' stg_atoms (coreExprType expr))
-
-coreExprToStgFloat env expr@(Con con args)
- = coreArgsToStg env args `thenUs` \ (binds, stg_atoms) ->
- returnUs (binds, StgCon con stg_atoms (coreExprType expr))
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-coreExprToStgFloat env expr@(Case scrut bndr alts)
- = coreExprToStgFloat env scrut `thenUs` \ (binds, scrut') ->
+coreExprToStgFloat env expr@(Case scrut bndr alts) dem
+ = coreExprToStgFloat env scrut (bdrDem bndr) `thenUs` \ (binds, scrut') ->
newEvaldLocalId env bndr `thenUs` \ (env', bndr') ->
alts_to_stg env' (findDefault alts) `thenUs` \ alts' ->
returnUs (binds, mkStgCase scrut' bndr' alts')
returnUs (StgAlgAlts scrut_ty alts' deflt')
alg_alt_to_stg env (DataCon con, bs, rhs)
- = coreExprToStg env rhs `thenUs` \ stg_rhs ->
+ = coreExprToStg env rhs dem `thenUs` \ stg_rhs ->
returnUs (con, filter isId bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs)
-- NB the filter isId. Some of the binders may be
-- existential type variables, which STG doesn't care about
prim_alt_to_stg env (Literal lit, args, rhs)
= ASSERT( null args )
- coreExprToStg env rhs `thenUs` \ stg_rhs ->
+ coreExprToStg env rhs dem `thenUs` \ stg_rhs ->
returnUs (lit, stg_rhs)
default_to_stg env Nothing
= returnUs StgNoDefault
default_to_stg env (Just rhs)
- = coreExprToStg env rhs `thenUs` \ stg_rhs ->
+ = coreExprToStg env rhs dem `thenUs` \ stg_rhs ->
returnUs (StgBindDefault stg_rhs)
-- The binder is used for prim cases and not otherwise
-- (hack for old code gen)
\end{code}
\begin{code}
-coreExprToStgFloat env expr
- = coreExprToStg env expr `thenUs` \stg_expr ->
+coreExprToStgFloat env expr@(Type _) dem
+ = pprPanic "coreExprToStgFloat: tyarg unexpected:" $ ppr expr
+\end{code}
+
+\begin{code}
+coreExprToStgFloat env expr dem
+ = coreExprToStg env expr dem `thenUs` \stg_expr ->
returnUs ([], stg_expr)
\end{code}
mkStgBinds :: [StgFloatBind] -> StgExpr -> StgExpr
mkStgBinds binds body = foldr mkStgBind body binds
-mkStgBind (CaseBind bndr rhs) body
+mkStgBind (StgFloatBind bndr rhs dem) body
| isUnLiftedType bndr_ty
- = mkStgCase rhs bndr (StgPrimAlts bndr_ty [] (StgBindDefault body))
- | otherwise
- = mkStgCase rhs bndr (StgAlgAlts bndr_ty [] (StgBindDefault body))
- where
- bndr_ty = idType bndr
+ = ASSERT( not ((isUnboxedTupleType bndr_ty) && (isStrictDem dem==False)) )
+ mkStgCase rhs bndr (StgPrimAlts bndr_ty [] (StgBindDefault body))
-mkStgBind (LetBind bndr rhs) body
- | isUnboxedTupleType bndr_ty
- = panic "mkStgBinds: unboxed tuple"
- | isUnLiftedType bndr_ty
- = mkStgCase rhs bndr (StgPrimAlts bndr_ty [] (StgBindDefault body))
+ | isStrictDem dem == True -- case
+ = mkStgCase rhs bndr (StgAlgAlts bndr_ty [] (StgBindDefault body))
- | otherwise
- = StgLet (StgNonRec bndr (exprToRhs rhs)) body
+ | isStrictDem dem == False -- let
+ = StgLet (StgNonRec bndr (exprToRhs dem rhs)) body
where
bndr_ty = idType bndr
projects / ghc-hetmet.git / commitdiff