diff options
| -rw-r--r-- | ghc/compiler/absCSyn/CLabel.lhs | 19 | ||||
| -rw-r--r-- | ghc/compiler/codeGen/CgClosure.lhs | 85 | ||||
| -rw-r--r-- | ghc/compiler/codeGen/ClosureInfo.lhs | 61 | ||||
| -rw-r--r-- | ghc/compiler/nativeGen/AsmCodeGen.lhs | 6 | ||||
| -rw-r--r-- | ghc/compiler/profiling/SCCfinal.lhs | 2 | ||||
| -rw-r--r-- | ghc/compiler/stgSyn/CoreToStg.lhs | 240 |
6 files changed, 249 insertions, 164 deletions
diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs index 436856037e..9161b280fd 100644 --- a/ghc/compiler/absCSyn/CLabel.lhs +++ b/ghc/compiler/absCSyn/CLabel.lhs @@ -1,7 +1,7 @@ % % (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), diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index 0348f8f282..86f90af8ca 100644 --- a/ghc/compiler/codeGen/CgClosure.lhs +++ b/ghc/compiler/codeGen/CgClosure.lhs @@ -1,7 +1,7 @@ % % (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} %************************************************************************ diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index c81bafbb1a..986bfd29ee 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -1,7 +1,7 @@ % % (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} %************************************************************************ diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs index ce8587bfcb..6ed3e5b353 100644 --- a/ghc/compiler/nativeGen/AsmCodeGen.lhs +++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs @@ -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 -> diff --git a/ghc/compiler/profiling/SCCfinal.lhs b/ghc/compiler/profiling/SCCfinal.lhs index d7a3a0d890..6afed02266 100644 --- a/ghc/compiler/profiling/SCCfinal.lhs +++ b/ghc/compiler/profiling/SCCfinal.lhs @@ -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 diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index ad960de800..034d571534 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -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 _ _) (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} %************************************************************************ @@ -433,16 +464,36 @@ coreExprToStgFloat env expr@(App _ _) %* * %************************************************************************ +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} %************************************************************************ @@ -452,8 +503,8 @@ coreExprToStgFloat env expr@(Con con args) %************************************************************************ \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') @@ -473,29 +524,34 @@ coreExprToStgFloat env expr@(Case 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} @@ -563,22 +619,16 @@ newLocalIds env (b:bs) 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 |