%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
-%************************************************************************
-%* *
-\section[CoreToStg]{Converting core syntax to STG syntax}
-%* *
-%************************************************************************
-
-Convert a @CoreSyntax@ program to a @StgSyntax@ program.
+\section[CoreToStg]{Converts Core to STG Syntax}
+And, as we have the info in hand, we may convert some lets to
+let-no-escapes.
\begin{code}
+module CoreToStg ( coreToStg, coreExprToStg ) where
+
#include "HsVersions.h"
-module CoreToStg (
- topCoreBindsToStg,
-
- -- and to make the interface self-sufficient...
- SplitUniqSupply, Id, CoreExpr, CoreBinding, StgBinding,
- StgRhs, StgBinderInfo
- ) where
-
-import PlainCore -- input
-import AnnCoreSyn -- intermediate form on which all work is done
-import StgSyn -- output
-import SplitUniq
-import Unique -- the UniqueSupply monadery used herein
-
-import AbsPrel ( unpackCStringId, stringTy,
- integerTy, rationalTy, ratioDataCon,
- PrimOp(..), -- For Int2IntegerOp etc
- integerZeroId, integerPlusOneId, integerMinusOneId
- IF_ATTACK_PRAGMAS(COMMA mkListTy COMMA charTy)
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-
-import AbsUniType ( isPrimType, isLeakFreeType, getUniDataTyCon )
-import Bag -- Bag operations
-import BasicLit ( mkMachInt, BasicLit(..), PrimKind ) -- ToDo: its use is ugly...
-import CostCentre ( noCostCentre, CostCentre )
-import Id ( mkSysLocal, getIdUniType, isBottomingId
- IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed)
- )
-import IdEnv
-import Maybes ( Maybe(..), catMaybes )
-import Outputable ( isExported )
-import Pretty -- debugging only!
-import SpecTyFuns ( mkSpecialisedCon )
-import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
-import Util
+import CoreSyn
+import CoreUtils
+import StgSyn
+
+import Type
+import TyCon ( isAlgTyCon )
+import Literal
+import Id
+import Var ( Var, globalIdDetails, varType )
+import IdInfo
+import DataCon
+import CostCentre ( noCCS )
+import VarSet
+import VarEnv
+import DataCon ( dataConWrapId )
+import IdInfo ( OccInfo(..) )
+import Maybes ( maybeToBool )
+import Name ( getOccName, isExternallyVisibleName, isDllName )
+import OccName ( occNameUserString )
+import BasicTypes ( TopLevelFlag(..), isNotTopLevel, Arity )
+import CmdLineOpts ( DynFlags, opt_RuntimeTypes )
+import FastTypes hiding ( fastOr )
+import Outputable
+
+import List ( partition )
+
+infixr 9 `thenLne`
\end{code}
+%************************************************************************
+%* *
+\subsection[live-vs-free-doc]{Documentation}
+%* *
+%************************************************************************
- *************** OVERVIEW *********************
-
+(There is other relevant documentation in codeGen/CgLetNoEscape.)
+
+The actual Stg datatype is decorated with {\em live variable}
+information, as well as {\em free variable} information. The two are
+{\em not} the same. Liveness is an operational property rather than a
+semantic one. A variable is live at a particular execution point if
+it can be referred to {\em directly} again. In particular, a dead
+variable's stack slot (if it has one):
+\begin{enumerate}
+\item
+should be stubbed to avoid space leaks, and
+\item
+may be reused for something else.
+\end{enumerate}
+
+There ought to be a better way to say this. Here are some examples:
+\begin{verbatim}
+ let v = [q] \[x] -> e
+ in
+ ...v... (but no q's)
+\end{verbatim}
+
+Just after the `in', v is live, but q is dead. If the whole of that
+let expression was enclosed in a case expression, thus:
+\begin{verbatim}
+ case (let v = [q] \[x] -> e in ...v...) of
+ alts[...q...]
+\end{verbatim}
+(ie @alts@ mention @q@), then @q@ is live even after the `in'; because
+we'll return later to the @alts@ and need it.
+
+Let-no-escapes make this a bit more interesting:
+\begin{verbatim}
+ let-no-escape v = [q] \ [x] -> e
+ in
+ ...v...
+\end{verbatim}
+Here, @q@ is still live at the `in', because @v@ is represented not by
+a closure but by the current stack state. In other words, if @v@ is
+live then so is @q@. Furthermore, if @e@ mentions an enclosing
+let-no-escaped variable, then {\em its} free variables are also live
+if @v@ is.
-The business of this pass is to convert Core to Stg. On the way:
+%************************************************************************
+%* *
+\subsection[caf-info]{Collecting live CAF info}
+%* *
+%************************************************************************
-* We discard type lambdas and applications. In so doing we discard
- "trivial" bindings such as
- x = y t1 t2
- where t1, t2 are types
+In this pass we also collect information on which CAFs are live for
+constructing SRTs (see SRT.lhs).
-* We make the representation of NoRep literals explicit, and
- float their bindings to the top level
+A top-level Id has CafInfo, which is
-* We do *not* pin on the correct free/live var info; that's done later.
- Instead we use bOGUS_LVS and _FVS as a placeholder.
+ - MayHaveCafRefs, if it may refer indirectly to
+ one or more CAFs, or
+ - NoCafRefs if it definitely doesn't
-* We convert case x of {...; x' -> ...x'...}
- to
- case x of {...; _ -> ...x... }
+we collect the CafInfo first by analysing the original Core expression, and
+also place this information in the environment.
- See notes in SimplCase.lhs, near simplDefault for the reasoning here.
+During CoreToStg, we then pin onto each binding and case expression, a
+list of Ids which represents the "live" CAFs at that point. The meaning
+of "live" here is the same as for live variables, see above (which is
+why it's convenient to collect CAF information here rather than elsewhere).
+The later SRT pass takes these lists of Ids and uses them to construct
+the actual nested SRTs, and replaces the lists of Ids with (offset,length)
+pairs.
%************************************************************************
%* *
-\subsection[coreToStg-programs]{Converting a core program and core bindings}
+\subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs}
%* *
%************************************************************************
-Because we're going to come across ``boring'' bindings like
-\tr{let x = /\ tyvars -> y in ...}, we want to keep a small
-environment, so we can just replace all occurrences of \tr{x}
-with \tr{y}.
-
\begin{code}
-type StgEnv = IdEnv PlainStgAtom
-\end{code}
-
-No free/live variable information is pinned on in this pass; it's added
-later. For this pass
-we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders.
+coreToStg :: DynFlags -> [CoreBind] -> IO [StgBinding]
+coreToStg dflags pgm
+ = return pgm'
+ where (_, _, pgm') = coreTopBindsToStg emptyVarEnv pgm
-\begin{code}
-bOGUS_LVs :: PlainStgLiveVars
-bOGUS_LVs = panic "bOGUS_LVs"
+coreExprToStg :: CoreExpr -> StgExpr
+coreExprToStg expr
+ = new_expr where (new_expr,_,_) = initLne emptyVarEnv (coreToStgExpr expr)
-bOGUS_FVs :: [Id]
-bOGUS_FVs = panic "bOGUS_FVs"
-\end{code}
-\begin{code}
-topCoreBindsToStg :: SplitUniqSupply -- name supply
- -> [PlainCoreBinding] -- input
- -> [PlainStgBinding] -- output
+coreTopBindsToStg
+ :: IdEnv HowBound -- environment for the bindings
+ -> [CoreBind]
+ -> (IdEnv HowBound, FreeVarsInfo, [StgBinding])
-topCoreBindsToStg us core_binds
- = case (initSUs us (binds_to_stg nullIdEnv core_binds)) of
- (_, stuff) -> stuff
+coreTopBindsToStg env [] = (env, emptyFVInfo, [])
+coreTopBindsToStg env (b:bs)
+ = (env2, fvs2, b':bs')
where
- binds_to_stg :: StgEnv -> [PlainCoreBinding] -> SUniqSM [PlainStgBinding]
-
- binds_to_stg env [] = returnSUs []
- binds_to_stg env (b:bs)
- = do_top_bind env b `thenSUs` \ (new_b, new_env, float_binds) ->
- binds_to_stg new_env bs `thenSUs` \ new_bs ->
- returnSUs (bagToList float_binds ++ -- Literals
- new_b ++
- new_bs)
-
- do_top_bind env bind@(CoRec pairs)
- = coreBindToStg env bind
-
- do_top_bind env bind@(CoNonRec var rhs)
- = coreBindToStg env bind `thenSUs` \ (stg_binds, new_env, float_binds) ->
-
- case stg_binds of
- [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body)] ->
- -- Mega-special case; there's still a binding there
- -- no fvs (of course), *no args*, "let" rhs
- let
- (extra_float_binds, rhs_body') = seek_liftable [] rhs_body
- in
- returnSUs (extra_float_binds ++
- [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body')],
- new_env,
- float_binds)
-
- other -> returnSUs (stg_binds, new_env, float_binds)
-
- --------------------
- -- HACK: look for very simple, obviously-liftable bindings
- -- that can come up to the top level; those that couldn't
- -- 'cause they were big-lambda constrained in the Core world.
-
- seek_liftable :: [PlainStgBinding] -- accumulator...
- -> PlainStgExpr -- look for top-lev liftables
- -> ([PlainStgBinding], PlainStgExpr) -- result
-
- seek_liftable acc expr@(StgLet inner_bind body)
- | is_liftable inner_bind
- = seek_liftable (inner_bind : acc) body
-
- seek_liftable acc other_expr = (reverse acc, other_expr) -- Finished
-
- --------------------
- is_liftable (StgNonRec binder (StgRhsClosure _ _ _ _ args body))
- = not (null args) -- it's manifestly a function...
- || isLeakFreeType [] (getIdUniType binder)
- || is_whnf body
- -- ToDo: use a decent manifestlyWHNF function for STG?
- where
- is_whnf (StgConApp _ _ _) = True
- is_whnf (StgApp (StgVarAtom v) _ _) = isBottomingId v
- is_whnf other = False
+ -- env accumulates down the list of binds, fvs accumulates upwards
+ (env1, fvs2, b' ) = coreTopBindToStg env fvs1 b
+ (env2, fvs1, bs') = coreTopBindsToStg env1 bs
+
+
+coreTopBindToStg
+ :: IdEnv HowBound
+ -> FreeVarsInfo -- Info about the body
+ -> CoreBind
+ -> (IdEnv HowBound, FreeVarsInfo, StgBinding)
+
+coreTopBindToStg env body_fvs (NonRec id rhs)
+ = let
+ caf_info = hasCafRefs env rhs
+
+ env' = extendVarEnv env id (LetBound how_bound emptyLVS (predictArity rhs))
+
+ how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs
+ | otherwise = TopLevelNoCafs
+
+ (stg_rhs, fvs', cafs) =
+ initLne env (
+ coreToStgRhs body_fvs TopLevel (id,rhs)
+ `thenLne` \ (stg_rhs, fvs', _) ->
+ freeVarsToLiveVars fvs' `thenLne` \ (_, cafs) ->
+ returnLne (stg_rhs, fvs', cafs)
+ )
+
+ bind = StgNonRec (SRTEntries cafs) id stg_rhs
+ in
+ ASSERT2(predictArity rhs == stgRhsArity stg_rhs, ppr id)
+ ASSERT2(consistent caf_info bind, ppr id)
+-- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
+ (env', fvs' `unionFVInfo` body_fvs, bind)
- is_liftable (StgRec [(_, StgRhsClosure _ _ _ _ args body)])
- = not (null args) -- it's manifestly a (recursive) function...
+coreTopBindToStg env body_fvs (Rec pairs)
+ = let
+ (binders, rhss) = unzip pairs
- is_liftable anything_else = False
-\end{code}
+ -- to calculate caf_info, we initially map all the binders to
+ -- TopLevelNoCafs.
+ env1 = extendVarEnvList env
+ [ (b, LetBound TopLevelNoCafs emptyLVS (error "no arity"))
+ | b <- binders ]
-%************************************************************************
-%* *
-\subsection[coreToStg-binds]{Converting bindings}
-%* *
-%************************************************************************
+ caf_info = hasCafRefss env1{-NB: not env'-} rhss
-\begin{code}
-coreBindToStg :: StgEnv
- -> PlainCoreBinding
- -> SUniqSM ([PlainStgBinding], -- Empty or singleton
- StgEnv, -- New envt
- Bag PlainStgBinding) -- Floats
+ env' = extendVarEnvList env
+ [ (b, LetBound how_bound emptyLVS (predictArity rhs))
+ | (b,rhs) <- pairs ]
-coreBindToStg env (CoNonRec binder rhs)
- = coreRhsToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) ->
+ how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs
+ | otherwise = TopLevelNoCafs
- let
- -- Binds to return if RHS is trivial
- triv_binds = if isExported binder then
- [StgNonRec binder stg_rhs] -- Retain it
- else
- [] -- Discard it
- in
- case stg_rhs of
- StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) ->
- -- Trivial RHS, so augment envt, and ditch the binding
- returnSUs (triv_binds, new_env, rhs_binds)
- where
- new_env = addOneToIdEnv env binder atom
-
- StgRhsCon cc con_id [] ->
- -- Trivial RHS, so augment envt, and ditch the binding
- returnSUs (triv_binds, new_env, rhs_binds)
- where
- new_env = addOneToIdEnv env binder (StgVarAtom con_id)
-
- other -> -- Non-trivial RHS, so don't augment envt
- returnSUs ([StgNonRec binder stg_rhs], env, rhs_binds)
-
-coreBindToStg env (CoRec pairs)
- = -- NB: *** WE DO NOT CHECK FOR TRIV_BINDS in REC BIND ****
- -- (possibly ToDo)
- let
- (binders, rhss) = unzip pairs
+ (stg_rhss, fvs', cafs)
+ = initLne env' (
+ mapAndUnzip3Lne (coreToStgRhs body_fvs TopLevel) pairs
+ `thenLne` \ (stg_rhss, fvss', _) ->
+ let fvs' = unionFVInfos fvss' in
+ freeVarsToLiveVars fvs' `thenLne` \ (_, cafs) ->
+ returnLne (stg_rhss, fvs', cafs)
+ )
+
+ bind = StgRec (SRTEntries cafs) (zip binders stg_rhss)
in
- mapAndUnzipSUs (coreRhsToStg env) rhss `thenSUs` \ (stg_rhss, rhs_binds) ->
- returnSUs ([StgRec (binders `zip` stg_rhss)], env, unionManyBags rhs_binds)
+ ASSERT2(and [predictArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders)
+ ASSERT2(consistent caf_info bind, ppr binders)
+-- WARN(not (consistent caf_info bind), ppr binders <+> ppr cafs <+> ppCafInfo caf_info)
+ (env', fvs' `unionFVInfo` body_fvs, bind)
+
+-- assertion helper
+consistent caf_info bind = mayHaveCafRefs caf_info == stgBindHasCafRefs bind
\end{code}
+\begin{code}
+coreToStgRhs
+ :: FreeVarsInfo -- Free var info for the scope of the binding
+ -> TopLevelFlag
+ -> (Id,CoreExpr)
+ -> LneM (StgRhs, FreeVarsInfo, EscVarsSet)
+
+coreToStgRhs scope_fv_info top (binder, rhs)
+ = coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, rhs_escs) ->
+ returnLne (mkStgRhs top rhs_fvs binder_info new_rhs,
+ rhs_fvs, rhs_escs)
+ where
+ binder_info = lookupFVInfo scope_fv_info binder
+
+mkStgRhs :: TopLevelFlag -> FreeVarsInfo -> StgBinderInfo
+ -> StgExpr -> StgRhs
+
+mkStgRhs top rhs_fvs binder_info (StgLam _ bndrs body)
+ = StgRhsClosure noCCS binder_info
+ (getFVs rhs_fvs)
+ ReEntrant
+ bndrs body
+
+mkStgRhs top rhs_fvs binder_info (StgConApp con args)
+ | isNotTopLevel top || not (isDllConApp con args)
+ = StgRhsCon noCCS con args
+
+mkStgRhs top rhs_fvs binder_info rhs
+ = StgRhsClosure noCCS binder_info
+ (getFVs rhs_fvs)
+ (updatable [] rhs)
+ [] rhs
+ where
+ updatable args body | null args && isPAP body = ReEntrant
+ | otherwise = Updatable
+{- ToDo:
+ upd = if isOnceDem dem
+ then (if isNotTop toplev
+ then SingleEntry -- HA! Paydirt for "dem"
+ else
+#ifdef DEBUG
+ trace "WARNING: SE CAFs unsupported, forcing UPD instead" $
+#endif
+ Updatable)
+ else Updatable
+ -- For now we forbid SingleEntry CAFs; they tickle the
+ -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
+ -- and I don't understand why. There's only one SE_CAF (well,
+ -- only one that tickled a great gaping bug in an earlier attempt
+ -- at ClosureInfo.getEntryConvention) in the whole of nofib,
+ -- specifically Main.lvl6 in spectral/cryptarithm2.
+ -- So no great loss. KSW 2000-07.
+-}
+\end{code}
-%************************************************************************
-%* *
-\subsection[coreToStg-rhss]{Converting right hand sides}
-%* *
-%************************************************************************
+Detect thunks which will reduce immediately to PAPs, and make them
+non-updatable. This has several advantages:
+
+ - the non-updatable thunk behaves exactly like the PAP,
+
+ - the thunk is more efficient to enter, because it is
+ specialised to the task.
+
+ - we save one update frame, one stg_update_PAP, one update
+ and lots of PAP_enters.
+
+ - in the case where the thunk is top-level, we save building
+ a black hole and futhermore the thunk isn't considered to
+ be a CAF any more, so it doesn't appear in any SRTs.
+
+We do it here, because the arity information is accurate, and we need
+to do it before the SRT pass to save the SRT entries associated with
+any top-level PAPs.
\begin{code}
-coreRhsToStg :: StgEnv -> PlainCoreExpr -> SUniqSM (PlainStgRhs, Bag PlainStgBinding)
-
-coreRhsToStg env core_rhs
- = coreExprToStg env core_rhs `thenSUs` \ (stg_expr, stg_binds) ->
-
- let stg_rhs = case stg_expr of
- StgLet (StgNonRec var1 rhs) (StgApp (StgVarAtom var2) [] _)
- | var1 == var2 -> rhs
- -- This curious stuff is to unravel what a lambda turns into
- -- We have to do it this way, rather than spot a lambda in the
- -- incoming rhs
-
- StgConApp con args _ -> StgRhsCon noCostCentre con args
-
- other -> StgRhsClosure noCostCentre -- No cost centre (ToDo?)
- stgArgOcc -- safe
- bOGUS_FVs
- Updatable -- Be pessimistic
- []
- stg_expr
- in
- returnSUs (stg_rhs, stg_binds)
+isPAP (StgApp f args) = idArity f > length args
+isPAP _ = False
\end{code}
-%************************************************************************
-%* *
-\subsection[coreToStg-lits]{Converting literals}
-%* *
-%************************************************************************
+-- ---------------------------------------------------------------------------
+-- Expressions
+-- ---------------------------------------------------------------------------
-Literals: the NoRep kind need to be de-no-rep'd.
-We always replace them with a simple variable, and float a suitable
-binding out to the top level.
+\begin{code}
+coreToStgExpr
+ :: CoreExpr
+ -> LneM (StgExpr, -- Decorated STG expr
+ FreeVarsInfo, -- Its free vars (NB free, not live)
+ EscVarsSet) -- Its escapees, a subset of its free vars;
+ -- also a subset of the domain of the envt
+ -- because we are only interested in the escapees
+ -- for vars which might be turned into
+ -- let-no-escaped ones.
+\end{code}
-If an Integer is small enough (Haskell implementations must support
-Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
-otherwise, wrap with @litString2Integer@.
+The second and third components can be derived in a simple bottom up pass, not
+dependent on any decisions about which variables will be let-no-escaped or
+not. The first component, that is, the decorated expression, may then depend
+on these components, but it in turn is not scrutinised as the basis for any
+decisions. Hence no black holes.
\begin{code}
-tARGET_MIN_INT, tARGET_MAX_INT :: Integer
-tARGET_MIN_INT = -536870912
-tARGET_MAX_INT = 536870912
+coreToStgExpr (Lit l) = returnLne (StgLit l, emptyFVInfo, emptyVarSet)
+coreToStgExpr (Var v) = coreToStgApp Nothing v []
-litToStgAtom :: BasicLit -> SUniqSM (PlainStgAtom, Bag PlainStgBinding)
+coreToStgExpr expr@(App _ _)
+ = coreToStgApp Nothing f args
+ where
+ (f, args) = myCollectArgs expr
-litToStgAtom (NoRepStr s)
- = newStgVar stringTy `thenSUs` \ var ->
+coreToStgExpr expr@(Lam _ _)
+ = let (args, body) = myCollectBinders expr
+ args' = filterStgBinders args
+ in
+ extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $
+ coreToStgExpr body `thenLne` \ (body, body_fvs, body_escs) ->
let
- rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
- stgArgOcc -- safe
- bOGUS_FVs
- Updatable -- OLD: ReEntrant (see note below)
- [] -- No arguments
- val
-
--- We used not to update strings, so that they wouldn't clog up the heap,
--- but instead be unpacked each time. But on some programs that costs a lot
--- [eg hpg], so now we update them.
-
- val = StgApp (StgVarAtom unpackCStringId)
- [StgLitAtom (MachStr s)]
- bOGUS_LVs
+ set_of_args = mkVarSet args'
+ fvs = args' `minusFVBinders` body_fvs
+ escs = body_escs `minusVarSet` set_of_args
+ result_expr | null args' = body
+ | otherwise = StgLam (exprType expr) args' body
in
- returnSUs (StgVarAtom var, unitBag (StgNonRec var rhs))
+ returnLne (result_expr, fvs, escs)
+
+coreToStgExpr (Note (SCC cc) expr)
+ = coreToStgExpr expr `thenLne` ( \ (expr2, fvs, escs) ->
+ returnLne (StgSCC cc expr2, fvs, escs) )
-litToStgAtom (NoRepInteger i)
- -- extremely convenient to look out for a few very common
- -- Integer literals!
- | i == 0 = returnSUs (StgVarAtom integerZeroId, emptyBag)
- | i == 1 = returnSUs (StgVarAtom integerPlusOneId, emptyBag)
- | i == (-1) = returnSUs (StgVarAtom integerMinusOneId, emptyBag)
+coreToStgExpr (Note other_note expr)
+ = coreToStgExpr expr
- | otherwise
- = newStgVar integerTy `thenSUs` \ var ->
+
+-- Cases require a little more real work.
+
+coreToStgExpr (Case scrut bndr alts)
+ = extendVarEnvLne [(bndr, CaseBound)] $
+ vars_alts (findDefault alts) `thenLne` \ (alts2, alts_fvs, alts_escs) ->
+ freeVarsToLiveVars alts_fvs `thenLne` \ (alts_lvs, alts_caf_refs) ->
let
- rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
- stgArgOcc -- safe
- bOGUS_FVs
- Updatable -- Update an integer
- [] -- No arguments
- val
-
- val
- | i > tARGET_MIN_INT && i < tARGET_MAX_INT
- = -- Start from an Int
- StgPrimApp Int2IntegerOp [StgLitAtom (mkMachInt i)] bOGUS_LVs
-
- | otherwise
- = -- Start from a string
- StgPrimApp Addr2IntegerOp [StgLitAtom (MachStr (_PK_ (show i)))] bOGUS_LVs
+ -- determine whether the default binder is dead or not
+ -- This helps the code generator to avoid generating an assignment
+ -- for the case binder (is extremely rare cases) ToDo: remove.
+ bndr'= if (bndr `elementOfFVInfo` alts_fvs)
+ then bndr
+ else bndr `setIdOccInfo` IAmDead
+
+ -- Don't consider the default binder as being 'live in alts',
+ -- since this is from the point of view of the case expr, where
+ -- the default binder is not free.
+ live_in_alts = (alts_lvs `minusVarSet` unitVarSet bndr)
in
- returnSUs (StgVarAtom var, unitBag (StgNonRec var rhs))
-
-litToStgAtom (NoRepRational r)
- = litToStgAtom (NoRepInteger (numerator r)) `thenSUs` \ (num_atom, binds1) ->
- litToStgAtom (NoRepInteger (denominator r)) `thenSUs` \ (denom_atom, binds2) ->
- newStgVar rationalTy `thenSUs` \ var ->
- let
- rhs = StgRhsCon noCostCentre -- No cost centre (ToDo?)
- ratioDataCon -- Constructor
- [num_atom, denom_atom]
- in
- returnSUs (StgVarAtom var, binds1 `unionBags`
- binds2 `unionBags`
- unitBag (StgNonRec var rhs))
-
-litToStgAtom other_lit = returnSUs (StgLitAtom other_lit, emptyBag)
-\end{code}
+ -- we tell the scrutinee that everything live in the alts
+ -- is live in it, too.
+ setVarsLiveInCont (live_in_alts,alts_caf_refs) (
+ coreToStgExpr scrut `thenLne` \ (scrut2, scrut_fvs, scrut_escs) ->
+ freeVarsToLiveVars scrut_fvs `thenLne` \ (scrut_lvs, _) ->
+ returnLne (scrut2, scrut_fvs, scrut_escs, scrut_lvs)
+ )
+ `thenLne` \ (scrut2, scrut_fvs, scrut_escs, scrut_lvs) ->
+
+ let srt = SRTEntries alts_caf_refs
+ in
+ returnLne (
+ StgCase scrut2 scrut_lvs live_in_alts bndr' srt alts2,
+ bndr `minusFVBinder` (scrut_fvs `unionFVInfo` alts_fvs),
+ (alts_escs `minusVarSet` unitVarSet bndr) `unionVarSet` getFVSet scrut_fvs
+ -- You might think we should have scrut_escs, not
+ -- (getFVSet scrut_fvs), but actually we can't call, and
+ -- then return from, a let-no-escape thing.
+ )
+ where
+ scrut_ty = idType bndr
+ prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
+
+ vars_alts (alts,deflt)
+ | prim_case
+ = mapAndUnzip3Lne vars_prim_alt alts
+ `thenLne` \ (alts2, alts_fvs_list, alts_escs_list) ->
+ let
+ alts_fvs = unionFVInfos alts_fvs_list
+ alts_escs = unionVarSets alts_escs_list
+ in
+ vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) ->
+ returnLne (
+ mkStgPrimAlts scrut_ty alts2 deflt2,
+ alts_fvs `unionFVInfo` deflt_fvs,
+ alts_escs `unionVarSet` deflt_escs
+ )
+
+ | otherwise
+ = mapAndUnzip3Lne vars_alg_alt alts
+ `thenLne` \ (alts2, alts_fvs_list, alts_escs_list) ->
+ let
+ alts_fvs = unionFVInfos alts_fvs_list
+ alts_escs = unionVarSets alts_escs_list
+ in
+ vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) ->
+ returnLne (
+ mkStgAlgAlts scrut_ty alts2 deflt2,
+ alts_fvs `unionFVInfo` deflt_fvs,
+ alts_escs `unionVarSet` deflt_escs
+ )
+ where
+ vars_prim_alt (LitAlt lit, _, rhs)
+ = coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
+ returnLne ((lit, rhs2), rhs_fvs, rhs_escs)
+
+ vars_alg_alt (DataAlt con, binders, rhs)
+ = let
+ -- remove type variables
+ binders' = filterStgBinders binders
+ in
+ extendVarEnvLne [(b, CaseBound) | b <- binders'] $
+ coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
+ let
+ good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders' ]
+ -- records whether each param is used in the RHS
+ in
+ returnLne (
+ (con, binders', good_use_mask, rhs2),
+ binders' `minusFVBinders` rhs_fvs,
+ rhs_escs `minusVarSet` mkVarSet binders'
+ -- ToDo: remove the minusVarSet;
+ -- since escs won't include any of these binders
+ )
+ vars_alg_alt other = pprPanic "vars_alg_alt" (ppr other)
+
+ vars_deflt Nothing
+ = returnLne (StgNoDefault, emptyFVInfo, emptyVarSet)
+
+ vars_deflt (Just rhs)
+ = coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
+ returnLne (StgBindDefault rhs2, rhs_fvs, rhs_escs)
+\end{code}
-%************************************************************************
-%* *
-\subsection[coreToStg-atoms{Converting atoms}
-%* *
-%************************************************************************
+Lets not only take quite a bit of work, but this is where we convert
+then to let-no-escapes, if we wish.
+(Meanwhile, we don't expect to see let-no-escapes...)
\begin{code}
-coreAtomToStg :: StgEnv -> PlainCoreAtom -> SUniqSM (PlainStgAtom, Bag PlainStgBinding)
+coreToStgExpr (Let bind body)
+ = fixLne (\ ~(_, _, _, no_binder_escapes) ->
+ coreToStgLet no_binder_escapes bind body
+ ) `thenLne` \ (new_let, fvs, escs, _) ->
-coreAtomToStg env (CoVarAtom var) = returnSUs (stgLookup env var, emptyBag)
-coreAtomToStg env (CoLitAtom lit) = litToStgAtom lit
+ returnLne (new_let, fvs, escs)
\end{code}
-There's not anything interesting we can ASSERT about \tr{var} if it
-isn't in the StgEnv. (WDP 94/06)
\begin{code}
-stgLookup :: StgEnv -> Id -> PlainStgAtom
-
-stgLookup env var = case (lookupIdEnv env var) of
- Nothing -> StgVarAtom var
- Just atom -> atom
+mkStgAlgAlts ty alts deflt
+ = case alts of
+ -- Get the tycon from the data con
+ (dc, _, _, _) : _rest
+ -> StgAlgAlts (Just (dataConTyCon dc)) alts deflt
+
+ -- Otherwise just do your best
+ [] -> case splitTyConApp_maybe (repType ty) of
+ Just (tc,_) | isAlgTyCon tc
+ -> StgAlgAlts (Just tc) alts deflt
+ other
+ -> StgAlgAlts Nothing alts deflt
+
+mkStgPrimAlts ty alts deflt
+ = StgPrimAlts (tyConAppTyCon ty) alts deflt
\end{code}
-%************************************************************************
-%* *
-\subsection[coreToStg-exprs]{Converting core expressions}
-%* *
-%************************************************************************
-\begin{code}
-coreExprToStg :: StgEnv
- -> PlainCoreExpr
- -> SUniqSM (PlainStgExpr, -- Result
- Bag PlainStgBinding) -- Float these to top level
-\end{code}
+-- ---------------------------------------------------------------------------
+-- Applications
+-- ---------------------------------------------------------------------------
\begin{code}
-coreExprToStg env (CoLit lit)
- = litToStgAtom lit `thenSUs` \ (atom, binds) ->
- returnSUs (StgApp atom [] bOGUS_LVs, binds)
+coreToStgApp
+ :: Maybe UpdateFlag -- Just upd <=> this application is
+ -- the rhs of a thunk binding
+ -- x = [...] \upd [] -> the_app
+ -- with specified update flag
+ -> Id -- Function
+ -> [CoreArg] -- Arguments
+ -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
+
+coreToStgApp maybe_thunk_body f args
+ = coreToStgArgs args `thenLne` \ (args', args_fvs) ->
+ lookupVarLne f `thenLne` \ how_bound ->
-coreExprToStg env (CoVar var)
- = returnSUs (StgApp (stgLookup env var) [] bOGUS_LVs, emptyBag)
+ let
+ n_val_args = valArgCount args
+ not_letrec_bound = not (isLetBound how_bound)
+ fun_fvs
+ = let fvs = singletonFVInfo f how_bound fun_occ in
+ -- e.g. (f :: a -> int) (x :: a)
+ -- Here the free variables are "f", "x" AND the type variable "a"
+ -- coreToStgArgs will deal with the arguments recursively
+ if opt_RuntimeTypes then
+ fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType (varType f))
+ else fvs
+
+ -- Mostly, the arity info of a function is in the fn's IdInfo
+ -- But new bindings introduced by CoreSat may not have no
+ -- arity info; it would do us no good anyway. For example:
+ -- let f = \ab -> e in f
+ -- No point in having correct arity info for f!
+ -- Hence the hasArity stuff below.
+ f_arity = case how_bound of
+ LetBound _ _ arity -> arity
+ _ -> 0
+
+ fun_occ
+ | not_letrec_bound = noBinderInfo -- Uninteresting variable
+ | f_arity > 0 && f_arity <= n_val_args = stgSatOcc -- Saturated or over-saturated function call
+ | otherwise = stgUnsatOcc -- Unsaturated function or thunk
+
+ fun_escs
+ | not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting
+ | f_arity == n_val_args = emptyVarSet -- A function *or thunk* with an exactly
+ -- saturated call doesn't escape
+ -- (let-no-escape applies to 'thunks' too)
+
+ | otherwise = unitVarSet f -- Inexact application; it does escape
+
+ -- At the moment of the call:
+
+ -- either the function is *not* let-no-escaped, in which case
+ -- nothing is live except live_in_cont
+ -- or the function *is* let-no-escaped in which case the
+ -- variables it uses are live, but still the function
+ -- itself is not. PS. In this case, the function's
+ -- live vars should already include those of the
+ -- continuation, but it does no harm to just union the
+ -- two regardless.
+
+ res_ty = exprType (mkApps (Var f) args)
+ app = case globalIdDetails f of
+ DataConId dc -> StgConApp dc args'
+ PrimOpId op -> StgOpApp (StgPrimOp op) args' res_ty
+ FCallId call -> StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
+ _other -> StgApp f args'
-coreExprToStg env (CoCon con types args)
- = mapAndUnzipSUs (coreAtomToStg env) args `thenSUs` \ (stg_atoms, stg_binds) ->
- returnSUs (StgConApp spec_con stg_atoms bOGUS_LVs, unionManyBags stg_binds)
- where
- spec_con = mkSpecialisedCon con types
+ in
+ returnLne (
+ app,
+ fun_fvs `unionFVInfo` args_fvs,
+ fun_escs `unionVarSet` (getFVSet args_fvs)
+ -- All the free vars of the args are disqualified
+ -- from being let-no-escaped.
+ )
-coreExprToStg env (CoPrim op tys args)
- = mapAndUnzipSUs (coreAtomToStg env) args `thenSUs` \ (stg_atoms, stg_binds) ->
- returnSUs (StgPrimApp op stg_atoms bOGUS_LVs, unionManyBags stg_binds)
+
+
+-- ---------------------------------------------------------------------------
+-- Argument lists
+-- This is the guy that turns applications into A-normal form
+-- ---------------------------------------------------------------------------
+
+coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo)
+coreToStgArgs []
+ = returnLne ([], emptyFVInfo)
+
+coreToStgArgs (Type ty : args) -- Type argument
+ = coreToStgArgs args `thenLne` \ (args', fvs) ->
+ if opt_RuntimeTypes then
+ returnLne (StgTypeArg ty : args', fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType ty))
+ else
+ returnLne (args', fvs)
+
+coreToStgArgs (arg : args) -- Non-type argument
+ = coreToStgArgs args `thenLne` \ (stg_args, args_fvs) ->
+ coreToStgExpr arg `thenLne` \ (arg', arg_fvs, escs) ->
+ let
+ fvs = args_fvs `unionFVInfo` arg_fvs
+ stg_arg = case arg' of
+ StgApp v [] -> StgVarArg v
+ StgConApp con [] -> StgVarArg (dataConWrapId con)
+ StgLit lit -> StgLitArg lit
+ _ -> pprPanic "coreToStgArgs" (ppr arg)
+ in
+ returnLne (stg_arg : stg_args, fvs)
+
+
+-- ---------------------------------------------------------------------------
+-- The magic for lets:
+-- ---------------------------------------------------------------------------
+
+coreToStgLet
+ :: Bool -- True <=> yes, we are let-no-escaping this let
+ -> CoreBind -- bindings
+ -> CoreExpr -- body
+ -> LneM (StgExpr, -- new let
+ FreeVarsInfo, -- variables free in the whole let
+ EscVarsSet, -- variables that escape from the whole let
+ Bool) -- True <=> none of the binders in the bindings
+ -- is among the escaping vars
+
+coreToStgLet let_no_escape bind body
+ = fixLne (\ ~(_, _, _, _, _, _, rec_body_fvs, _, _) ->
+
+ -- Do the bindings, setting live_in_cont to empty if
+ -- we ain't in a let-no-escape world
+ getVarsLiveInCont `thenLne` \ live_in_cont ->
+ setVarsLiveInCont (if let_no_escape
+ then live_in_cont
+ else emptyLVS)
+ (vars_bind rec_body_fvs bind)
+ `thenLne` \ ( bind2, bind_fvs, bind_escs
+ , bind_lvs, bind_cafs, env_ext) ->
+
+ -- Do the body
+ extendVarEnvLne env_ext (
+ coreToStgExpr body `thenLne` \(body2, body_fvs, body_escs) ->
+ freeVarsToLiveVars body_fvs `thenLne` \(body_lvs, _) ->
+
+ returnLne (bind2, bind_fvs, bind_escs, bind_lvs, bind_cafs,
+ body2, body_fvs, body_escs, body_lvs)
+ )
+
+ ) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs, bind_cafs,
+ body2, body_fvs, body_escs, body_lvs) ->
+
+
+ -- Compute the new let-expression
+ let
+ new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
+ | otherwise = StgLet bind2 body2
+
+ free_in_whole_let
+ = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
+
+ live_in_whole_let
+ = bind_lvs `unionVarSet` (body_lvs `minusVarSet` set_of_binders)
+
+ real_bind_escs = if let_no_escape then
+ bind_escs
+ else
+ getFVSet bind_fvs
+ -- Everything escapes which is free in the bindings
+
+ let_escs = (real_bind_escs `unionVarSet` body_escs) `minusVarSet` set_of_binders
+
+ all_escs = bind_escs `unionVarSet` body_escs -- Still includes binders of
+ -- this let(rec)
+
+ no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
+
+#ifdef DEBUG
+ -- Debugging code as requested by Andrew Kennedy
+ checked_no_binder_escapes
+ | not no_binder_escapes && any is_join_var binders
+ = pprTrace "Interesting! A join var that isn't let-no-escaped" (ppr binders)
+ False
+ | otherwise = no_binder_escapes
+#else
+ checked_no_binder_escapes = no_binder_escapes
+#endif
+
+ -- Mustn't depend on the passed-in let_no_escape flag, since
+ -- no_binder_escapes is used by the caller to derive the flag!
+ in
+ returnLne (
+ new_let,
+ free_in_whole_let,
+ let_escs,
+ checked_no_binder_escapes
+ ))
+ where
+ set_of_binders = mkVarSet binders
+ binders = case bind of
+ NonRec binder rhs -> [binder]
+ Rec pairs -> map fst pairs
+
+ mk_binding bind_lvs bind_cafs binder rhs
+ = (binder, LetBound NotTopLevelBound -- Not top level
+ live_vars (predictArity rhs)
+ )
+ where
+ live_vars = if let_no_escape then
+ (extendVarSet bind_lvs binder, bind_cafs)
+ else
+ (unitVarSet binder, emptyVarSet)
+
+ vars_bind :: FreeVarsInfo -- Free var info for body of binding
+ -> CoreBind
+ -> LneM (StgBinding,
+ FreeVarsInfo,
+ EscVarsSet, -- free vars; escapee vars
+ StgLiveVars, -- vars live in binding
+ IdSet, -- CAFs live in binding
+ [(Id, HowBound)]) -- extension to environment
+
+
+ vars_bind body_fvs (NonRec binder rhs)
+ = coreToStgRhs body_fvs NotTopLevel (binder,rhs)
+ `thenLne` \ (rhs2, bind_fvs, escs) ->
+
+ freeVarsToLiveVars bind_fvs `thenLne` \ (bind_lvs, bind_cafs) ->
+ let
+ env_ext_item = mk_binding bind_lvs bind_cafs binder rhs
+ in
+ returnLne (StgNonRec (SRTEntries bind_cafs) binder rhs2,
+ bind_fvs, escs, bind_lvs, bind_cafs, [env_ext_item])
+
+
+ vars_bind body_fvs (Rec pairs)
+ = fixLne (\ ~(_, rec_rhs_fvs, _, bind_lvs, bind_cafs, _) ->
+ let
+ rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
+ binders = map fst pairs
+ env_ext = [ mk_binding bind_lvs bind_cafs b rhs
+ | (b,rhs) <- pairs ]
+ in
+ extendVarEnvLne env_ext (
+ mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs NotTopLevel) pairs
+ `thenLne` \ (rhss2, fvss, escss) ->
+ let
+ bind_fvs = unionFVInfos fvss
+ escs = unionVarSets escss
+ in
+ freeVarsToLiveVars (binders `minusFVBinders` bind_fvs)
+ `thenLne` \ (bind_lvs, bind_cafs) ->
+
+ returnLne (StgRec (SRTEntries bind_cafs) (binders `zip` rhss2),
+ bind_fvs, escs, bind_lvs, bind_cafs, env_ext)
+ )
+ )
+
+is_join_var :: Id -> Bool
+-- A hack (used only for compiler debuggging) to tell if
+-- a variable started life as a join point ($j)
+is_join_var j = occNameUserString (getOccName j) == "$j"
\end{code}
%************************************************************************
%* *
-\subsubsection[coreToStg-type-stuff]{Type application and abstraction}
+\subsection{Arity prediction}
%* *
%************************************************************************
-This type information dies in this Core-to-STG translation.
+To avoid yet another knot, we predict the arity of each function from
+its Core form, based on the number of visible top-level lambdas.
+It should be the same as the arity of the STG RHS!
\begin{code}
-coreExprToStg env (CoTyLam tyvar expr) = coreExprToStg env expr
-coreExprToStg env (CoTyApp expr ty) = coreExprToStg env expr
+predictArity :: CoreExpr -> Int
+predictArity (Lam x e)
+ | isTyVar x = predictArity e
+ | otherwise = 1 + predictArity e
+predictArity (Note _ e)
+ -- Ignore coercions. Top level sccs are removed by the final
+ -- profiling pass, so we ignore those too.
+ = predictArity e
+predictArity _ = 0
\end{code}
+
%************************************************************************
%* *
-\subsubsection[coreToStg-lambdas]{Lambda abstractions}
+\subsection[LNE-monad]{A little monad for this let-no-escaping pass}
%* *
%************************************************************************
+There's a lot of stuff to pass around, so we use this @LneM@ monad to
+help. All the stuff here is only passed *down*.
+
\begin{code}
-coreExprToStg env expr@(CoLam binders body)
- = coreExprToStg env body `thenSUs` \ (stg_body, binds) ->
- newStgVar (typeOfCoreExpr expr) `thenSUs` \ var ->
- returnSUs (StgLet (StgNonRec var (StgRhsClosure noCostCentre
- stgArgOcc
- bOGUS_FVs
- ReEntrant -- binders is non-empty
- binders
- stg_body))
- (StgApp (StgVarAtom var) [] bOGUS_LVs),
- binds)
+type LneM a = IdEnv HowBound
+ -> (StgLiveVars, -- vars live in continuation
+ IdSet) -- cafs live in continuation
+ -> a
+
+data HowBound
+ = ImportBound
+ | CaseBound
+ | LambdaBound
+ | LetBound
+ TopLevelCafInfo
+ (StgLiveVars, IdSet) -- (Live vars, Live CAFs)... see notes below
+ Arity -- its arity (local Ids don't have arity info at this point)
+
+isLetBound (LetBound _ _ _) = True
+isLetBound other = False
\end{code}
-%************************************************************************
-%* *
-\subsubsection[coreToStg-applications]{Applications}
-%* *
-%************************************************************************
+For a let(rec)-bound variable, x, we record StgLiveVars, the set of
+variables that are live if x is live. For "normal" variables that is
+just x alone. If x is a let-no-escaped variable then x is represented
+by a code pointer and a stack pointer (well, one for each stack). So
+all of the variables needed in the execution of x are live if x is,
+and are therefore recorded in the LetBound constructor; x itself
+*is* included.
+
+The set of live variables is guaranteed ot have no further let-no-escaped
+variables in it.
+The std monad functions:
\begin{code}
-coreExprToStg env expr@(CoApp _ _)
- = -- Deal with the arguments
- mapAndUnzipSUs (coreAtomToStg env) args `thenSUs` \ (stg_args, arg_binds) ->
-
- -- Now deal with the function
- case fun of
- CoVar fun_id -> returnSUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs,
- unionManyBags arg_binds)
-
- other -> -- A non-variable applied to things; better let-bind it.
- newStgVar (typeOfCoreExpr fun) `thenSUs` \ fun_id ->
- coreExprToStg env fun `thenSUs` \ (stg_fun, fun_binds) ->
- let
- fun_rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
- stgArgOcc
- bOGUS_FVs
- SingleEntry -- Only entered once
- []
- stg_fun
- in
- returnSUs (StgLet (StgNonRec fun_id fun_rhs)
- (StgApp (StgVarAtom fun_id) stg_args bOGUS_LVs),
- unionManyBags arg_binds `unionBags`
- fun_binds)
- where
- (fun,args) = collect_args expr []
+initLne :: IdEnv HowBound -> LneM a -> a
+initLne env m = m env emptyLVS
- -- Collect arguments, discarding type applications
- collect_args (CoApp fun arg) args = collect_args fun (arg:args)
- collect_args (CoTyApp e t) args = collect_args e args
- collect_args fun args = (fun, args)
-\end{code}
+emptyLVS = (emptyVarSet,emptyVarSet)
-%************************************************************************
-%* *
-\subsubsection[coreToStg-cases]{Case expressions}
-%* *
-%************************************************************************
+{-# INLINE thenLne #-}
+{-# INLINE returnLne #-}
-At this point, we *mangle* cases involving fork# and par# in the
-discriminant. The original templates for these primops (see
-@PrelVals.lhs@) constructed case expressions with boolean results
-solely to fool the strictness analyzer, the simplifier, and anyone
-else who might want to fool with the evaluation order. Now, we
-believe that once the translation to STG code is performed, our
-evaluation order is safe. Therefore, we convert expressions of the
-form:
+returnLne :: a -> LneM a
+returnLne e env lvs_cont = e
- case par# e of
- True -> rhs
- False -> parError#
+thenLne :: LneM a -> (a -> LneM b) -> LneM b
+thenLne m k env lvs_cont
+ = k (m env lvs_cont) env lvs_cont
-to
+mapLne :: (a -> LneM b) -> [a] -> LneM [b]
+mapLne f [] = returnLne []
+mapLne f (x:xs)
+ = f x `thenLne` \ r ->
+ mapLne f xs `thenLne` \ rs ->
+ returnLne (r:rs)
- case par# e of
- _ -> rhs
+mapAndUnzipLne :: (a -> LneM (b,c)) -> [a] -> LneM ([b],[c])
-\begin{code}
+mapAndUnzipLne f [] = returnLne ([],[])
+mapAndUnzipLne f (x:xs)
+ = f x `thenLne` \ (r1, r2) ->
+ mapAndUnzipLne f xs `thenLne` \ (rs1, rs2) ->
+ returnLne (r1:rs1, r2:rs2)
-coreExprToStg env (CoCase discrim@(CoPrim op tys args) alts)
- | funnyParallelOp op =
- getSUnique `thenSUs` \ uniq ->
- coreExprToStg env discrim `thenSUs` \ (stg_discrim, discrim_binds) ->
- alts_to_stg alts `thenSUs` \ (stg_alts, alts_binds) ->
- returnSUs (
- StgCase stg_discrim
- bOGUS_LVs
- bOGUS_LVs
- uniq
- stg_alts,
- discrim_binds `unionBags` alts_binds
- )
- where
- funnyParallelOp SeqOp = True
- funnyParallelOp ParOp = True
- funnyParallelOp ForkOp = True
- funnyParallelOp _ = False
-
- discrim_ty = typeOfCoreExpr discrim
-
- alts_to_stg (CoPrimAlts _ (CoBindDefault binder rhs))
- = coreExprToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) ->
- let
- stg_deflt = StgBindDefault binder False stg_rhs
- in
- returnSUs (StgPrimAlts discrim_ty [] stg_deflt, rhs_binds)
-
--- OK, back to real life...
-
-coreExprToStg env (CoCase discrim alts)
- = coreExprToStg env discrim `thenSUs` \ (stg_discrim, discrim_binds) ->
- alts_to_stg discrim alts `thenSUs` \ (stg_alts, alts_binds) ->
- getSUnique `thenSUs` \ uniq ->
- returnSUs (
- StgCase stg_discrim
- bOGUS_LVs
- bOGUS_LVs
- uniq
- stg_alts,
- discrim_binds `unionBags` alts_binds
- )
+mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d])
+
+mapAndUnzip3Lne f [] = returnLne ([],[],[])
+mapAndUnzip3Lne f (x:xs)
+ = f x `thenLne` \ (r1, r2, r3) ->
+ mapAndUnzip3Lne f xs `thenLne` \ (rs1, rs2, rs3) ->
+ returnLne (r1:rs1, r2:rs2, r3:rs3)
+
+fixLne :: (a -> LneM a) -> LneM a
+fixLne expr env lvs_cont
+ = result
where
- discrim_ty = typeOfCoreExpr discrim
- (_, discrim_ty_args, _) = getUniDataTyCon discrim_ty
-
- alts_to_stg discrim (CoAlgAlts alts deflt)
- = default_to_stg discrim deflt `thenSUs` \ (stg_deflt, deflt_binds) ->
- mapAndUnzipSUs boxed_alt_to_stg alts `thenSUs` \ (stg_alts, alts_binds) ->
- returnSUs (StgAlgAlts discrim_ty stg_alts stg_deflt,
- deflt_binds `unionBags` unionManyBags alts_binds)
- where
- boxed_alt_to_stg (con, bs, rhs)
- = coreExprToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) ->
- returnSUs ((spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs),
- rhs_binds)
- where
- spec_con = mkSpecialisedCon con discrim_ty_args
-
- alts_to_stg discrim (CoPrimAlts alts deflt)
- = default_to_stg discrim deflt `thenSUs` \ (stg_deflt,deflt_binds) ->
- mapAndUnzipSUs unboxed_alt_to_stg alts `thenSUs` \ (stg_alts, alts_binds) ->
- returnSUs (StgPrimAlts discrim_ty stg_alts stg_deflt,
- deflt_binds `unionBags` unionManyBags alts_binds)
- where
- unboxed_alt_to_stg (lit, rhs)
- = coreExprToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) ->
- returnSUs ((lit, stg_rhs), rhs_binds)
-
-#ifdef DPH
- alts_to_stg (CoParAlgAlts tycon ctxt params alts deflt)
- = default_to_stg deflt `thenSUs` \ stg_deflt ->
- mapSUs boxed_alt_to_stg alts `thenSUs` \ stg_alts ->
- returnSUs (StgParAlgAlts discrim_ty ctxt params stg_alts stg_deflt)
- where
- boxed_alt_to_stg (con, rhs)
- = coreExprToStg env rhs `thenSUs` \ stg_rhs ->
- returnSUs (con, stg_rhs)
-
- alts_to_stg (CoParPrimAlts tycon ctxt alts deflt)
- = default_to_stg deflt `thenSUs` \ stg_deflt ->
- mapSUs unboxed_alt_to_stg alts `thenSUs` \ stg_alts ->
- returnSUs (StgParPrimAlts discrim_ty ctxt stg_alts stg_deflt)
- where
- unboxed_alt_to_stg (lit, rhs)
- = coreExprToStg env rhs `thenSUs` \ stg_rhs ->
- returnSUs (lit, stg_rhs)
-#endif {- Data Parallel Haskell -}
-
- default_to_stg discrim CoNoDefault
- = returnSUs (StgNoDefault, emptyBag)
-
- default_to_stg discrim (CoBindDefault binder rhs)
- = coreExprToStg new_env rhs `thenSUs` \ (stg_rhs, rhs_binds) ->
- returnSUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs,
- rhs_binds)
- where
+ result = expr result env lvs_cont
+\end{code}
+Functions specific to this monad:
- -- We convert case x of {...; x' -> ...x'...}
- -- to
- -- case x of {...; _ -> ...x... }
- --
- -- See notes in SimplCase.lhs, near simplDefault for the reasoning.
- -- It's quite easily done: simply extend the environment to bind the
- -- default binder to the scrutinee.
- --
- new_env = case discrim of
- CoVar v -> addOneToIdEnv env binder (StgVarAtom v)
- other -> env
+\begin{code}
+getVarsLiveInCont :: LneM (StgLiveVars, IdSet)
+getVarsLiveInCont env lvs_cont = lvs_cont
+
+setVarsLiveInCont :: (StgLiveVars,IdSet) -> LneM a -> LneM a
+setVarsLiveInCont new_lvs_cont expr env lvs_cont
+ = expr env new_lvs_cont
+
+extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
+extendVarEnvLne ids_w_howbound expr env lvs_cont
+ = expr (extendVarEnvList env ids_w_howbound) lvs_cont
+
+lookupVarLne :: Id -> LneM HowBound
+lookupVarLne v env lvs_cont
+ = returnLne (
+ case (lookupVarEnv env v) of
+ Just xx -> xx
+ Nothing -> ImportBound
+ ) env lvs_cont
+
+-- The result of lookupLiveVarsForSet, a set of live variables, is
+-- only ever tacked onto a decorated expression. It is never used as
+-- the basis of a control decision, which might give a black hole.
+
+freeVarsToLiveVars :: FreeVarsInfo -> LneM (StgLiveVars, IdSet)
+freeVarsToLiveVars fvs env live_in_cont
+ = returnLne (lvs, cafs) env live_in_cont
+ where
+ (lvs_cont, cafs_cont) = live_in_cont -- not a strict pattern match!
+ (local, global) = partition isLocalId (allFreeIds fvs)
+
+ (lvs_from_fvs, caf_extras) = unzip (map do_one local)
+
+ lvs = unionVarSets lvs_from_fvs
+ `unionVarSet` lvs_cont
+
+ cafs = mkVarSet (filter is_caf_one global)
+ `unionVarSet` (unionVarSets caf_extras)
+ `unionVarSet` cafs_cont
+
+ do_one v
+ = case (lookupVarEnv env v) of
+ Just (LetBound _ (lvs,cafs) _) -> (extendVarSet lvs v, cafs)
+ Just _ -> (unitVarSet v, emptyVarSet)
+ Nothing -> pprPanic "lookupLiveVarsForSet/do_one:" (ppr v)
+
+ is_caf_one v
+ = case lookupVarEnv env v of
+ Just (LetBound TopLevelHasCafs (lvs,_) _) ->
+ ASSERT( isEmptyVarSet lvs ) True
+ Just (LetBound _ _ _) -> False
+ _otherwise -> mayHaveCafRefs (idCafInfo v)
\end{code}
%************************************************************************
%* *
-\subsubsection[coreToStg-let(rec)]{Let and letrec expressions}
+\subsection[Free-var info]{Free variable information}
%* *
%************************************************************************
\begin{code}
-coreExprToStg env (CoLet bind body)
- = coreBindToStg env bind `thenSUs` \ (stg_binds, new_env, float_binds1) ->
- coreExprToStg new_env body `thenSUs` \ (stg_body, float_binds2) ->
- returnSUs (mkStgLets stg_binds stg_body, float_binds1 `unionBags` float_binds2)
-\end{code}
+type FreeVarsInfo = VarEnv (Var, TopLevelCafInfo, StgBinderInfo)
+ -- If f is mapped to noBinderInfo, that means
+ -- that f *is* mentioned (else it wouldn't be in the
+ -- IdEnv at all), but perhaps in an unsaturated applications.
+ --
+ -- All case/lambda-bound things are also mapped to
+ -- noBinderInfo, since we aren't interested in their
+ -- occurence info.
+ --
+ -- For ILX we track free var info for type variables too;
+ -- hence VarEnv not IdEnv
+data TopLevelCafInfo
+ = NotTopLevelBound
+ | TopLevelNoCafs
+ | TopLevelHasCafs
+ deriving Eq
-%************************************************************************
-%* *
-\subsubsection[coreToStg-scc]{SCC expressions}
-%* *
-%************************************************************************
+type EscVarsSet = IdSet
+\end{code}
-Covert core @scc@ expression directly to STG @scc@ expression.
\begin{code}
-coreExprToStg env (CoSCC cc expr)
- = coreExprToStg env expr `thenSUs` \ (stg_expr, binds) ->
- returnSUs (StgSCC (typeOfCoreExpr expr) cc stg_expr, binds)
+emptyFVInfo :: FreeVarsInfo
+emptyFVInfo = emptyVarEnv
+
+singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
+singletonFVInfo id ImportBound info
+ | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, TopLevelHasCafs, info)
+ | otherwise = emptyVarEnv
+singletonFVInfo id (LetBound top_level _ _) info
+ = unitVarEnv id (id, top_level, info)
+singletonFVInfo id other info
+ = unitVarEnv id (id, NotTopLevelBound, info)
+
+tyvarFVInfo :: TyVarSet -> FreeVarsInfo
+tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs
+ where
+ add tv fvs = extendVarEnv fvs tv (tv, NotTopLevelBound, noBinderInfo)
+
+unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
+unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
+
+unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
+unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
+
+minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo
+minusFVBinders vs fv = foldr minusFVBinder fv vs
+
+minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
+minusFVBinder v fv | isId v && opt_RuntimeTypes
+ = (fv `delVarEnv` v) `unionFVInfo`
+ tyvarFVInfo (tyVarsOfType (idType v))
+ | otherwise = fv `delVarEnv` v
+ -- When removing a binder, remember to add its type variables
+ -- c.f. CoreFVs.delBinderFV
+
+elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
+elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
+
+lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
+-- Find how the given Id is used.
+-- Externally visible things may be used any old how
+lookupFVInfo fvs id
+ | isExternallyVisibleName (idName id) = noBinderInfo
+ | otherwise = case lookupVarEnv fvs id of
+ Nothing -> noBinderInfo
+ Just (_,_,info) -> info
+
+allFreeIds :: FreeVarsInfo -> [Id] -- Non-top-level things only
+allFreeIds fvs = [id | (id,_,_) <- rngVarEnv fvs, isId id]
+
+-- Non-top-level things only, both type variables and ids (type variables
+-- only if opt_RuntimeTypes.
+getFVs :: FreeVarsInfo -> [Var]
+getFVs fvs = [id | (id,NotTopLevelBound,_) <- rngVarEnv fvs]
+
+getFVSet :: FreeVarsInfo -> VarSet
+getFVSet fvs = mkVarSet (getFVs fvs)
+
+plusFVInfo (id1,top1,info1) (id2,top2,info2)
+ = ASSERT (id1 == id2 && top1 == top2)
+ (id1, top1, combineStgBinderInfo info1 info2)
\end{code}
-%************************************************************************
-%* *
-\subsubsection[coreToStg-dataParallel]{Data Parallel expressions}
-%* *
-%************************************************************************
+Misc.
\begin{code}
-#ifdef DPH
-coreExprToStg env (_, AnnCoParCon con ctxt types args)
- = mapAndUnzipSUs (arg2stg env) args `thenSUs` \ (stg_atoms, stg_binds) ->
- returnSUs (mkStgLets (catMaybes stg_binds)
- (StgParConApp con ctxt stg_atoms bOGUS_LVs))
-
-coreExprToStg env (_,AnnCoParComm ctxt expr comm)
- = coreExprToStg env expr `thenSUs` \ stg_expr ->
- annComm_to_stg comm `thenSUs` \ (stg_comm,stg_binds) ->
- returnSUs (mkStgLets (catMaybes stg_binds)
- (StgParComm ctxt stg_expr stg_comm))
- ))
- where
- annComm_to_stg (AnnCoParSend args)
- = mapAndUnzipSUs (arg2stg env) args `thenSUs` \ (stg_atoms, stg_binds) ->
- returnSUs (StgParSend stg_atoms,stg_binds)
-
- annComm_to_stg (AnnCoParFetch args)
- = mapAndUnzipSUs (arg2stg env) args `thenSUs` \ (stg_atoms, stg_binds) ->
- returnSUs (StgParFetch stg_atoms,stg_binds)
-
- annComm_to_stg (AnnCoToPodized)
- = returnSUs (StgToPodized,[])
- annComm_to_stg (AnnCoFromPodized)
- = returnSUs (StgFromPodized,[])
-#endif {- Data Parallel Haskell -}
+filterStgBinders :: [Var] -> [Var]
+filterStgBinders bndrs
+ | opt_RuntimeTypes = bndrs
+ | otherwise = filter isId bndrs
\end{code}
+
\begin{code}
-coreExprToStg env other = panic "coreExprToStg: it really failed here"
+ -- Ignore all notes except SCC
+myCollectBinders expr
+ = go [] expr
+ where
+ go bs (Lam b e) = go (b:bs) e
+ go bs e@(Note (SCC _) _) = (reverse bs, e)
+ go bs (Note _ e) = go bs e
+ go bs e = (reverse bs, e)
+
+myCollectArgs :: CoreExpr -> (Id, [CoreArg])
+ -- We assume that we only have variables
+ -- in the function position by now
+myCollectArgs expr
+ = go expr []
+ where
+ go (Var v) as = (v, as)
+ go (App f a) as = go f (a:as)
+ go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
+ go (Note n e) as = go e as
+ go _ as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
\end{code}
%************************************************************************
%* *
-\subsection[coreToStg-misc]{Miscellaneous helping functions}
+\subsection{Figuring out CafInfo for an expression}
%* *
%************************************************************************
-Utilities.
+hasCafRefs decides whether a top-level closure can point into the dynamic heap.
+We mark such things as `MayHaveCafRefs' because this information is
+used to decide whether a particular closure needs to be referenced
+in an SRT or not.
-Invent a fresh @Id@:
-\begin{code}
-newStgVar :: UniType -> SUniqSM Id
-newStgVar ty
- = getSUnique `thenSUs` \ uniq ->
- returnSUs (mkSysLocal SLIT("stg") uniq ty mkUnknownSrcLoc)
-\end{code}
+There are two reasons for setting MayHaveCafRefs:
+ a) The RHS is a CAF: a top-level updatable thunk.
+ b) The RHS refers to something that MayHaveCafRefs
-\begin{code}
-mkStgLets :: [PlainStgBinding]
- -> PlainStgExpr -- body of let
- -> PlainStgExpr
+Possible improvement: In an effort to keep the number of CAFs (and
+hence the size of the SRTs) down, we could also look at the expression and
+decide whether it requires a small bounded amount of heap, so we can ignore
+it as a CAF. In these cases however, we would need to use an additional
+CAF list to keep track of non-collectable CAFs.
-mkStgLets binds body = foldr StgLet body binds
+\begin{code}
+hasCafRefs :: IdEnv HowBound -> CoreExpr -> CafInfo
+-- Only called for the RHS of top-level lets
+hasCafRefss :: IdEnv HowBound -> [CoreExpr] -> CafInfo
+ -- predicate returns True for a given Id if we look at this Id when
+ -- calculating the result. Used to *avoid* looking at the CafInfo
+ -- field for an Id that is part of the current recursive group.
+
+hasCafRefs p expr
+ | isCAF expr || isFastTrue (cafRefs p expr) = MayHaveCafRefs
+ | otherwise = NoCafRefs
+
+ -- used for recursive groups. The whole group is set to
+ -- "MayHaveCafRefs" if at least one of the group is a CAF or
+ -- refers to any CAFs.
+hasCafRefss p exprs
+ | any isCAF exprs || isFastTrue (cafRefss p exprs) = MayHaveCafRefs
+ | otherwise = NoCafRefs
+
+-- cafRefs compiles to beautiful code :)
+
+cafRefs p (Var id)
+ | isLocalId id = fastBool False
+ | otherwise =
+ case lookupVarEnv p id of
+ Just (LetBound TopLevelHasCafs _ _) -> fastBool True
+ Just (LetBound _ _ _) -> fastBool False
+ Nothing -> fastBool (cgMayHaveCafRefs (idCgInfo id)) -- imported Ids
+
+cafRefs p (Lit l) = fastBool False
+cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a
+cafRefs p (Lam x e) = cafRefs p e
+cafRefs p (Let b e) = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e
+cafRefs p (Case e bndr alts) = fastOr (cafRefs p e)
+ (cafRefss p) (rhssOfAlts alts)
+cafRefs p (Note n e) = cafRefs p e
+cafRefs p (Type t) = fastBool False
+
+cafRefss p [] = fastBool False
+cafRefss p (e:es) = fastOr (cafRefs p e) (cafRefss p) es
+
+-- hack for lazy-or over FastBool.
+fastOr a f x = fastBool (isFastTrue a || isFastTrue (f x))
+
+isCAF :: CoreExpr -> Bool
+-- Only called for the RHS of top-level lets
+isCAF e = not (rhsIsNonUpd e)
+ {- ToDo: check type for onceness, i.e. non-updatable thunks? -}
+
+
+rhsIsNonUpd :: CoreExpr -> Bool
+ -- True => Value-lambda, constructor, PAP
+ -- This is a bit like CoreUtils.exprIsValue, with the following differences:
+ -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
+ --
+ -- b) (C x xs), where C is a contructors is updatable if the application is
+ -- dynamic: see isDynConApp
+ --
+ -- c) don't look through unfolding of f in (f x). I'm suspicious of this one
+
+-- This function has to line up with what the update flag
+-- for the StgRhs gets set to in mkStgRhs (above)
+--
+-- When opt_RuntimeTypes is on, we keep type lambdas and treat
+-- them as making the RHS re-entrant (non-updatable).
+rhsIsNonUpd (Lam b e) = isRuntimeVar b || rhsIsNonUpd e
+rhsIsNonUpd (Note (SCC _) e) = False
+rhsIsNonUpd (Note _ e) = rhsIsNonUpd e
+rhsIsNonUpd other_expr
+ = go other_expr 0 []
+ where
+ go (Var f) n_args args = idAppIsNonUpd f n_args args
+
+ go (App f a) n_args args
+ | isTypeArg a = go f n_args args
+ | otherwise = go f (n_args + 1) (a:args)
+
+ go (Note (SCC _) f) n_args args = False
+ go (Note _ f) n_args args = go f n_args args
+
+ go other n_args args = False
+
+idAppIsNonUpd :: Id -> Int -> [CoreExpr] -> Bool
+idAppIsNonUpd id n_val_args args
+ | Just con <- isDataConId_maybe id = not (isCrossDllConApp con args)
+ | otherwise = n_val_args < idArity id
+
+isCrossDllConApp :: DataCon -> [CoreExpr] -> Bool
+isCrossDllConApp con args = isDllName (dataConName con) || any isCrossDllArg args
+-- Top-level constructor applications can usually be allocated
+-- statically, but they can't if
+-- a) the constructor, or any of the arguments, come from another DLL
+-- b) any of the arguments are LitLits
+-- (because we can't refer to static labels in other DLLs).
+-- If this happens we simply make the RHS into an updatable thunk,
+-- and 'exectute' it rather than allocating it statically.
+-- All this should match the decision in (see CoreToStg.coreToStgRhs)
+
+
+isCrossDllArg :: CoreExpr -> Bool
+-- True if somewhere in the expression there's a cross-DLL reference
+isCrossDllArg (Type _) = False
+isCrossDllArg (Var v) = isDllName (idName v)
+isCrossDllArg (Note _ e) = isCrossDllArg e
+isCrossDllArg (Lit lit) = isLitLitLit lit
+isCrossDllArg (App e1 e2) = isCrossDllArg e1 || isCrossDllArg e2 -- must be a type app
+isCrossDllArg (Lam v e) = isCrossDllArg e -- must be a type lam
\end{code}