Commit 5c0b6550 authored by keithw's avatar keithw
Browse files

[project @ 1999-05-11 16:44:02 by keithw]

(this is number 7 of 9 commits to be applied together)

  The code generator now incorporates the update avoidance
  optimisation: a thunk of __o type is now made SingleEntry rather
  than Updatable.

  We want to verify that SingleEntry thunks are indeed entered at most
  once.  In order to do this, -ticky turns on eager blackholing.
  Ordinary thunks will be dealt with by the RTS, but CAFs are
  blackholed by the code generator.  We blackhole with new blackholes:
  SE_CAF_BLACKHOLE.  We will enter one of these if we attempt to enter
  a SingleEntry thunk twice.
parent f54faab0
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CLabel.lhs,v 1.25 1999/04/27 12:34:49 simonm Exp $
% $Id: CLabel.lhs,v 1.26 1999/05/11 16:44:04 keithw Exp $
%
\section[CLabel]{@CLabel@: Information to make C Labels}
......@@ -36,7 +36,8 @@ module CLabel (
mkErrorStdEntryLabel,
mkUpdEntryLabel,
mkBlackHoleInfoTableLabel,
mkCAFBlackHoleInfoTableLabel,
mkSECAFBlackHoleInfoTableLabel,
mkRtsPrimOpLabel,
mkSelectorInfoLabel,
......@@ -61,7 +62,7 @@ module CLabel (
import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl )
#endif
import CmdLineOpts ( opt_Static )
import CmdLineOpts ( opt_Static, opt_DoTickyProfiling )
import CStrings ( pp_cSEP )
import DataCon ( ConTag, DataCon )
import Module ( isDynamicModule )
......@@ -153,7 +154,7 @@ data CaseLabelInfo
data RtsLabelInfo
= RtsShouldNeverHappenCode
| RtsBlackHoleInfoTbl
| RtsBlackHoleInfoTbl FAST_STRING -- black hole with info table name
| RtsUpdEntry
......@@ -210,7 +211,11 @@ mkAsmTempLabel = AsmTempLabel
mkErrorStdEntryLabel = RtsLabel RtsShouldNeverHappenCode
mkUpdEntryLabel = RtsLabel RtsUpdEntry
mkBlackHoleInfoTableLabel = RtsLabel RtsBlackHoleInfoTbl
mkCAFBlackHoleInfoTableLabel = RtsLabel (RtsBlackHoleInfoTbl SLIT("CAF_BLACKHOLE_info"))
mkSECAFBlackHoleInfoTableLabel = if opt_DoTickyProfiling then
RtsLabel (RtsBlackHoleInfoTbl SLIT("SE_CAF_BLACKHOLE_info"))
else -- RTS won't have info table unless -ticky is on
panic "mkSECAFBlackHoleInfoTableLabel requires -ticky"
mkRtsPrimOpLabel primop = RtsLabel (RtsPrimOp primop)
mkSelectorInfoLabel upd off = RtsLabel (RtsSelectorInfoTbl upd off)
......@@ -299,7 +304,7 @@ For generating correct types in label declarations...
\begin{code}
labelType :: CLabel -> CLabelType
labelType (RtsLabel RtsBlackHoleInfoTbl) = InfoTblType
labelType (RtsLabel (RtsBlackHoleInfoTbl _)) = InfoTblType
labelType (RtsLabel (RtsSelectorInfoTbl _ _)) = InfoTblType
labelType (RtsLabel (RtsApInfoTbl _ _)) = InfoTblType
labelType (CaseLabel _ CaseReturnInfo) = InfoTblType
......@@ -415,7 +420,7 @@ pprCLbl (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("stg_error_entry")
pprCLbl (RtsLabel RtsUpdEntry) = ptext SLIT("Upd_frame_entry")
pprCLbl (RtsLabel RtsBlackHoleInfoTbl) = ptext SLIT("CAF_BLACKHOLE_info")
pprCLbl (RtsLabel (RtsBlackHoleInfoTbl info)) = ptext info
pprCLbl (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
= hcat [ptext SLIT("__sel_"), text (show offset),
......
%
% (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}
......@@ -44,7 +44,7 @@ import CLabel ( CLabel, mkClosureLabel, mkFastEntryLabel,
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 )
......@@ -56,6 +56,9 @@ import Util ( isIn )
import CmdLineOpts ( opt_SccProfilingOn )
import Outputable
import Name ( nameOccName )
import OccName ( occNameFS )
getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)"
\end{code}
......@@ -600,7 +603,8 @@ funWrapper closure_info arg_regs stk_tags slow_label fun_body
\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
......@@ -613,42 +617,59 @@ blackHoleIt closure_info node_points
\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}
......@@ -48,7 +48,7 @@ module ClosureInfo (
isStaticClosure,
allocProfilingMsg,
blackHoleClosureInfo,
cafBlackHoleClosureInfo, seCafBlackHoleClosureInfo,
maybeSelectorInfo,
infoTblNeedsSRT,
......@@ -68,7 +68,8 @@ import CgRetConv ( assignRegs )
import CLabel ( CLabel, mkStdEntryLabel, mkFastEntryLabel,
mkInfoTableLabel,
mkConInfoTableLabel, mkStaticClosureLabel,
mkBlackHoleInfoTableLabel,
mkCAFBlackHoleInfoTableLabel,
mkSECAFBlackHoleInfoTableLabel,
mkStaticInfoTableLabel, mkStaticConEntryLabel,
mkConEntryLabel, mkClosureLabel,
mkSelectorInfoLabel, mkSelectorEntryLabel,
......@@ -76,7 +77,7 @@ import CLabel ( CLabel, mkStdEntryLabel, mkFastEntryLabel,
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
......@@ -155,9 +156,9 @@ data LambdaFormInfo
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
......@@ -252,7 +253,6 @@ Miscellaneous LF-infos.
\begin{code}
mkLFArgument = LFArgument
mkLFBlackHole = LFBlackHole
mkLFLetNoEscape = LFLetNoEscape
mkLFImported :: Id -> LambdaFormInfo
......@@ -582,9 +582,9 @@ nodeMustPointToIt lf_info
-> 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
......@@ -678,15 +678,15 @@ getEntryConvention name lf_info arg_kinds
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))
......@@ -717,7 +717,10 @@ blackHoleOnEntry (MkClosureInfo _ lf_info _)
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
......@@ -892,7 +895,7 @@ closureLFInfo (MkClosureInfo _ lf_info _) = lf_info
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
......@@ -945,10 +948,10 @@ fastLabelFromCI (MkClosureInfo name _ _)
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
......@@ -1010,17 +1013,23 @@ allocProfilingMsg (MkClosureInfo _ lf_info _)
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}
%************************************************************************
......
......@@ -22,7 +22,7 @@ import PrimOp ( commutableOp, PrimOp(..) )
import RegAllocInfo ( mkMRegsState, MRegsState )
import Stix ( StixTree(..), StixReg(..) )
import PrimRep ( isFloatingRep )
import UniqSupply ( returnUs, thenUs, mapUs, initUs, UniqSM, UniqSupply )
import UniqSupply ( returnUs, thenUs, mapUs, initUs_, UniqSM, UniqSupply )
import UniqFM ( UniqFM, emptyUFM, addToUFM, lookupUFM )
import Outputable
......@@ -80,10 +80,10 @@ So, here we go:
writeRealAsm :: Handle -> AbstractC -> UniqSupply -> IO ()
writeRealAsm handle absC us
= -- _scc_ "writeRealAsm"
printForAsm handle (initUs us (runNCG absC))
printForAsm handle (initUs_ us (runNCG absC))
dumpRealAsm :: AbstractC -> UniqSupply -> SDoc
dumpRealAsm absC us = initUs us (runNCG absC)
dumpRealAsm absC us = initUs_ us (runNCG absC)
runNCG absC
= genCodeAbstractC absC `thenUs` \ treelists ->
......
......@@ -349,7 +349,7 @@ type MassageM result
-> CollectedCCs
-> (CollectedCCs, result)
-- the initUs function also returns the final UniqueSupply and CollectedCCs
-- the initMM function also returns the final CollectedCCs
initMM :: Module -- module name, which we may consult
-> UniqSupply
......
......@@ -23,20 +23,24 @@ import CostCentre ( noCCS )
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}
......@@ -74,12 +78,36 @@ Names new unique ids, since the code generator assumes that binders
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
......@@ -100,7 +128,7 @@ topCoreBindsToStg :: UniqSupply -- name supply
-> [StgBinding] -- output
topCoreBindsToStg us core_binds
= initUs us (coreBindsToStg emptyVarEnv core_binds)
= initUs_ us (coreBindsToStg emptyVarEnv core_binds)
where
coreBindsToStg :: StgEnv -> [CoreBind] -> UniqSM [StgBinding]
......@@ -124,13 +152,14 @@ coreBindToStg :: StgEnv
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
......@@ -144,13 +173,13 @@ coreBindToStg env (Rec 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
......@@ -188,7 +217,7 @@ exprToRhs (StgLet (StgNonRec var1 rhs) (StgApp var2 []))
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
......@@ -200,13 +229,12 @@ exprToRhs (StgCon (DataCon con) args _)
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
......@@ -237,25 +265,29 @@ isDynName nm =
%************************************************************************
\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)
......@@ -268,12 +300,9 @@ coreArgToStg env arg
-- 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}
......@@ -284,9 +313,9 @@ coreArgToStg env arg
%************************************************************************
\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}
......@@ -298,13 +327,15 @@ coreExprToStg env (Var var)
%************************************************************************
\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
......@@ -347,9 +378,9 @@ coreExprToStg env expr@(Lam _ _)
%************************************************************************
\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}
......@@ -362,20 +393,20 @@ coreExprToStg env (Let bind body)
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}
......@@ -386,11 +417,12 @@ coreExprToStg env expr
%************************************************************************
\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
......@@ -401,30 +433,29 @@ coreExprToStgFloat env expr@(App _ _)