| codeStyle sty = ppr (moduleName mod) <> char '_' <> pprOccName occ
| debugStyle sty = ppr (moduleName mod) <> dot <> pprOccName occ <>
- text "{-" <> pprUnique10 uniq <> text "-}"
+ text "{-" <> pprUnique uniq <> text "-}"
| unqualStyle sty name = pprOccName occ
| otherwise = ppr (moduleName mod) <> dot <> pprOccName occ
import Subst ( mkTyVarSubst, substTy )
import Name ( getSrcLoc )
import PprCore
-import ErrUtils ( doIfSet, dumpIfSet, ghcExit, Message, showPass,
+import ErrUtils ( doIfSet, dumpIfSet_core, ghcExit, Message, showPass,
ErrMsg, addErrLocHdrLine, pprBagOfErrors,
WarnMsg, pprBagOfWarnings)
import SrcLoc ( SrcLoc, noSrcLoc )
and do Core Lint when necessary.
\begin{code}
-endPass :: DynFlags -> String -> Bool -> [CoreBind] -> IO [CoreBind]
+endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
endPass dflags pass_name dump_flag binds
= do
(binds, _) <- endPassWithRules dflags pass_name dump_flag binds Nothing
return binds
-endPassWithRules :: DynFlags -> String -> Bool -> [CoreBind] -> Maybe RuleBase
+endPassWithRules :: DynFlags -> String -> DynFlag -> [CoreBind]
+ -> Maybe RuleBase
-> IO ([CoreBind], Maybe RuleBase)
endPassWithRules dflags pass_name dump_flag binds rules
= do
return ()
-- Report verbosely, if required
- dumpIfSet dump_flag pass_name
+ dumpIfSet_core dflags dump_flag pass_name
(pprCoreBindings binds $$ case rules of
Nothing -> empty
Just rb -> pprRuleBase rb)
--- /dev/null
+%
+% (c) The University of Glasgow, 1994-2000
+%
+\section{Core pass to saturate constructors and PrimOps}
+
+\begin{code}
+module CoreSat (
+ coreSatPgm, coreSatExpr
+ ) where
+
+#include "HsVersions.h"
+
+import CoreUtils
+import CoreFVs
+import CoreLint
+import CoreSyn
+import Type
+import Demand
+import Var ( TyVar, setTyVarUnique )
+import VarSet
+import PrimOp
+import IdInfo
+import Id
+import UniqSupply
+import Maybes
+import ErrUtils
+import CmdLineOpts
+import Outputable
+\end{code}
+
+-----------------------------------------------------------------------------
+Overview
+-----------------------------------------------------------------------------
+
+Most of the contents of this pass used to be in CoreToStg. The
+primary goals here are:
+
+1. Get the program into "A-normal form". In particular:
+
+ f E ==> let x = E in f x
+ OR ==> case E of x -> f x
+
+
+ if E is a non-trivial expression.
+ Which transformation is used depends on whether f is strict or not.
+ [Previously the transformation to case used to be done by the
+ simplifier, but it's better done here. It does mean that f needs
+ to have its strictness info correct!.]
+
+2. Similarly, convert any unboxed let's into cases.
+ [I'm experimenting with leaving 'ok-for-speculation' rhss in let-form
+ right up to this point.]
+
+ This is all done modulo type applications and abstractions, so that
+ when type erasure is done for conversion to STG, we don't end up with
+ any trivial or useless bindings.
+
+3. Ensure that lambdas only occur as the RHS of a binding
+ (The code generator can't deal with anything else.)
+
+4. Saturate constructor and primop applications.
+
+
+
+-- -----------------------------------------------------------------------------
+-- Top level stuff
+-- -----------------------------------------------------------------------------
+
+\begin{code}
+coreSatPgm :: DynFlags -> [CoreBind] -> IO [CoreBind]
+coreSatPgm dflags binds
+ = do showPass dflags "CoreSat"
+ us <- mkSplitUniqSupply 's'
+ let new_binds = initUs_ us (coreSatBinds binds)
+ endPass dflags "CoreSat" Opt_D_dump_sat new_binds
+
+coreSatExpr :: DynFlags -> CoreExpr -> IO CoreExpr
+coreSatExpr dflags expr
+ = do showPass dflags "CoreSat"
+ us <- mkSplitUniqSupply 's'
+ let new_expr = initUs_ us (coreSatAnExpr expr)
+ dumpIfSet_dyn dflags Opt_D_dump_sat "Saturated/Normal form syntax:"
+ (ppr new_expr)
+ return new_expr
+
+-- ---------------------------------------------------------------------------
+-- Dealing with bindings
+-- ---------------------------------------------------------------------------
+
+data FloatingBind
+ = RecF [(Id, CoreExpr)]
+ | NonRecF Id
+ CoreExpr -- *Can* be a Lam
+ RhsDemand
+ [FloatingBind]
+
+coreSatBinds :: [CoreBind] -> UniqSM [CoreBind]
+coreSatBinds [] = returnUs []
+coreSatBinds (b:bs)
+ = coreSatBind b `thenUs` \ float ->
+ coreSatBinds bs `thenUs` \ new_bs ->
+ case float of
+ NonRecF bndr rhs dem floats
+ -> ASSERT2( not (isStrictDem dem) &&
+ not (isUnLiftedType (idType bndr)),
+ ppr b ) -- No top-level cases!
+
+ mkBinds floats rhs `thenUs` \ new_rhs ->
+ returnUs (NonRec bndr new_rhs : new_bs)
+ -- Keep all the floats inside...
+ -- Some might be cases etc
+ -- We might want to revisit this decision
+
+ RecF prs -> returnUs (Rec prs : new_bs)
+
+coreSatBind :: CoreBind -> UniqSM FloatingBind
+coreSatBind (NonRec binder rhs)
+ = coreSatExprFloat rhs `thenUs` \ (floats, new_rhs) ->
+ returnUs (NonRecF binder new_rhs (bdrDem binder) floats)
+coreSatBind (Rec pairs)
+ = mapUs do_rhs pairs `thenUs` \ new_rhss ->
+ returnUs (RecF (binders `zip` new_rhss))
+ where
+ binders = map fst pairs
+ do_rhs (bndr,rhs) =
+ coreSatExprFloat rhs `thenUs` \ (floats, new_rhs) ->
+ mkBinds floats new_rhs `thenUs` \ new_rhs' ->
+ -- NB: new_rhs' might still be a Lam (and we want that)
+ returnUs new_rhs'
+
+-- ---------------------------------------------------------------------------
+-- Making arguments atomic (function args & constructor args)
+-- ---------------------------------------------------------------------------
+
+-- This is where we arrange that a non-trivial argument is let-bound
+coreSatArg :: CoreArg -> RhsDemand -> UniqSM ([FloatingBind], CoreArg)
+coreSatArg arg dem
+ = coreSatExprFloat arg `thenUs` \ (floats, arg') ->
+ if exprIsTrivial arg'
+ then returnUs (floats, arg')
+ else newVar (exprType arg') `thenUs` \ v ->
+ returnUs ([NonRecF v arg' dem floats], Var v)
+
+-- ---------------------------------------------------------------------------
+-- Dealing with expressions
+-- ---------------------------------------------------------------------------
+
+coreSatAnExpr :: CoreExpr -> UniqSM CoreExpr
+coreSatAnExpr expr
+ = coreSatExprFloat expr `thenUs` \ (floats, expr) ->
+ mkBinds floats expr
+
+
+coreSatExprFloat :: CoreExpr -> UniqSM ([FloatingBind], CoreExpr)
+-- If
+-- e ===> (bs, e')
+-- then
+-- e = let bs in e' (semantically, that is!)
+--
+-- For example
+-- f (g x) ===> ([v = g x], f v)
+
+coreSatExprFloat (Var v)
+ = maybeSaturate v (Var v) 0 (idType v) `thenUs` \ app ->
+ returnUs ([], app)
+
+coreSatExprFloat (Lit lit)
+ = returnUs ([], Lit lit)
+
+coreSatExprFloat (Let bind body)
+ = coreSatBind bind `thenUs` \ new_bind ->
+ coreSatExprFloat body `thenUs` \ (floats, new_body) ->
+ returnUs (new_bind:floats, new_body)
+
+coreSatExprFloat (Note other_note expr)
+ = coreSatExprFloat expr `thenUs` \ (floats, expr) ->
+ returnUs (floats, Note other_note expr)
+
+coreSatExprFloat expr@(Type _)
+ = returnUs ([], expr)
+
+coreSatExprFloat (Lam v e)
+ = coreSatAnExpr e `thenUs` \ e' ->
+ returnUs ([], Lam v e')
+
+coreSatExprFloat (Case scrut bndr alts)
+ = coreSatExprFloat scrut `thenUs` \ (floats, scrut) ->
+ mapUs sat_alt alts `thenUs` \ alts ->
+ mkCase scrut bndr alts `thenUs` \ expr ->
+ returnUs (floats, expr)
+ where
+ sat_alt (con, bs, rhs)
+ = coreSatAnExpr rhs `thenUs` \ rhs ->
+ deLam rhs `thenUs` \ rhs ->
+ returnUs (con, bs, rhs)
+
+coreSatExprFloat expr@(App _ _)
+ = collect_args expr 0 `thenUs` \ (app,(head,depth),ty,floats,ss) ->
+ ASSERT(null ss) -- make sure we used all the strictness info
+
+ -- Now deal with the function
+ case head of
+ Var fn_id
+ -> maybeSaturate fn_id app depth ty `thenUs` \ app' ->
+ returnUs (floats, app')
+ _other
+ -> returnUs (floats, app)
+
+ where
+
+ collect_args
+ :: CoreExpr
+ -> Int -- current app depth
+ -> UniqSM (CoreExpr, -- the rebuilt expression
+ (CoreExpr,Int), -- the head of the application,
+ -- and no. of args it was applied to
+ Type, -- type of the whole expr
+ [FloatingBind], -- any floats we pulled out
+ [Demand]) -- remaining argument demands
+
+ collect_args (App fun arg@(Type arg_ty)) depth
+ = collect_args fun depth `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
+ returnUs (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
+
+ collect_args (App fun arg) depth
+ = collect_args fun (depth+1) `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
+ let
+ (ss1, ss_rest) = case ss of
+ (ss1:ss_rest) -> (ss1, ss_rest)
+ [] -> (wwLazy, [])
+ (arg_ty, res_ty) = expectJust "coreSatExprFloat:collect_args" $
+ splitFunTy_maybe fun_ty
+ in
+ coreSatArg arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') ->
+ returnUs (App fun' arg', hd, res_ty, fs ++ floats, ss_rest)
+
+ collect_args (Var v) depth
+ = returnUs (Var v, (Var v, depth), idType v, [], stricts)
+ where
+ stricts = case idStrictness v of
+ StrictnessInfo demands _
+ | depth >= length demands -> demands
+ | otherwise -> []
+ other -> []
+ -- If depth < length demands, then we have too few args to
+ -- satisfy strictness info so we have to ignore all the
+ -- strictness info, e.g. + (error "urk")
+ -- Here, we can't evaluate the arg strictly, because this
+ -- partial application might be seq'd
+
+ collect_args (Note (Coerce ty1 ty2) fun) depth
+ = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
+ returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss)
+
+ collect_args (Note note fun) depth
+ | ignore_note note
+ = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
+ returnUs (Note note fun', hd, fun_ty, floats, ss)
+
+ -- non-variable fun, better let-bind it
+ collect_args fun depth
+ = newVar ty `thenUs` \ fn_id ->
+ coreSatExprFloat fun `thenUs` \ (fun_floats, fun) ->
+ returnUs (Var fn_id, (Var fn_id, depth), ty,
+ [NonRecF fn_id fun onceDem fun_floats], [])
+ where ty = exprType fun
+
+ ignore_note InlineCall = True
+ ignore_note InlineMe = True
+ ignore_note _other = False
+ -- we don't ignore SCCs, since they require some code generation
+
+------------------------------------------------------------------------------
+-- Generating new binders
+-- ---------------------------------------------------------------------------
+
+newVar :: Type -> UniqSM Id
+newVar ty
+ = getUniqueUs `thenUs` \ uniq ->
+ seqType ty `seq`
+ returnUs (mkSysLocal SLIT("sat") uniq ty)
+
+cloneTyVar :: TyVar -> UniqSM TyVar
+cloneTyVar tv
+ = getUniqueUs `thenUs` \ uniq ->
+ returnUs (setTyVarUnique tv uniq)
+
+------------------------------------------------------------------------------
+-- Building the saturated syntax
+-- ---------------------------------------------------------------------------
+
+maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
+ -- mkApp deals with saturating primops and constructors
+ -- The type is the type of the entire application
+maybeSaturate fn expr n_args ty
+ = case idFlavour fn of
+ PrimOpId (CCallOp ccall)
+ -- Sigh...make a guaranteed unique name for a dynamic ccall
+ -- Done here, not earlier, because it's a code-gen thing
+ -> getUniqueUs `thenUs` \ uniq ->
+ let
+ flavour = PrimOpId (CCallOp (setCCallUnique ccall uniq))
+ fn' = modifyIdInfo (`setFlavourInfo` flavour) fn
+ in
+ saturate fn' expr n_args ty
+
+ PrimOpId op -> saturate fn expr n_args ty
+ DataConId dc -> saturate fn expr n_args ty
+ other -> returnUs expr
+
+saturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
+ -- The type should be the type of (id args)
+ -- The returned expression should also have this type
+saturate fn expr n_args ty
+ = go excess_arity expr ty
+ where
+ fn_arity = idArity fn
+ excess_arity = fn_arity - n_args
+
+ go n expr ty
+ | n == 0 -- Saturated, so nothing to do
+ = returnUs expr
+
+ | otherwise -- An unsaturated constructor or primop; eta expand it
+ = case splitForAllTy_maybe ty of {
+ Just (tv,ty') -> go n (App expr (Type (mkTyVarTy tv))) ty' `thenUs` \ expr' ->
+ returnUs (Lam tv expr') ;
+ Nothing ->
+
+ case splitFunTy_maybe ty of {
+ Just (arg_ty, res_ty)
+ -> newVar arg_ty `thenUs` \ arg' ->
+ go (n-1) (App expr (Var arg')) res_ty `thenUs` \ expr' ->
+ returnUs (Lam arg' expr') ;
+ Nothing ->
+
+ case splitNewType_maybe ty of {
+ Just ty' -> go n (mkCoerce ty' ty expr) ty' `thenUs` \ expr' ->
+ returnUs (mkCoerce ty ty' expr') ;
+
+ Nothing -> pprTrace "Bad saturate" ((ppr fn <+> ppr expr) $$ ppr ty)
+ returnUs expr
+ }}}
+
+
+
+-----------------------------------------------------------------------------
+-- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
+-----------------------------------------------------------------------------
+
+deLam (Note n e)
+ = deLam e `thenUs` \ e ->
+ returnUs (Note n e)
+
+ -- types will all disappear, so that's ok
+deLam (Lam x e) | isTyVar x
+ = deLam e `thenUs` \ e ->
+ returnUs (Lam x e)
+
+deLam expr@(Lam _ _)
+ -- Try for eta reduction
+ | Just e <- eta body
+ = returnUs e
+
+ -- Eta failed, so let-bind the lambda
+ | otherwise
+ = newVar (exprType expr) `thenUs` \ fn ->
+ returnUs (Let (NonRec fn expr) (Var fn))
+
+ where
+ (bndrs, body) = collectBinders expr
+
+ eta expr@(App _ _)
+ | n_remaining >= 0 &&
+ and (zipWith ok bndrs last_args) &&
+ not (any (`elemVarSet` fvs_remaining) bndrs)
+ = Just remaining_expr
+ where
+ (f, args) = collectArgs expr
+ remaining_expr = mkApps f remaining_args
+ fvs_remaining = exprFreeVars remaining_expr
+ (remaining_args, last_args) = splitAt n_remaining args
+ n_remaining = length args - length bndrs
+
+ ok bndr (Var arg) = bndr == arg
+ ok bndr other = False
+
+ eta (Let bind@(NonRec b r) body)
+ | not (any (`elemVarSet` fvs) bndrs)
+ = case eta body of
+ Just e -> Just (Let bind e)
+ Nothing -> Nothing
+ where fvs = exprFreeVars r
+
+ eta _ = Nothing
+
+deLam expr = returnUs expr
+
+-- ---------------------------------------------------------------------------
+-- Precipitating the floating bindings
+-- ---------------------------------------------------------------------------
+
+mkBinds :: [FloatingBind] -> CoreExpr -> UniqSM CoreExpr
+mkBinds [] body = returnUs body
+mkBinds (b:bs) body
+ = deLam body `thenUs` \ body' ->
+ go (b:bs) body'
+ where
+ go [] body = returnUs body
+ go (b:bs) body = go bs body `thenUs` \ body' ->
+ mkBind b body'
+
+-- body can't be Lam
+mkBind (RecF prs) body = returnUs (Let (Rec prs) body)
+
+mkBind (NonRecF bndr rhs dem floats) body
+#ifdef DEBUG
+ -- We shouldn't get let or case of the form v=w
+ = if exprIsTrivial rhs
+ then pprTrace "mkBind" (ppr bndr <+> ppr rhs)
+ (mk_let bndr rhs dem floats body)
+ else mk_let bndr rhs dem floats body
+
+mk_let bndr rhs dem floats body
+#endif
+ | isUnLiftedType bndr_rep_ty
+ = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
+ mkCase rhs bndr [(DEFAULT, [], body)] `thenUs` \ expr' ->
+ mkBinds floats expr'
+
+ | is_whnf
+ = if is_strict then
+ -- Strict let with WHNF rhs
+ mkBinds floats $
+ Let (NonRec bndr rhs) body
+ else
+ -- Lazy let with WHNF rhs; float until we find a strict binding
+ let
+ (floats_out, floats_in) = splitFloats floats
+ in
+ mkBinds floats_in rhs `thenUs` \ new_rhs ->
+ mkBinds floats_out $
+ Let (NonRec bndr new_rhs) body
+
+ | otherwise -- Not WHNF
+ = if is_strict then
+ -- Strict let with non-WHNF rhs
+ mkCase rhs bndr [(DEFAULT, [], body)] `thenUs` \ expr' ->
+ mkBinds floats expr'
+ else
+ -- Lazy let with non-WHNF rhs, so keep the floats in the RHS
+ mkBinds floats rhs `thenUs` \ new_rhs ->
+ returnUs (Let (NonRec bndr new_rhs) body)
+
+ where
+ bndr_rep_ty = repType (idType bndr)
+ is_strict = isStrictDem dem
+ is_whnf = exprIsValue rhs
+
+splitFloats fs@(NonRecF _ _ dem _ : _)
+ | isStrictDem dem = ([], fs)
+
+splitFloats (f : fs) = case splitFloats fs of
+ (fs_out, fs_in) -> (f : fs_out, fs_in)
+
+splitFloats [] = ([], [])
+
+-- -----------------------------------------------------------------------------
+-- Making case expressions
+-- -----------------------------------------------------------------------------
+
+mkCase scrut bndr alts = returnUs (Case scrut bndr alts) -- ToDo
+
+{-
+mkCase scrut@(App _ _) bndr alts
+ = let (f,args) = collectArgs scrut in
+
+
+
+mkCase scrut@(StgPrimApp ParOp _ _) bndr
+ (StgPrimAlts tycon _ deflt@(StgBindDefault _))
+ = returnUs (StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT (StgPrimAlts tycon [] deflt))
+
+mkStgCase (StgPrimApp SeqOp [scrut] _) bndr
+ (StgPrimAlts _ _ deflt@(StgBindDefault rhs))
+ = mkStgCase scrut_expr new_bndr new_alts
+ where
+ new_alts | isUnLiftedType scrut_ty = WARN( True, text "mkStgCase" ) mkStgPrimAlts scrut_ty [] deflt
+ | otherwise = mkStgAlgAlts scrut_ty [] deflt
+ scrut_ty = stgArgType scrut
+ new_bndr = setIdType bndr scrut_ty
+ -- NB: SeqOp :: forall a. a -> Int#
+ -- So bndr has type Int#
+ -- But now we are going to scrutinise the SeqOp's argument directly,
+ -- so we must change the type of the case binder to match that
+ -- of the argument expression e.
+
+ scrut_expr = case scrut of
+ StgVarArg v -> StgApp v []
+ -- Others should not happen because
+ -- seq of a value should have disappeared
+ StgLitArg l -> WARN( True, text "seq on" <+> ppr l ) StgLit l
+
+mkStgCase scrut bndr alts
+ = deStgLam scrut `thenUs` \ scrut' ->
+ -- It is (just) possible to get a lambda as a srutinee here
+ -- Namely: fromDyn (toDyn ((+1)::Int->Int)) False)
+ -- gives: case ...Bool == Int->Int... of
+ -- True -> case coerce Bool (\x -> + 1 x) of
+ -- True -> ...
+ -- False -> ...
+ -- False -> ...
+ -- The True branch of the outer case will never happen, of course.
+
+ returnUs (StgCase scrut' bOGUS_LVs bOGUS_LVs bndr noSRT alts)
+-}
+
+-------------------------------------------------------------------------
+-- Demands
+-- -----------------------------------------------------------------------------
+
+data RhsDemand
+ = RhsDemand { isStrictDem :: Bool, -- True => used at least once
+ isOnceDem :: Bool -- True => used at most once
+ }
+
+mkDem :: Demand -> Bool -> RhsDemand
+mkDem strict once = RhsDemand (isStrict strict) once
+
+mkDemTy :: Demand -> Type -> RhsDemand
+mkDemTy strict ty = RhsDemand (isStrict strict) (isOnceTy ty)
+
+isOnceTy :: Type -> Bool
+isOnceTy ty
+ =
+#ifdef USMANY
+ opt_UsageSPOn && -- can't expect annotations if -fusagesp is off
+#endif
+ once
+ where
+ u = uaUTy ty
+ once | u == usOnce = True
+ | u == usMany = False
+ | isTyVarTy u = False -- if unknown at compile-time, is Top ie usMany
+
+bdrDem :: Id -> RhsDemand
+bdrDem id = mkDem (idDemandInfo id) (isOnceTy (idType id))
+
+safeDem, onceDem :: RhsDemand
+safeDem = RhsDemand False False -- always safe to use this
+onceDem = RhsDemand False True -- used at most once
+\end{code}
#include "HsVersions.h"
-import CmdLineOpts ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas, dopt )
+import CmdLineOpts ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas )
import CoreSyn
import CoreUnfold ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile )
+import CoreUtils ( exprArity )
import CoreFVs ( ruleSomeFreeVars, exprSomeFreeVars )
import CoreLint ( showPass, endPass )
import VarEnv
import VarSet
import Var ( Id, Var )
import Id ( idType, idInfo, idName, isExportedId,
- mkVanillaId, mkId, isLocalId, omitIfaceSigForId,
- setIdStrictness, setIdDemandInfo,
+ mkId, isLocalId, omitIfaceSigForId
)
-import IdInfo ( mkIdInfo,
+import IdInfo ( IdInfo, mkIdInfo, vanillaIdInfo,
IdFlavour(..), flavourInfo, ppFlavourInfo,
specInfo, setSpecInfo,
- cprInfo, setCprInfo,
+ cprInfo, setCprInfo,
inlinePragInfo, setInlinePragInfo, isNeverInlinePrag,
- strictnessInfo, setStrictnessInfo, isBottomingStrictness,
+ strictnessInfo, setStrictnessInfo,
+ isBottomingStrictness,
unfoldingInfo, setUnfoldingInfo,
- demandInfo,
occInfo, isLoopBreaker,
- workerInfo, setWorkerInfo, WorkerInfo(..)
+ workerInfo, setWorkerInfo, WorkerInfo(..),
+ ArityInfo(..), setArityInfo
)
import Name ( getOccName, nameOccName, globaliseName, setNameOcc,
localiseName, mkLocalName, isGlobalName
import HscTypes ( PersistentCompilerState( pcs_PRS ), PersistentRenamerState( prsOrig ),
OrigNameEnv( origNames ), OrigNameNameEnv
)
-import Unique ( Uniquable(..) )
+import UniqSupply
import FiniteMap ( lookupFM, addToFM )
import Maybes ( maybeToBool, orElse )
import ErrUtils ( showPass )
IdEnv Bool
-
Step 2: Tidy the program
~~~~~~~~~~~~~~~~~~~~~~~~
Next we traverse the bindings top to bottom. For each top-level
- Give external Ids the same Unique as they had before
if the name is in the renamer's name cache
+ - Clone all local Ids. This means that Tidy Core has the property
+ that all Ids are unique, rather than the weaker guarantee of
+ no clashes which the simplifier provides.
+
- Give the Id its final IdInfo; in ptic,
* Its flavour becomes ConstantId, reflecting the fact that
from now on we regard it as a constant, not local, Id
; let ext_ids = findExternalSet binds_in orphans_in
- ; let ((orig_env', occ_env, subst_env), binds_out)
- = mapAccumL (tidyTopBind mod ext_ids) init_tidy_env binds_in
+ ; us <- mkSplitUniqSupply 't' -- for "tidy"
- ; let orphans_out = tidyIdRules (occ_env,subst_env) orphans_in
+ ; let ((us1, orig_env', occ_env, subst_env), binds_out)
+ = mapAccumL (tidyTopBind mod ext_ids)
+ (init_tidy_env us) binds_in
- ; let pcs' = pcs { pcs_PRS = prs { prsOrig = orig { origNames = orig_env' }}}
+ ; let (orphans_out, us2)
+ = initUs us1 (tidyIdRules (occ_env,subst_env) orphans_in)
- ; endPass dflags "Tidy Core" (dopt Opt_D_dump_simpl dflags ||
- dopt Opt_D_verbose_core2core dflags)
- binds_out
+ ; let prs' = prs { prsOrig = orig { origNames = orig_env' } }
+ pcs' = pcs { pcs_PRS = prs' }
+
+ ; endPass dflags "Tidy Core" Opt_D_dump_simpl binds_out
; return (pcs', binds_out, orphans_out)
}
-- The second exported decl must 'get' the name 'f', so we
-- have to put 'f' in the avoids list before we get to the first
-- decl. tidyTopId then does a no-op on exported binders.
- prs = pcs_PRS pcs
- orig = prsOrig prs
- orig_env = origNames orig
+ prs = pcs_PRS pcs
+ orig = prsOrig prs
+ orig_env = origNames orig
- init_tidy_env = (orig_env, initTidyOccEnv avoids, emptyVarEnv)
- avoids = [getOccName bndr | bndr <- bindersOfBinds binds_in,
+ init_tidy_env us = (us, orig_env, initTidyOccEnv avoids, emptyVarEnv)
+ avoids = [getOccName bndr | bndr <- bindersOfBinds binds_in,
isGlobalName (idName bndr)]
\end{code}
\begin{code}
-type TopTidyEnv = (OrigNameNameEnv, TidyOccEnv, VarEnv Var)
+type TopTidyEnv = (UniqSupply, OrigNameNameEnv, TidyOccEnv, VarEnv Var)
-- TopTidyEnv: when tidying we need to know
-- * orig_env: Any pre-ordained Names. These may have arisen because the
-- invented an Id whose name is $wf (but with a different unique)
-- we want to rename it to have unique r77, so that we can do easy
-- comparisons with stuff from the interface file
-
--- * occ_env: The TidyOccEnv, which tells us which local occurrences are 'used'
-
+--
+-- * occ_env: The TidyOccEnv, which tells us which local occurrences
+-- are 'used'
+--
-- * subst_env: A Var->Var mapping that substitutes the new Var for the old
+--
+-- * uniqsuppy: so we can clone any Ids with non-preordained names.
+--
\end{code}
\begin{code}
tidyTopBind :: Module
- -> IdEnv Bool -- Domain = Ids that should be exernal
+ -> IdEnv Bool -- Domain = Ids that should be external
-- True <=> their unfolding is external too
-> TopTidyEnv -> CoreBind
-> (TopTidyEnv, CoreBind)
tidyTopBind mod ext_ids env (NonRec bndr rhs)
- = (env', NonRec bndr' rhs')
+ = ((us2,orig,occ,subst) , NonRec bndr' rhs')
where
- rhs' = tidyTopRhs env rhs
- (env', bndr') = tidyTopBinder mod ext_ids env rhs' env bndr
+ (env1@(us1,orig,occ,subst), bndr') = tidyTopBinder mod ext_ids env rhs' env bndr
+ (rhs',us2) = initUs us1 (tidyTopRhs env1 rhs)
tidyTopBind mod ext_ids env (Rec prs)
= (final_env, Rec prs')
where
(final_env, prs') = mapAccumL do_one env prs
- do_one env (bndr,rhs) = (env', (bndr', rhs'))
- where
- rhs' = tidyTopRhs final_env rhs
- (env', bndr') = tidyTopBinder mod ext_ids final_env
- rhs' env bndr
-tidyTopRhs :: TopTidyEnv -> CoreExpr -> CoreExpr
+ do_one env (bndr,rhs)
+ = ((us',orig,occ,subst), (bndr',rhs'))
+ where
+ (env'@(us,orig,occ,subst), bndr')
+ = tidyTopBinder mod ext_ids final_env rhs' env bndr
+ (rhs', us') = initUs us (tidyTopRhs final_env rhs)
+
+
+tidyTopRhs :: TopTidyEnv -> CoreExpr -> UniqSM CoreExpr
-- Just an impedence matcher
-tidyTopRhs (_, occ_env, subst_env) rhs = tidyExpr (occ_env, subst_env) rhs
+tidyTopRhs (_, _, occ_env, subst_env) rhs
+ = tidyExpr (occ_env, subst_env) rhs
+
tidyTopBinder :: Module -> IdEnv Bool
-> TopTidyEnv -> CoreExpr
-> TopTidyEnv -> Id -> (TopTidyEnv, Id)
-tidyTopBinder mod ext_ids env_idinfo rhs env@(orig_env, occ_env, subst_env) id
+tidyTopBinder mod ext_ids
+ final_env@(_, orig_env1, occ_env1, subst_env1) rhs
+ env@(us, orig_env2, occ_env2, subst_env2) id
+
| omitIfaceSigForId id -- Don't mess with constructors,
= (env, id) -- record selectors, and the like
-- The rhs is already tidied
- = ((orig_env', occ_env', subst_env'), id')
+ = ((us_r, orig_env', occ_env', subst_env'), id')
where
- (orig_env', occ_env', name') = tidyTopName mod orig_env occ_env
+ (us_l, us_r) = splitUniqSupply us
+
+ (orig_env', occ_env', name') = tidyTopName mod orig_env2 occ_env2
is_external
(idName id)
- ty' = tidyTopType (idType id)
- idinfo' = tidyIdInfo env_idinfo is_external unfold_info id
+ ty' = tidyTopType (idType id)
+ idinfo' = tidyIdInfo us_l (occ_env1, subst_env1)
+ is_external unfold_info arity_info id
+
id' = mkId name' ty' idinfo'
- subst_env' = extendVarEnv subst_env id id'
+ subst_env' = extendVarEnv subst_env2 id id'
maybe_external = lookupVarEnv ext_ids id
is_external = maybeToBool maybe_external
unfold_info | show_unfold = mkTopUnfolding rhs
| otherwise = noUnfolding
-tidyIdInfo (_, occ_env, subst_env) is_external unfold_info id
+ arity_info = exprArity rhs
+
+
+tidyIdInfo us tidy_env is_external unfold_info arity_info id
| opt_OmitInterfacePragmas || not is_external
-- No IdInfo if the Id isn't external, or if we don't have -O
- = mkIdInfo new_flavour
+ = mkIdInfo new_flavour
`setStrictnessInfo` strictnessInfo core_idinfo
- -- Keep strictness info; it's used by the code generator
+ `setArityInfo` ArityExactly arity_info
+ -- Keep strictness and arity info; it's used by the code generator
| otherwise
- = mkIdInfo new_flavour
+ = let (rules', _) = initUs us (tidyRules tidy_env (specInfo core_idinfo))
+ in
+ mkIdInfo new_flavour
`setCprInfo` cprInfo core_idinfo
`setStrictnessInfo` strictnessInfo core_idinfo
`setInlinePragInfo` inlinePragInfo core_idinfo
`setUnfoldingInfo` unfold_info
`setWorkerInfo` tidyWorker tidy_env (workerInfo core_idinfo)
- `setSpecInfo` tidyRules tidy_env (specInfo core_idinfo)
+ `setSpecInfo` rules'
+ `setArityInfo` ArityExactly arity_info
+ -- this is the final IdInfo, it must agree with the
+ -- code finally generated (i.e. NO more transformations
+ -- after this!).
where
- tidy_env = (occ_env, subst_env)
core_idinfo = idInfo id
-- A DFunId must stay a DFunId, so that we can gather the
flavour -> pprTrace "tidyIdInfo" (ppr id <+> ppFlavourInfo flavour)
flavour
+-- this is where we set names to local/global based on whether they really are
+-- externally visible (see comment at the top of this module). If the name
+-- was previously local, we have to give it a unique occurrence name if
+-- we intend to globalise it.
tidyTopName mod orig_env occ_env external name
- | global && internal = (orig_env, occ_env, localiseName name)
- | local && internal = (orig_env, occ_env', setNameOcc name occ')
- | global && external = (orig_env, occ_env, name)
+ | global && internal = (orig_env, occ_env, localiseName name)
+ | local && internal = (orig_env, occ_env', setNameOcc name occ') -- (*)
+ | global && external = (orig_env, occ_env, name)
| local && external = globalise
+ -- (*) just in case we're globalising all top-level names (because of
+ -- -split-objs), we need to give *all* the top-level ids a
+ -- unique occurrence name. The actual globalisation now happens in the code
+ -- generator.
where
-- If we want to globalise a currently-local name, check
-- whether we have already assigned a unique for it.
-- If so, use it; if not, extend the table
- globalise = case lookupFM orig_env key of
- Just orig -> (orig_env, occ_env', orig)
- Nothing -> (addToFM orig_env key global_name, occ_env', global_name)
+ globalise
+ = case lookupFM orig_env key of
+ Just orig -> (orig_env, occ_env', orig)
+ Nothing -> (addToFM orig_env key global_name, occ_env', global_name)
(occ_env', occ') = tidyOccName occ_env (nameOccName name)
key = (moduleName mod, occ')
local = not global
internal = not external
-tidyIdRules :: TidyEnv -> [IdCoreRule] -> [IdCoreRule]
-tidyIdRules env rules
- = [ (tidyVarOcc env fn, tidyRule env rule) | (fn,rule) <- rules ]
-
+tidyIdRules :: TidyEnv -> [IdCoreRule] -> UniqSM [IdCoreRule]
+tidyIdRules env [] = returnUs []
+tidyIdRules env ((fn,rule) : rules)
+ = tidyRule env rule `thenUs` \ rule ->
+ tidyIdRules env rules `thenUs` \ rules ->
+ returnUs ((tidyVarOcc env fn, rule) : rules)
tidyWorker tidy_env (HasWorker work_id wrap_arity)
= HasWorker (tidyVarOcc tidy_env work_id) wrap_arity
tidyWorker tidy_env NoWorker
= NoWorker
-tidyRules :: TidyEnv -> CoreRules -> CoreRules
+tidyRules :: TidyEnv -> CoreRules -> UniqSM CoreRules
tidyRules env (Rules rules fvs)
- = Rules (map (tidyRule env) rules)
- (foldVarSet tidy_set_elem emptyVarSet fvs)
+ = mapUs (tidyRule env) rules `thenUs` \ rules ->
+ returnUs (Rules rules (foldVarSet tidy_set_elem emptyVarSet fvs))
where
tidy_set_elem var new_set = extendVarSet new_set (tidyVarOcc env var)
-tidyRule :: TidyEnv -> CoreRule -> CoreRule
-tidyRule env rule@(BuiltinRule _) = rule
+tidyRule :: TidyEnv -> CoreRule -> UniqSM CoreRule
+tidyRule env rule@(BuiltinRule _) = returnUs rule
tidyRule env (Rule name vars tpl_args rhs)
- = (Rule name vars' (map (tidyExpr env') tpl_args) (tidyExpr env' rhs))
- where
- (env', vars') = tidyBndrs env vars
+ = tidyBndrs env vars `thenUs` \ (env', vars) ->
+ mapUs (tidyExpr env') tpl_args `thenUs` \ tpl_args ->
+ tidyExpr env' rhs `thenUs` \ rhs ->
+ returnUs (Rule name vars tpl_args rhs)
\end{code}
-
%************************************************************************
%* *
\subsection{Step 2: inner tidying
\begin{code}
tidyBind :: TidyEnv
-> CoreBind
- -> (TidyEnv, CoreBind)
+ -> UniqSM (TidyEnv, CoreBind)
tidyBind env (NonRec bndr rhs)
- = let
- (env', bndr') = tidyBndr env bndr
- rhs' = tidyExpr env' rhs
- -- We use env' when tidying the RHS even though it's not
- -- strictly necessary; it makes the tidied code pretty
- -- hard to read if we don't!
- in
- (env', NonRec bndr' rhs')
+ = tidyBndrWithRhs env (bndr,rhs) `thenUs` \ (env', bndr') ->
+ tidyExpr env' rhs `thenUs` \ rhs' ->
+ returnUs (env', NonRec bndr' rhs')
tidyBind env (Rec prs)
- = (final_env, Rec prs')
- where
- (final_env, prs') = mapAccumL do_one env prs
- do_one env (bndr,rhs) = (env', (bndr', rhs'))
- where
- (env', bndr') = tidyBndr env bndr
- rhs' = tidyExpr final_env rhs
+ = mapAccumLUs tidyBndrWithRhs env prs `thenUs` \ (env', bndrs') ->
+ mapUs (tidyExpr env') (map snd prs) `thenUs` \ rhss' ->
+ returnUs (env', Rec (zip bndrs' rhss'))
-tidyExpr env (Type ty) = Type (tidyType env ty)
-tidyExpr env (Lit lit) = Lit lit
-tidyExpr env (App f a) = App (tidyExpr env f) (tidyExpr env a)
-tidyExpr env (Note n e) = Note (tidyNote env n) (tidyExpr env e)
+tidyExpr env (Var v) = returnUs (Var (tidyVarOcc env v))
+tidyExpr env (Type ty) = returnUs (Type (tidyType env ty))
+tidyExpr env (Lit lit) = returnUs (Lit lit)
-tidyExpr env (Let b e) = Let b' (tidyExpr env' e)
- where
- (env', b') = tidyBind env b
+tidyExpr env (App f a)
+ = tidyExpr env f `thenUs` \ f ->
+ tidyExpr env a `thenUs` \ a ->
+ returnUs (App f a)
-tidyExpr env (Case e b alts) = Case (tidyExpr env e) b' (map (tidyAlt env') alts)
- where
- (env', b') = tidyBndr env b
+tidyExpr env (Note n e)
+ = tidyExpr env e `thenUs` \ e ->
+ returnUs (Note (tidyNote env n) e)
-tidyExpr env (Var v) = Var (tidyVarOcc env v)
+tidyExpr env (Let b e)
+ = tidyBind env b `thenUs` \ (env', b') ->
+ tidyExpr env' e `thenUs` \ e ->
+ returnUs (Let b' e)
-tidyExpr env (Lam b e) = Lam b' (tidyExpr env' e)
- where
- (env', b') = tidyBndr env b
+tidyExpr env (Case e b alts)
+ = tidyExpr env e `thenUs` \ e ->
+ tidyBndr env b `thenUs` \ (env', b) ->
+ mapUs (tidyAlt env') alts `thenUs` \ alts ->
+ returnUs (Case e b alts)
-tidyAlt env (con, vs, rhs) = (con, vs', tidyExpr env' rhs)
- where
- (env', vs') = tidyBndrs env vs
+tidyExpr env (Lam b e)
+ = tidyBndr env b `thenUs` \ (env', b) ->
+ tidyExpr env' e `thenUs` \ e ->
+ returnUs (Lam b e)
-tidyNote env (Coerce t1 t2) = Coerce (tidyType env t1) (tidyType env t2)
+tidyAlt env (con, vs, rhs)
+ = tidyBndrs env vs `thenUs` \ (env', vs) ->
+ tidyExpr env' rhs `thenUs` \ rhs ->
+ returnUs (con, vs, rhs)
+
+tidyNote env (Coerce t1 t2) = Coerce (tidyType env t1) (tidyType env t2)
tidyNote env note = note
\end{code}
Just v' -> v'
Nothing -> v
-tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var)
-tidyBndr env var | isTyVar var = tidyTyVar env var
- | otherwise = tidyId env var
-
-tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var])
-tidyBndrs env vars = mapAccumL tidyBndr env vars
+-- tidyBndr is used for lambda and case binders
+tidyBndr :: TidyEnv -> Var -> UniqSM (TidyEnv, Var)
+tidyBndr env var
+ | isTyVar var = returnUs (tidyTyVar env var)
+ | otherwise = tidyId env var vanillaIdInfo
+
+tidyBndrs :: TidyEnv -> [Var] -> UniqSM (TidyEnv, [Var])
+tidyBndrs env vars = mapAccumLUs tidyBndr env vars
+
+-- tidyBndrWithRhs is used for let binders
+tidyBndrWithRhs :: TidyEnv -> (Var, CoreExpr) -> UniqSM (TidyEnv, Var)
+tidyBndrWithRhs env (id,rhs)
+ = tidyId env id idinfo
+ where
+ idinfo = vanillaIdInfo `setArityInfo` ArityExactly (exprArity rhs)
+ -- NB: This throws away the IdInfo of the Id, which we
+ -- no longer need. That means we don't need to
+ -- run over it with env, nor renumber it.
-tidyId :: TidyEnv -> Id -> (TidyEnv, Id)
-tidyId env@(tidy_env, var_env) id
+tidyId :: TidyEnv -> Id -> IdInfo -> UniqSM (TidyEnv, Id)
+tidyId env@(tidy_env, var_env) id idinfo
= -- Non-top-level variables
+ getUniqueUs `thenUs` \ uniq ->
let
-- Give the Id a fresh print-name, *and* rename its type
- -- The SrcLoc isn't important now, though we could extract it from the Id
- name' = mkLocalName (getUnique id) occ' noSrcLoc
+ -- The SrcLoc isn't important now,
+ -- though we could extract it from the Id
+ name' = mkLocalName uniq occ' noSrcLoc
(tidy_env', occ') = tidyOccName tidy_env (getOccName id)
- ty' = tidyType env (idType id)
- idinfo = idInfo id
- id' = mkVanillaId name' ty'
- `setIdStrictness` strictnessInfo idinfo
- `setIdDemandInfo` demandInfo idinfo
- -- NB: This throws away the IdInfo of the Id, which we
- -- no longer need. That means we don't need to
- -- run over it with env, nor renumber it.
- --
- -- The exception is strictness and demand info, which
- -- is used to decide whether to use let or case for
- -- function arguments and let bindings
-
+ ty' = tidyType (tidy_env,var_env) (idType id)
+ id' = mkId name' ty' idinfo
var_env' = extendVarEnv var_env id id'
in
- ((tidy_env', var_env'), id')
+ returnUs ((tidy_env', var_env'), id')
\end{code}
exprIsValue,exprOkForSpeculation, exprIsBig,
exprIsConApp_maybe,
idAppIsBottom, idAppIsCheap,
+ exprArity,
-- Expr transformation
etaReduce, exprEtaExpandArity,
Just unf -> exprIsConApp_maybe unf
analyse other = Nothing
-\end{code}
+\end{code}
+
+The arity of an expression (in the code-generator sense, i.e. the
+number of lambdas at the beginning).
+\begin{code}
+exprArity :: CoreExpr -> Int
+exprArity (Lam x e)
+ | isTyVar x = exprArity e
+ | otherwise = 1 + exprArity e
+exprArity (Note _ e)
+ -- Ignore coercions. Top level sccs are removed by the final
+ -- profiling pass, so we ignore those too.
+ = exprArity e
+exprArity _ = 0
+\end{code}
%************************************************************************
%* *
showPass dflags "Constructed Product analysis" ;
let { binds_plus_cpr = do_prog binds } ;
endPass dflags "Constructed Product analysis"
- (dopt Opt_D_dump_cpranal dflags || dopt Opt_D_verbose_core2core dflags)
- binds_plus_cpr
+ Opt_D_dump_cpranal binds_plus_cpr
}
where
do_prog :: [CoreBind] -> [CoreBind]
(printErrs unqual (pprBagOfWarnings ds_warns))
-- Lint result if necessary
- ; let do_dump_ds = dopt Opt_D_dump_ds dflags
- ; endPass dflags "Desugar" do_dump_ds ds_binds
+ ; endPass dflags "Desugar" Opt_D_dump_ds ds_binds
-- Dump output
- ; doIfSet do_dump_ds (printDump (ppr_ds_rules ds_rules))
+ ; doIfSet (dopt Opt_D_dump_ds dflags)
+ (printDump (ppr_ds_rules ds_rules))
; return result
}
\begin{code}
data StgToDo
- = StgDoStaticArgs
- | StgDoLambdaLift
- | StgDoMassageForProfiling -- should be (next to) last
+ = StgDoMassageForProfiling -- should be (next to) last
-- There's also setStgVarInfo, but its absolute "lastness"
-- is so critical that it is hardwired in (no flag).
| D_stg_stats
| Opt_D_dump_simpl
| Opt_D_dump_simpl_iterations
| Opt_D_dump_spec
+ | Opt_D_dump_sat
| Opt_D_dump_stg
| Opt_D_dump_stranal
| Opt_D_dump_tc
-----------------------------------------------------------------------------
--- $Id: DriverFlags.hs,v 1.27 2000/12/05 16:59:03 rrt Exp $
+-- $Id: DriverFlags.hs,v 1.28 2000/12/06 13:03:29 simonmar Exp $
--
-- Driver flags
--
, ( "ddump-simpl", NoArg (setDynFlag Opt_D_dump_simpl) )
, ( "ddump-simpl-iterations", NoArg (setDynFlag Opt_D_dump_simpl_iterations) )
, ( "ddump-spec", NoArg (setDynFlag Opt_D_dump_spec) )
+ , ( "ddump-sat", NoArg (setDynFlag Opt_D_dump_sat) )
, ( "ddump-stg", NoArg (setDynFlag Opt_D_dump_stg) )
, ( "ddump-stranal", NoArg (setDynFlag Opt_D_dump_stranal) )
, ( "ddump-tc", NoArg (setDynFlag Opt_D_dump_tc) )
printErrorsAndWarnings, pprBagOfErrors, pprBagOfWarnings,
ghcExit,
- doIfSet, doIfSet_dyn, dumpIfSet, dumpIfSet_dyn, showPass
+ doIfSet, doIfSet_dyn, dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, showPass
) where
#include "HsVersions.h"
| not flag = return ()
| otherwise = printDump (dump hdr doc)
+dumpIfSet_core :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
+dumpIfSet_core dflags flag hdr doc
+ | dopt flag dflags
+ || verbosity dflags >= 4
+ || dopt Opt_D_verbose_core2core dflags = printDump (dump hdr doc)
+ | otherwise = return ()
+
dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn dflags flag hdr doc
- | not (dopt flag dflags) && verbosity dflags < 4 = return ()
- | otherwise = printDump (dump hdr doc)
+ | dopt flag dflags || verbosity dflags >= 4 = printDump (dump hdr doc)
+ | otherwise = return ()
dump hdr doc
= vcat [text "",
= do {
showPass dflags "Common sub-expression";
let { binds' = cseBinds emptyCSEnv binds };
- endPass dflags "Common sub-expression"
- (dopt Opt_D_dump_cse dflags || dopt Opt_D_verbose_core2core dflags)
- binds'
+ endPass dflags "Common sub-expression" Opt_D_dump_cse binds'
}
cseBinds :: CSEnv -> [CoreBind] -> [CoreBind]
= do {
showPass dflags "Float inwards";
let { binds' = map fi_top_bind binds };
- endPass dflags "Float inwards"
- (dopt Opt_D_verbose_core2core dflags)
+ endPass dflags "Float inwards" Opt_D_verbose_core2core binds'
{- no specific flag for dumping float-in -}
- binds'
}
where
int ntlets, ptext SLIT(" Lets floated elsewhere; from "),
int lams, ptext SLIT(" Lambda groups")]);
- endPass dflags float_msg
- (dopt Opt_D_verbose_core2core dflags)
+ endPass dflags float_msg Opt_D_verbose_core2core (concat binds_s')
{- no specific flag for dumping float-out -}
- (concat binds_s')
}
where
float_msg | float_lams = "Float out (floating lambdas too)"
= do {
showPass dflags "Liberate case" ;
let { binds' = do_prog (initEnv opt_LiberateCaseThreshold) binds } ;
- endPass dflags "Liberate case"
- (dopt Opt_D_verbose_core2core dflags)
+ endPass dflags "Liberate case" Opt_D_verbose_core2core binds'
{- no specific flag for dumping -}
- binds'
}
where
do_prog env [] = []
text "",
pprSimplCount counts_out]);
- endPass dflags "Simplify"
- (dopt Opt_D_verbose_core2core dflags
- && not (dopt Opt_D_dump_simpl_iterations dflags))
- binds' ;
+ endPass dflags "Simplify" Opt_D_verbose_core2core binds';
return (counts_out, binds')
}
if dopt Opt_D_dump_simpl_iterations dflags then
endPass dflags
("Simplifier iteration " ++ show iteration_no ++ " result")
- (dopt Opt_D_verbose_core2core dflags)
+ Opt_D_verbose_core2core
binds'
else
return [] ;
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1994-1998
-%
-\section[LambdaLift]{A STG-code lambda lifter}
-
-\begin{code}
-module LambdaLift ( liftProgram ) where
-
-#include "HsVersions.h"
-
-import StgSyn
-
-import CmdLineOpts ( opt_EnsureSplittableC )
-import Bag ( Bag, emptyBag, unionBags, unitBag, snocBag, bagToList )
-import Id ( mkVanillaId, idType, setIdArityInfo, Id )
-import VarSet
-import VarEnv
-import IdInfo ( exactArity )
-import Module ( Module )
-import Name ( Name, mkGlobalName, mkLocalName )
-import OccName ( mkVarOcc )
-import Type ( splitForAllTys, mkForAllTys, mkFunTys, Type )
-import Unique ( Unique )
-import UniqSupply ( uniqFromSupply, splitUniqSupply, UniqSupply )
-import Util ( zipEqual )
-import SrcLoc ( noSrcLoc )
-import Panic ( panic, assertPanic )
-\end{code}
-
-This is the lambda lifter. It turns lambda abstractions into
-supercombinators on a selective basis:
-
-* Let-no-escaped bindings are never lifted. That's one major reason
- why the lambda lifter is done in STG.
-
-* Non-recursive bindings whose RHS is a lambda abstractions are lifted,
- provided all the occurrences of the bound variable is in a function
- postition. In this example, f will be lifted:
-
- let
- f = \x -> e
- in
- ..(f a1)...(f a2)...
- thus
-
- $f p q r x = e -- Supercombinator
-
- ..($f p q r a1)...($f p q r a2)...
-
- NOTE that the original binding is eliminated.
-
- But in this case, f won't be lifted:
-
- let
- f = \x -> e
- in
- ..(g f)...(f a2)...
-
- Why? Because we have to heap-allocate a closure for f thus:
-
- $f p q r x = e -- Supercombinator
-
- let
- f = $f p q r
- in
- ..(g f)...($f p q r a2)..
-
- so it might as well be the original lambda abstraction.
-
- We also do not lift if the function has an occurrence with no arguments, e.g.
-
- let
- f = \x -> e
- in f
-
- as this form is more efficient than if we create a partial application
-
- $f p q r x = e -- Supercombinator
-
- f p q r
-
-* Recursive bindings *all* of whose RHSs are lambda abstractions are
- lifted iff
- - all the occurrences of all the binders are in a function position
- - there aren't ``too many'' free variables.
-
- Same reasoning as before for the function-position stuff. The ``too many
- free variable'' part comes from considering the (potentially many)
- recursive calls, which may now have lots of free vars.
-
-Recent Observations:
-
-* 2 might be already ``too many'' variables to abstract.
- The problem is that the increase in the number of free variables
- of closures refering to the lifted function (which is always # of
- abstracted args - 1) may increase heap allocation a lot.
- Expeiments are being done to check this...
-
-* We do not lambda lift if the function has at least one occurrence
- without any arguments. This caused lots of problems. Ex:
- h = \ x -> ... let y = ...
- in let let f = \x -> ...y...
- in f
- ==>
- f = \y x -> ...y...
- h = \ x -> ... let y = ...
- in f y
-
- now f y is a partial application, so it will be updated, and this
- is Bad.
-
-
---- NOT RELEVANT FOR STG ----
-* All ``lone'' lambda abstractions are lifted. Notably this means lambda
- abstractions:
- - in a case alternative: case e of True -> (\x->b)
- - in the body of a let: let x=e in (\y->b)
------------------------------
-
-%************************************************************************
-%* *
-\subsection[Lift-expressions]{The main function: liftExpr}
-%* *
-%************************************************************************
-
-\begin{code}
-liftProgram :: Module -> UniqSupply -> [StgBinding] -> [StgBinding]
-liftProgram mod us prog = concat (runLM mod Nothing us (mapLM liftTopBind prog))
-
-
-liftTopBind :: StgBinding -> LiftM [StgBinding]
-liftTopBind (StgNonRec id rhs)
- = dontLiftRhs rhs `thenLM` \ (rhs', rhs_info) ->
- returnLM (getScBinds rhs_info ++ [StgNonRec id rhs'])
-
-liftTopBind (StgRec pairs)
- = mapAndUnzipLM dontLiftRhs rhss `thenLM` \ (rhss', rhs_infos) ->
- returnLM ([co_rec_ify (StgRec (ids `zip` rhss') :
- getScBinds (unionLiftInfos rhs_infos))
- ])
- where
- (ids, rhss) = unzip pairs
-\end{code}
-
-
-\begin{code}
-liftExpr :: StgExpr
- -> LiftM (StgExpr, LiftInfo)
-
-
-liftExpr expr@(StgLit _) = returnLM (expr, emptyLiftInfo)
-liftExpr expr@(StgConApp _ _) = returnLM (expr, emptyLiftInfo)
-liftExpr expr@(StgPrimApp _ _ _) = returnLM (expr, emptyLiftInfo)
-
-liftExpr expr@(StgApp v args)
- = lookUp v `thenLM` \ ~(sc, sc_args) -> -- NB the ~. We don't want to
- -- poke these bindings too early!
- returnLM (StgApp sc (map StgVarArg sc_args ++ args),
- emptyLiftInfo)
- -- The lvs field is probably wrong, but we reconstruct it
- -- anyway following lambda lifting
-
-liftExpr (StgCase scrut lv1 lv2 bndr srt alts)
- = liftExpr scrut `thenLM` \ (scrut', scrut_info) ->
- lift_alts alts `thenLM` \ (alts', alts_info) ->
- returnLM (StgCase scrut' lv1 lv2 bndr srt alts', scrut_info `unionLiftInfo` alts_info)
- where
- lift_alts (StgAlgAlts tycon alg_alts deflt)
- = mapAndUnzipLM lift_alg_alt alg_alts `thenLM` \ (alg_alts', alt_infos) ->
- lift_deflt deflt `thenLM` \ (deflt', deflt_info) ->
- returnLM (StgAlgAlts tycon alg_alts' deflt', foldr unionLiftInfo deflt_info alt_infos)
-
- lift_alts (StgPrimAlts tycon prim_alts deflt)
- = mapAndUnzipLM lift_prim_alt prim_alts `thenLM` \ (prim_alts', alt_infos) ->
- lift_deflt deflt `thenLM` \ (deflt', deflt_info) ->
- returnLM (StgPrimAlts tycon prim_alts' deflt', foldr unionLiftInfo deflt_info alt_infos)
-
- lift_alg_alt (con, args, use_mask, rhs)
- = liftExpr rhs `thenLM` \ (rhs', rhs_info) ->
- returnLM ((con, args, use_mask, rhs'), rhs_info)
-
- lift_prim_alt (lit, rhs)
- = liftExpr rhs `thenLM` \ (rhs', rhs_info) ->
- returnLM ((lit, rhs'), rhs_info)
-
- lift_deflt StgNoDefault = returnLM (StgNoDefault, emptyLiftInfo)
- lift_deflt (StgBindDefault rhs)
- = liftExpr rhs `thenLM` \ (rhs', rhs_info) ->
- returnLM (StgBindDefault rhs', rhs_info)
-\end{code}
-
-Now the interesting cases. Let no escape isn't lifted. We turn it
-back into a let, to play safe, because we have to redo that pass after
-lambda anyway.
-
-\begin{code}
-liftExpr (StgLetNoEscape _ _ (StgNonRec binder rhs) body)
- = dontLiftRhs rhs `thenLM` \ (rhs', rhs_info) ->
- liftExpr body `thenLM` \ (body', body_info) ->
- returnLM (StgLet (StgNonRec binder rhs') body',
- rhs_info `unionLiftInfo` body_info)
-
-liftExpr (StgLetNoEscape _ _ (StgRec pairs) body)
- = liftExpr body `thenLM` \ (body', body_info) ->
- mapAndUnzipLM dontLiftRhs rhss `thenLM` \ (rhss', rhs_infos) ->
- returnLM (StgLet (StgRec (zipEqual "liftExpr" binders rhss')) body',
- foldr unionLiftInfo body_info rhs_infos)
- where
- (binders,rhss) = unzip pairs
-\end{code}
-
-\begin{code}
-liftExpr (StgLet (StgNonRec binder rhs) body)
- | not (isLiftable rhs)
- = dontLiftRhs rhs `thenLM` \ (rhs', rhs_info) ->
- liftExpr body `thenLM` \ (body', body_info) ->
- returnLM (StgLet (StgNonRec binder rhs') body',
- rhs_info `unionLiftInfo` body_info)
-
- | otherwise -- It's a lambda
- = -- Do the body of the let
- fixLM (\ ~(sc_inline, _, _) ->
- addScInlines [binder] [sc_inline] (
- liftExpr body
- ) `thenLM` \ (body', body_info) ->
-
- -- Deal with the RHS
- dontLiftRhs rhs `thenLM` \ (rhs', rhs_info) ->
-
- -- All occurrences in function position, so lambda lift
- getFinalFreeVars (rhsFreeVars rhs) `thenLM` \ final_free_vars ->
-
- mkScPieces final_free_vars (binder,rhs') `thenLM` \ (sc_inline, sc_bind) ->
-
- returnLM (sc_inline,
- body',
- nonRecScBind rhs_info sc_bind `unionLiftInfo` body_info)
-
- ) `thenLM` \ (_, expr', final_info) ->
-
- returnLM (expr', final_info)
-
-liftExpr (StgLet (StgRec pairs) body)
---[Andre-testing]
- | not (all isLiftableRec rhss)
- = liftExpr body `thenLM` \ (body', body_info) ->
- mapAndUnzipLM dontLiftRhs rhss `thenLM` \ (rhss', rhs_infos) ->
- returnLM (StgLet (StgRec (zipEqual "liftExpr2" binders rhss')) body',
- foldr unionLiftInfo body_info rhs_infos)
-
- | otherwise -- All rhss are liftable
- = -- Do the body of the let
- fixLM (\ ~(sc_inlines, _, _) ->
- addScInlines binders sc_inlines (
-
- liftExpr body `thenLM` \ (body', body_info) ->
- mapAndUnzipLM dontLiftRhs rhss `thenLM` \ (rhss', rhs_infos) ->
- let
- -- Find the free vars of all the rhss,
- -- excluding the binders themselves.
- rhs_free_vars = unionVarSets (map rhsFreeVars rhss)
- `minusVarSet`
- mkVarSet binders
-
- rhs_info = unionLiftInfos rhs_infos
- in
- getFinalFreeVars rhs_free_vars `thenLM` \ final_free_vars ->
-
- mapAndUnzipLM (mkScPieces final_free_vars) (binders `zip` rhss')
- `thenLM` \ (sc_inlines, sc_pairs) ->
- returnLM (sc_inlines,
- body',
- recScBind rhs_info sc_pairs `unionLiftInfo` body_info)
-
- )) `thenLM` \ (_, expr', final_info) ->
-
- returnLM (expr', final_info)
- where
- (binders,rhss) = unzip pairs
-\end{code}
-
-\begin{code}
-liftExpr (StgSCC cc expr)
- = liftExpr expr `thenLM` \ (expr2, expr_info) ->
- returnLM (StgSCC cc expr2, expr_info)
-\end{code}
-
-A binding is liftable if it's a *function* (args not null) and never
-occurs in an argument position.
-
-\begin{code}
-isLiftable :: StgRhs -> Bool
-
-isLiftable (StgRhsClosure _ (StgBinderInfo arg_occ _ _ _ unapplied_occ) _ fvs _ args _)
-
- -- Experimental evidence suggests we should lift only if we will be
- -- abstracting up to 4 fvs.
-
- = if not (null args || -- Not a function
- unapplied_occ || -- Has an occ with no args at all
- arg_occ || -- Occurs in arg position
- length fvs > 4 -- Too many free variables
- )
- then {-trace ("LL: " ++ show (length fvs))-} True
- else False
-isLiftable other_rhs = False
-
-isLiftableRec :: StgRhs -> Bool
-
--- this is just the same as for non-rec, except we only lift to
--- abstract up to 1 argument this avoids undoing Static Argument
--- Transformation work
-
-{- Andre's longer comment about isLiftableRec: 1996/01:
-
-A rec binding is "liftable" (according to our heuristics) if:
-* It is a function,
-* all occurrences have arguments,
-* does not occur in an argument position and
-* has up to *2* free variables (including the rec binding variable
- itself!)
-
-The point is: my experiments show that SAT is more important than LL.
-Therefore if we still want to do LL, for *recursive* functions, we do
-not want LL to undo what SAT did. We do this by avoiding LL recursive
-functions that have more than 2 fvs, since if this recursive function
-was created by SAT (we don't know!), it would have at least 3 fvs: one
-for the rec binding itself and 2 more for the static arguments (note:
-this matches with the choice of performing SAT to have at least 2
-static arguments, if we change things there we should change things
-here).
--}
-
-isLiftableRec (StgRhsClosure _ (StgBinderInfo arg_occ _ _ _ unapplied_occ) _ fvs _ args _)
- = if not (null args || -- Not a function
- unapplied_occ || -- Has an occ with no args at all
- arg_occ || -- Occurs in arg position
- length fvs > 2 -- Too many free variables
- )
- then {-trace ("LLRec: " ++ show (length fvs))-} True
- else False
-isLiftableRec other_rhs = False
-
-rhsFreeVars :: StgRhs -> IdSet
-rhsFreeVars (StgRhsClosure _ _ _ fvs _ _ _) = mkVarSet fvs
-rhsFreeVars other = panic "rhsFreeVars"
-\end{code}
-
-dontLiftRhs is like liftExpr, except that it does not lift a top-level
-lambda abstraction. It is used for the right-hand sides of
-definitions where we've decided *not* to lift: for example, top-level
-ones or mutually-recursive ones where not all are lambdas.
-
-\begin{code}
-dontLiftRhs :: StgRhs -> LiftM (StgRhs, LiftInfo)
-
-dontLiftRhs rhs@(StgRhsCon cc v args) = returnLM (rhs, emptyLiftInfo)
-
-dontLiftRhs (StgRhsClosure cc bi srt fvs upd args body)
- = liftExpr body `thenLM` \ (body', body_info) ->
- returnLM (StgRhsClosure cc bi srt fvs upd args body', body_info)
-\end{code}
-
-\begin{code}
-mkScPieces :: IdSet -- Extra args for the supercombinator
- -> (Id, StgRhs) -- The processed RHS and original Id
- -> LiftM ((Id,[Id]), -- Replace abstraction with this;
- -- the set is its free vars
- (Id,StgRhs)) -- Binding for supercombinator
-
-mkScPieces extra_arg_set (id, StgRhsClosure cc bi srt _ upd args body)
- = ASSERT( n_args > 0 )
- -- Construct the rhs of the supercombinator, and its Id
- newSupercombinator sc_ty arity `thenLM` \ sc_id ->
- returnLM ((sc_id, extra_args), (sc_id, sc_rhs))
- where
- n_args = length args
- extra_args = varSetElems extra_arg_set
- arity = n_args + length extra_args
-
- -- Construct the supercombinator type
- type_of_original_id = idType id
- extra_arg_tys = map idType extra_args
- (tyvars, rest) = splitForAllTys type_of_original_id
- sc_ty = mkForAllTys tyvars (mkFunTys extra_arg_tys rest)
-
- sc_rhs = StgRhsClosure cc bi srt [] upd (extra_args ++ args) body
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[Lift-monad]{The LiftM monad}
-%* *
-%************************************************************************
-
-The monad is used only to distribute global stuff, and the unique supply.
-
-\begin{code}
-type LiftM a = Module
- -> LiftFlags
- -> UniqSupply
- -> (IdEnv -- Domain = candidates for lifting
- (Id, -- The supercombinator
- [Id]) -- Args to apply it to
- )
- -> a
-
-
-type LiftFlags = Maybe Int -- No of fvs reqd to float recursive
- -- binding; Nothing == infinity
-
-
-runLM :: Module -> LiftFlags -> UniqSupply -> LiftM a -> a
-runLM mod flags us m = m mod flags us emptyVarEnv
-
-thenLM :: LiftM a -> (a -> LiftM b) -> LiftM b
-thenLM m k mod ci us idenv
- = k (m mod ci us1 idenv) mod ci us2 idenv
- where
- (us1, us2) = splitUniqSupply us
-
-returnLM :: a -> LiftM a
-returnLM a mod ci us idenv = a
-
-fixLM :: (a -> LiftM a) -> LiftM a
-fixLM k mod ci us idenv = r
- where
- r = k r mod ci us idenv
-
-mapLM :: (a -> LiftM b) -> [a] -> LiftM [b]
-mapLM f [] = returnLM []
-mapLM f (a:as) = f a `thenLM` \ r ->
- mapLM f as `thenLM` \ rs ->
- returnLM (r:rs)
-
-mapAndUnzipLM :: (a -> LiftM (b,c)) -> [a] -> LiftM ([b],[c])
-mapAndUnzipLM f [] = returnLM ([],[])
-mapAndUnzipLM f (a:as) = f a `thenLM` \ (b,c) ->
- mapAndUnzipLM f as `thenLM` \ (bs,cs) ->
- returnLM (b:bs, c:cs)
-\end{code}
-
-\begin{code}
-newSupercombinator :: Type
- -> Int -- Arity
- -> LiftM Id
-
-newSupercombinator ty arity mod ci us idenv
- = mkVanillaId (mkTopName uniq mod SLIT("_ll")) ty
- `setIdArityInfo` exactArity arity
- -- ToDo: rm the setIdArity? Just let subsequent stg-saturation pass do it?
- where
- uniq = uniqFromSupply us
-
-
-mkTopName :: Unique -> Module -> FAST_STRING -> Name
- -- Make a top-level name; make it Global if top-level
- -- things should be externally visible; Local otherwise
- -- This chap is only used *after* the tidyCore phase
- -- Notably, it is used during STG lambda lifting
- --
- -- We have to make sure that the name is globally unique
- -- and we don't have tidyCore to help us. So we append
- -- the unique. Hack! Hack!
- -- (Used only by the STG lambda lifter.)
-mkTopName uniq mod fs
- | opt_EnsureSplittableC = mkGlobalName uniq mod occ noSrcLoc
- | otherwise = mkLocalName uniq occ noSrcLoc
- where
- occ = mkVarOcc (_PK_ ((_UNPK_ fs) ++ show uniq))
-
-lookUp :: Id -> LiftM (Id,[Id])
-lookUp v mod ci us idenv
- = case (lookupVarEnv idenv v) of
- Just result -> result
- Nothing -> (v, [])
-
-addScInlines :: [Id] -> [(Id,[Id])] -> LiftM a -> LiftM a
-addScInlines ids values m mod ci us idenv
- = m mod ci us idenv'
- where
- idenv' = extendVarEnvList idenv (ids `zip_lazy` values)
-
- -- zip_lazy zips two things together but matches lazily on the
- -- second argument. This is important, because the ids are know here,
- -- but the things they are bound to are decided only later
- zip_lazy [] _ = []
- zip_lazy (x:xs) ~(y:ys) = (x,y) : zip_lazy xs ys
-
-
--- The free vars reported by the free-var analyser will include
--- some ids, f, which are to be replaced by ($f a b c), where $f
--- is the supercombinator. Hence instead of f being a free var,
--- {a,b,c} are.
---
--- Example
--- let
--- f a = ...y1..y2.....
--- in
--- let
--- g b = ...f...z...
--- in
--- ...
---
--- Here the free vars of g are {f,z}; but f will be lambda-lifted
--- with free vars {y1,y2}, so the "real~ free vars of g are {y1,y2,z}.
-
-getFinalFreeVars :: IdSet -> LiftM IdSet
-
-getFinalFreeVars free_vars mod ci us idenv
- = unionVarSets (map munge_it (varSetElems free_vars))
- where
- munge_it :: Id -> IdSet -- Takes a free var and maps it to the "real"
- -- free var
- munge_it id = case (lookupVarEnv idenv id) of
- Just (_, args) -> mkVarSet args
- Nothing -> unitVarSet id
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[Lift-info]{The LiftInfo type}
-%* *
-%************************************************************************
-
-\begin{code}
-type LiftInfo = Bag StgBinding -- Float to top
-
-emptyLiftInfo = emptyBag
-
-unionLiftInfo :: LiftInfo -> LiftInfo -> LiftInfo
-unionLiftInfo binds1 binds2 = binds1 `unionBags` binds2
-
-unionLiftInfos :: [LiftInfo] -> LiftInfo
-unionLiftInfos infos = foldr unionLiftInfo emptyLiftInfo infos
-
-mkScInfo :: StgBinding -> LiftInfo
-mkScInfo bind = unitBag bind
-
-nonRecScBind :: LiftInfo -- From body of supercombinator
- -> (Id, StgRhs) -- Supercombinator and its rhs
- -> LiftInfo
-nonRecScBind binds (sc_id,sc_rhs) = binds `snocBag` (StgNonRec sc_id sc_rhs)
-
-
--- In the recursive case, all the SCs from the RHSs of the recursive group
--- are dealing with might potentially mention the new, recursive SCs.
--- So we flatten the whole lot into a single recursive group.
-
-recScBind :: LiftInfo -- From body of supercombinator
- -> [(Id,StgRhs)] -- Supercombinator rhs
- -> LiftInfo
-
-recScBind binds pairs = unitBag (co_rec_ify (StgRec pairs : bagToList binds))
-
-co_rec_ify :: [StgBinding] -> StgBinding
-co_rec_ify binds = StgRec (concat (map f binds))
- where
- f (StgNonRec id rhs) = [(id,rhs)]
- f (StgRec pairs) = pairs
-
-
-getScBinds :: LiftInfo -> [StgBinding]
-getScBinds binds = bagToList binds
-\end{code}
\begin{code}
module SRT where
-import Id ( Id, setIdCafInfo, idCafInfo, externallyVisibleId,
- )
-import CoreUtils( idAppIsBottom )
-import IdInfo ( CafInfo(..) )
+import Id ( Id, setIdCafInfo, idCafInfo, externallyVisibleId )
+import CoreUtils ( idAppIsBottom )
+import IdInfo ( CafInfo(..) )
import StgSyn
import UniqFM
import UniqSet
+
+#ifdef DEBUG
+import Outputable
+import Panic
+#endif
\end{code}
\begin{code}
srtExpr rho cont off (StgSCC cc expr) =
srtExpr rho cont off expr =: \(expr, g, srt, off) ->
(StgSCC cc expr, g, srt, off)
+
+#ifdef DEBUG
+srtExpr rho cont off expr = pprPanic "srtExpr" (ppr expr)
+#else
+srtExpr rho cont off expr = panic "srtExpr"
+#endif
\end{code}
-----------------------------------------------------------------------------
import StgSyn
-import LambdaLift ( liftProgram )
import CostCentre ( CostCentre, CostCentreStack )
import SCCfinal ( stgMassageForProfiling )
import StgLint ( lintStgBindings )
import StgStats ( showStgStats )
-import StgVarInfo ( setStgVarInfo )
import SRT ( computeSRTs )
import CmdLineOpts ( DynFlags, DynFlag(..), dopt,
; doIfSet_dyn dflags Opt_D_verbose_stg2stg
(printDump (text "VERBOSE STG-TO-STG:"))
- ; (binds', us', ccs) <- end_pass us "Core2Stg" ([],[],[]) binds
+ ; (binds', us', ccs) <- end_pass us "Stg2Stg" ([],[],[]) binds
-- Do the main business!
; (processed_binds, _, cost_centres)
<- foldl_mn do_stg_pass (binds', us', ccs)
(dopt_StgToDo dflags)
- -- Do essential wind-up
- -- Essential wind-up: part (b), do setStgVarInfo. It has to
- -- happen regardless, because the code generator uses its
- -- decorations.
- --
- -- Why does it have to happen last? Because earlier passes
- -- may move things around, which would change the live-var
- -- info. Also, setStgVarInfo decides about let-no-escape
- -- things, which in turn do a better job if arities are
- -- correct, which is done by satStgRhs.
- --
-
- ; let annotated_binds = setStgVarInfo opt_StgDoLetNoEscapes processed_binds
- srt_binds = computeSRTs annotated_binds
+ ; let srt_binds = computeSRTs processed_binds
; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:"
(pprStgBindingsWithSRTs srt_binds)
(us1, us2) = splitUniqSupply us
in
case to_do of
- StgDoStaticArgs -> panic "STG static argument transformation deleted"
-
D_stg_stats ->
trace (showStgStats binds)
end_pass us2 "StgStats" ccs binds
- StgDoLambdaLift ->
- _scc_ "StgLambdaLift"
- -- NB We have to do setStgVarInfo first!
- let
- binds3 = liftProgram module_name us1 (setStgVarInfo opt_StgDoLetNoEscapes binds)
- in
- end_pass us2 "LambdaLift" ccs binds3
-
StgDoMassageForProfiling ->
_scc_ "ProfMassage"
let
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
-%
-\section[StgVarInfo]{Sets free/live variable info in STG syntax}
-
-And, as we have the info in hand, we may convert some lets to
-let-no-escapes.
-
-\begin{code}
-module StgVarInfo ( setStgVarInfo ) where
-
-#include "HsVersions.h"
-
-import StgSyn
-
-import Id ( isLocalId, setIdArityInfo, idArity, setIdOccInfo, Id )
-import VarSet
-import VarEnv
-import Var
-import IdInfo ( ArityInfo(..), OccInfo(..) )
-import PrimOp ( PrimOp(..), ccallMayGC )
-import TysPrim ( foreignObjPrimTyCon )
-import Type ( splitTyConApp_maybe )
-import Maybes ( maybeToBool, orElse )
-import Name ( getOccName )
-import OccName ( occNameUserString )
-import BasicTypes ( Arity )
-import Outputable
-
-infixr 9 `thenLne`, `thenLne_`
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[live-vs-free-doc]{Documentation}
-%* *
-%************************************************************************
-
-(There is other relevant documentation in codeGen/CgLetNoEscape.)
-
-March 97: setStgVarInfo guarantees to leave every variable's arity correctly
-set. The lambda lifter makes some let-bound variables (which have arities)
-and turns them into lambda-bound ones (which should not, else we get Vap trouble),
-so this guarantee is necessary, as well as desirable.
-
-The arity information is used in the code generator, when deciding if
-a right-hand side is a saturated application so we can generate a VAP
-closure.
-
-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.
-
-%************************************************************************
-%* *
-\subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs}
-%* *
-%************************************************************************
-
-Top-level:
-\begin{code}
-setStgVarInfo :: Bool -- True <=> do let-no-escapes
- -> [StgBinding] -- input
- -> [StgBinding] -- result
-
-setStgVarInfo want_LNEs pgm
- = pgm'
- where
- (pgm', _) = initLne want_LNEs (varsTopBinds pgm)
-
-\end{code}
-
-For top-level guys, we basically aren't worried about this
-live-variable stuff; we do need to keep adding to the environment
-as we step through the bindings (using @extendVarEnv@).
-
-\begin{code}
-varsTopBinds :: [StgBinding] -> LneM ([StgBinding], FreeVarsInfo)
-
-varsTopBinds [] = returnLne ([], emptyFVInfo)
-varsTopBinds (bind:binds)
- = extendVarEnvLne env_extension (
- varsTopBinds binds `thenLne` \ (binds', fv_binds) ->
- varsTopBind binders' fv_binds bind `thenLne` \ (bind', fv_bind) ->
- returnLne ((bind' : binds'),
- (fv_binds `unionFVInfo` fv_bind) `minusFVBinders` binders'
- )
-
- )
- where
- pairs = case bind of
- StgNonRec binder rhs -> [(binder,rhs)]
- StgRec pairs -> pairs
-
- binders' = [ binder `setIdArityInfo` ArityExactly (rhsArity rhs)
- | (binder, rhs) <- pairs
- ]
-
- env_extension = binders' `zip` repeat how_bound
-
- how_bound = LetrecBound
- True {- top level -}
- emptyVarSet
-
-
-varsTopBind :: [Id] -- New binders (with correct arity)
- -> FreeVarsInfo -- Info about the body
- -> StgBinding
- -> LneM (StgBinding, FreeVarsInfo)
-
-varsTopBind [binder'] body_fvs (StgNonRec binder rhs)
- = varsRhs body_fvs (binder,rhs) `thenLne` \ (rhs2, fvs, _) ->
- returnLne (StgNonRec binder' rhs2, fvs)
-
-varsTopBind binders' body_fvs (StgRec pairs)
- = fixLne (\ ~(_, rec_rhs_fvs) ->
- let
- scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
- in
- mapAndUnzip3Lne (varsRhs scope_fvs) pairs `thenLne` \ (rhss2, fvss, _) ->
- let
- fvs = unionFVInfos fvss
- in
- returnLne (StgRec (binders' `zip` rhss2), fvs)
- )
-
-\end{code}
-
-\begin{code}
-varsRhs :: FreeVarsInfo -- Free var info for the scope of the binding
- -> (Id,StgRhs)
- -> LneM (StgRhs, FreeVarsInfo, EscVarsSet)
-
-varsRhs scope_fv_info (binder, StgRhsCon cc con args)
- = varsAtoms args `thenLne` \ (args', fvs) ->
- returnLne (StgRhsCon cc con args', fvs, getFVSet fvs)
-
-varsRhs scope_fv_info (binder, StgRhsClosure cc _ srt _ upd args body)
- = extendVarEnvLne [ (zapArity a, LambdaBound) | a <- args ] (
- do_body args body `thenLne` \ (body2, body_fvs, body_escs) ->
- let
- set_of_args = mkVarSet args
- rhs_fvs = body_fvs `minusFVBinders` args
- rhs_escs = body_escs `minusVarSet` set_of_args
- binder_info = lookupFVInfo scope_fv_info binder
- upd' | null args && isPAP body2 = ReEntrant
- | otherwise = upd
- in
- returnLne (StgRhsClosure cc binder_info srt (getFVs rhs_fvs) upd'
- args body2, rhs_fvs, rhs_escs)
- )
- where
- -- Pick out special case of application in body of thunk
- do_body [] (StgApp f args) = varsApp (Just upd) f args
- do_body _ other_body = varsExpr other_body
-\end{code}
-
-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}
-isPAP (StgApp f args) = idArity f > length args
-isPAP _ = False
-\end{code}
-
-\begin{code}
-varsAtoms :: [StgArg]
- -> LneM ([StgArg], FreeVarsInfo)
- -- It's not *really* necessary to return fresh arguments,
- -- because the only difference is that the argument variable
- -- arities are correct. But it seems safer to do so.
-
-varsAtoms atoms
- = mapAndUnzipLne var_atom atoms `thenLne` \ (args', fvs_lists) ->
- returnLne (args', unionFVInfos fvs_lists)
- where
- var_atom a@(StgVarArg v)
- = lookupVarLne v `thenLne` \ (v', how_bound) ->
- returnLne (StgVarArg v', singletonFVInfo v' how_bound stgArgOcc)
- var_atom a = returnLne (a, emptyFVInfo)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[expr-StgVarInfo]{Setting variable info on expressions}
-%* *
-%************************************************************************
-
-@varsExpr@ carries in a monad-ised environment, which binds each
-let(rec) variable (ie non top level, not imported, not lambda bound,
-not case-alternative bound) to:
- - its STG arity, and
- - its set of live vars.
-For normal variables the set of live vars is just the variable
-itself. For let-no-escaped variables, the set of live vars is the set
-live at the moment the variable is entered. The set is guaranteed to
-have no further let-no-escaped vars in it.
-
-\begin{code}
-varsExpr :: StgExpr
- -> LneM (StgExpr, -- Decorated 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}
-
-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}
-varsExpr (StgLit l) = returnLne (StgLit l, emptyFVInfo, emptyVarSet)
-
-varsExpr (StgApp f args) = varsApp Nothing f args
-
-varsExpr (StgConApp con args)
- = varsAtoms args `thenLne` \ (args', args_fvs) ->
- returnLne (StgConApp con args', args_fvs, getFVSet args_fvs)
-
-varsExpr (StgPrimApp op args res_ty)
- = varsAtoms args `thenLne` \ (args', args_fvs) ->
- returnLne (StgPrimApp op args' res_ty, args_fvs, getFVSet args_fvs)
-
-varsExpr (StgSCC cc expr)
- = varsExpr expr `thenLne` ( \ (expr2, fvs, escs) ->
- returnLne (StgSCC cc expr2, fvs, escs) )
-\end{code}
-
-Cases require a little more real work.
-\begin{code}
-varsExpr (StgCase scrut _ _ bndr srt alts)
- = getVarsLiveInCont `thenLne` \ live_in_cont ->
- extendVarEnvLne [(zapArity bndr, CaseBound)] (
- vars_alts alts `thenLne` \ (alts2, alts_fvs, alts_escs) ->
- lookupLiveVarsForSet alts_fvs `thenLne` \ alts_lvs ->
- let
- -- determine whether the default binder is dead or not
- bndr'= if (bndr `elementOfFVInfo` alts_fvs)
- then bndr `setIdOccInfo` NoOccInfo
- else bndr `setIdOccInfo` IAmDead
-
- -- for a _ccall_GC_, some of the *arguments* need to live across the
- -- call (see findLiveArgs comments.), so we annotate them as being live
- -- in the alts to achieve the desired effect.
- mb_live_across_case =
- case scrut of
- StgPrimApp (CCallOp ccall) args _
- | ccallMayGC ccall
- -> Just (foldl findLiveArgs emptyVarSet args)
- _ -> Nothing
-
- -- 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 = orElse (FMAP unionVarSet mb_live_across_case) id $
- live_in_cont `unionVarSet`
- (alts_lvs `minusVarSet` unitVarSet bndr)
- in
- -- we tell the scrutinee that everything live in the alts
- -- is live in it, too.
- setVarsLiveInCont live_in_alts (
- varsExpr scrut
- ) `thenLne` \ (scrut2, scrut_fvs, scrut_escs) ->
- lookupLiveVarsForSet scrut_fvs `thenLne` \ scrut_lvs ->
- let
- live_in_whole_case = live_in_alts `unionVarSet` scrut_lvs
- in
- returnLne (
- StgCase scrut2 live_in_whole_case live_in_alts bndr' srt alts2,
- (scrut_fvs `unionFVInfo` alts_fvs)
- `minusFVBinders` [bndr],
- (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
- vars_alts (StgAlgAlts tycon alts deflt)
- = 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 (
- StgAlgAlts tycon alts2 deflt2,
- alts_fvs `unionFVInfo` deflt_fvs,
- alts_escs `unionVarSet` deflt_escs
- )
- where
- vars_alg_alt (con, binders, worthless_use_mask, rhs)
- = extendVarEnvLne [(zapArity b, CaseBound) | b <- binders] (
- varsExpr 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),
- rhs_fvs `minusFVBinders` binders,
- rhs_escs `minusVarSet` mkVarSet binders -- ToDo: remove the minusVarSet;
- -- since escs won't include
- -- any of these binders
- ))
-
- vars_alts (StgPrimAlts tycon alts deflt)
- = 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 (
- StgPrimAlts tycon alts2 deflt2,
- alts_fvs `unionFVInfo` deflt_fvs,
- alts_escs `unionVarSet` deflt_escs
- )
- where
- vars_prim_alt (lit, rhs)
- = varsExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
- returnLne ((lit, rhs2), rhs_fvs, rhs_escs)
-
- vars_deflt StgNoDefault
- = returnLne (StgNoDefault, emptyFVInfo, emptyVarSet)
-
- vars_deflt (StgBindDefault rhs)
- = varsExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
- returnLne ( StgBindDefault rhs2, rhs_fvs, rhs_escs )
-\end{code}
-
-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}
-varsExpr (StgLetNoEscape _ _ _ _) = panic "varsExpr: unexpected StgLetNoEscape"
-
-varsExpr (StgLet bind body)
- = isSwitchSetLne {-StgDoLetNoEscapes-} `thenLne` \ want_LNEs ->
-
- (fixLne (\ ~(_, _, _, no_binder_escapes) ->
- let
- non_escaping_let = want_LNEs && no_binder_escapes
- in
- vars_let non_escaping_let bind body
- )) `thenLne` \ (new_let, fvs, escs, _) ->
-
- returnLne (new_let, fvs, escs)
-\end{code}
-
-If we've got a case containing a _ccall_GC_ primop, we need to
-ensure that the arguments are kept live for the duration of the
-call. This only an issue
-
-\begin{code}
-findLiveArgs :: StgLiveVars -> StgArg -> StgLiveVars
-findLiveArgs lvs (StgVarArg x)
- | isForeignObjPrimTy (idType x) = extendVarSet lvs x
- | otherwise = lvs
-findLiveArgs lvs arg = lvs
-
-isForeignObjPrimTy ty
- = case splitTyConApp_maybe ty of
- Just (tycon, _) -> tycon == foreignObjPrimTyCon
- Nothing -> False
-\end{code}
-
-
-Applications:
-\begin{code}
-varsApp :: Maybe UpdateFlag -- Just upd <=> this application is
- -- the rhs of a thunk binding
- -- x = [...] \upd [] -> the_app
- -- with specified update flag
- -> Id -- Function
- -> [StgArg] -- Arguments
- -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
-
-varsApp maybe_thunk_body f args
- = getVarsLiveInCont `thenLne` \ live_in_cont ->
-
- varsAtoms args `thenLne` \ (args', args_fvs) ->
-
- lookupVarLne f `thenLne` \ (f', how_bound) ->
-
- let
- n_args = length args
- not_letrec_bound = not (isLetrecBound how_bound)
- f_arity = idArity f' -- Will have an exact arity by now
- fun_fvs = singletonFVInfo f' how_bound fun_occ
-
- fun_occ
- | not_letrec_bound = NoStgBinderInfo -- Uninteresting variable
-
- -- Otherwise it is letrec bound; must have its arity
- | n_args == 0 = stgFakeFunAppOcc -- Function Application
- -- with no arguments.
- -- used by the lambda lifter.
- | f_arity > n_args = stgUnsatOcc -- Unsaturated
-
-
- | f_arity == n_args &&
- maybeToBool maybe_thunk_body -- Exactly saturated,
- -- and rhs of thunk
- = case maybe_thunk_body of
- Just Updatable -> stgStdHeapOcc
- Just SingleEntry -> stgNoUpdHeapOcc
- other -> panic "varsApp"
-
- | otherwise = stgNormalOcc
- -- Record only that it occurs free
-
- myself = unitVarSet f'
-
- fun_escs | not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting
- | f_arity == n_args = emptyVarSet -- Function doesn't escape
- | otherwise = myself -- 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.
-
- -- XXX not needed?
- -- live_at_call
- -- = live_in_cont `unionVarSet` case how_bound of
- -- LetrecBound _ lvs -> lvs `minusVarSet` myself
- -- other -> emptyVarSet
- in
- returnLne (
- StgApp f' args',
- 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.
- )
-\end{code}
-
-The magic for lets:
-\begin{code}
-vars_let :: Bool -- True <=> yes, we are let-no-escaping this let
- -> StgBinding -- bindings
- -> StgExpr -- 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
-
-vars_let let_no_escape bind body
- = fixLne (\ ~(_, _, _, rec_bind_lvs, _, 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 emptyVarSet)
- (vars_bind rec_bind_lvs rec_body_fvs bind)
- `thenLne` \ (bind2, bind_fvs, bind_escs, env_ext) ->
-
- -- The live variables of this binding are the ones which are live
- -- by virtue of being accessible via the free vars of the binding (lvs_from_fvs)
- -- together with the live_in_cont ones
- lookupLiveVarsForSet (bind_fvs `minusFVBinders` binders) `thenLne` \ lvs_from_fvs ->
- let
- bind_lvs = lvs_from_fvs `unionVarSet` live_in_cont
- in
-
- -- bind_fvs and bind_escs still include the binders of the let(rec)
- -- but bind_lvs does not
-
- -- Do the body
- extendVarEnvLne env_ext (
- varsExpr body `thenLne` \ (body2, body_fvs, body_escs) ->
- lookupLiveVarsForSet body_fvs `thenLne` \ body_lvs ->
-
- returnLne (bind2, bind_fvs, bind_escs, bind_lvs,
- body2, body_fvs, body_escs, body_lvs)
-
- )) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs,
- 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
- = (bind_fvs `unionFVInfo` body_fvs) `minusFVBinders` binders
-
- 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
- StgNonRec binder rhs -> [binder]
- StgRec pairs -> map fst pairs
-
- mk_binding bind_lvs (binder,rhs)
- = (binder `setIdArityInfo` ArityExactly (stgArity rhs),
- LetrecBound False -- Not top level
- live_vars
- )
- where
- live_vars = if let_no_escape then
- extendVarSet bind_lvs binder
- else
- unitVarSet binder
-
- vars_bind :: StgLiveVars
- -> FreeVarsInfo -- Free var info for body of binding
- -> StgBinding
- -> LneM (StgBinding,
- FreeVarsInfo, EscVarsSet, -- free vars; escapee vars
- [(Id, HowBound)])
- -- extension to environment
-
- vars_bind rec_bind_lvs rec_body_fvs (StgNonRec binder rhs)
- = varsRhs rec_body_fvs (binder,rhs) `thenLne` \ (rhs2, fvs, escs) ->
- let
- env_ext_item@(binder', _) = mk_binding rec_bind_lvs (binder,rhs)
- in
- returnLne (StgNonRec binder' rhs2, fvs, escs, [env_ext_item])
-
- vars_bind rec_bind_lvs rec_body_fvs (StgRec pairs)
- = let
- env_ext = map (mk_binding rec_bind_lvs) pairs
- binders' = map fst env_ext
- in
- extendVarEnvLne env_ext (
- fixLne (\ ~(_, rec_rhs_fvs, _, _) ->
- let
- rec_scope_fvs = unionFVInfo rec_body_fvs rec_rhs_fvs
- in
- mapAndUnzip3Lne (varsRhs rec_scope_fvs) pairs `thenLne` \ (rhss2, fvss, escss) ->
- let
- fvs = unionFVInfos fvss
- escs = unionVarSets escss
- in
- returnLne (StgRec (binders' `zip` rhss2), fvs, escs, 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}
-
-%************************************************************************
-%* *
-\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 {\em down}.
-
-\begin{code}
-type LneM a = Bool -- True <=> do let-no-escapes
- -> IdEnv (Id, HowBound) -- Use the Id at all occurrences; it has correct
- -- arity information inside it.
- -> StgLiveVars -- vars live in continuation
- -> a
-
-data HowBound
- = ImportBound
- | CaseBound
- | LambdaBound
- | LetrecBound
- Bool -- True <=> bound at top level
- StgLiveVars -- Live vars... see notes below
-
-isLetrecBound (LetrecBound _ _) = True
-isLetrecBound other = False
-\end{code}
-
-For a let(rec)-bound variable, x, we record what varibles 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 LetrecBound constructor; x itself *is* included.
-
-The std monad functions:
-\begin{code}
-initLne :: Bool -> LneM a -> a
-initLne want_LNEs m = m want_LNEs emptyVarEnv emptyVarSet
-
-{-# INLINE thenLne #-}
-{-# INLINE thenLne_ #-}
-{-# INLINE returnLne #-}
-
-returnLne :: a -> LneM a
-returnLne e sw env lvs_cont = e
-
-thenLne :: LneM a -> (a -> LneM b) -> LneM b
-thenLne m k sw env lvs_cont
- = case (m sw env lvs_cont) of
- m_result -> k m_result sw env lvs_cont
-
-thenLne_ :: LneM a -> LneM b -> LneM b
-thenLne_ m k sw env lvs_cont
- = case (m sw env lvs_cont) of
- _ -> k sw env lvs_cont
-
-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)
-
-mapAndUnzipLne :: (a -> LneM (b,c)) -> [a] -> LneM ([b],[c])
-
-mapAndUnzipLne f [] = returnLne ([],[])
-mapAndUnzipLne f (x:xs)
- = f x `thenLne` \ (r1, r2) ->
- mapAndUnzipLne f xs `thenLne` \ (rs1, rs2) ->
- returnLne (r1:rs1, r2:rs2)
-
-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 sw env lvs_cont = result
- where
- result = expr result sw env lvs_cont
--- ^^^^^^ ------ ^^^^^^
-\end{code}
-
-Functions specific to this monad:
-\begin{code}
-isSwitchSetLne :: LneM Bool
-isSwitchSetLne want_LNEs env lvs_cont
- = want_LNEs
-
-getVarsLiveInCont :: LneM StgLiveVars
-getVarsLiveInCont sw env lvs_cont = lvs_cont
-
-setVarsLiveInCont :: StgLiveVars -> LneM a -> LneM a
-setVarsLiveInCont new_lvs_cont expr sw env lvs_cont
- = expr sw env new_lvs_cont
-
-extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
-extendVarEnvLne ids_w_howbound expr sw env lvs_cont
- = expr sw (extendVarEnvList env [(id, pair) | pair@(id,_) <- ids_w_howbound]) lvs_cont
-
-
-lookupVarLne :: Id -> LneM (Id, HowBound)
-lookupVarLne v sw env lvs_cont
- = returnLne (
- case (lookupVarEnv env v) of
- Just xx -> xx
- Nothing -> --false:ASSERT(not (isLocallyDefined v))
- (v, ImportBound)
- ) sw 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.
-
-lookupLiveVarsForSet :: FreeVarsInfo -> LneM StgLiveVars
-
-lookupLiveVarsForSet fvs sw env lvs_cont
- = returnLne (unionVarSets (map do_one (getFVs fvs)))
- sw env lvs_cont
- where
- do_one v
- = if isLocalId v then
- case (lookupVarEnv env v) of
- Just (_, LetrecBound _ lvs) -> extendVarSet lvs v
- Just _ -> unitVarSet v
- Nothing -> pprPanic "lookupVarEnv/do_one:" (ppr v)
- else
- emptyVarSet
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[Free-var info]{Free variable information}
-%* *
-%************************************************************************
-
-\begin{code}
-type FreeVarsInfo = IdEnv (Id, Bool, StgBinderInfo)
- -- If f is mapped to NoStgBinderInfo, that means
- -- that f *is* mentioned (else it wouldn't be in the
- -- IdEnv at all), but only in a saturated applications.
- --
- -- All case/lambda-bound things are also mapped to
- -- NoStgBinderInfo, since we aren't interested in their
- -- occurence info.
- --
- -- The Bool is True <=> the Id is top level letrec bound
-
-type EscVarsSet = IdSet
-\end{code}
-
-\begin{code}
-emptyFVInfo :: FreeVarsInfo
-emptyFVInfo = emptyVarEnv
-
-singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
-singletonFVInfo id ImportBound info = emptyVarEnv
-singletonFVInfo id (LetrecBound top_level _) info = unitVarEnv id (id, top_level, info)
-singletonFVInfo id other info = unitVarEnv id (id, False, info)
-
-unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
-unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
-
-unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
-unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
-
-minusFVBinders :: FreeVarsInfo -> [Id] -> FreeVarsInfo
-minusFVBinders fv ids = fv `delVarEnvList` ids
-
-elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
-elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
-
-lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
-lookupFVInfo fvs id = case lookupVarEnv fvs id of
- Nothing -> NoStgBinderInfo
- Just (_,_,info) -> info
-
-getFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only
-getFVs fvs = [id | (id,False,_) <- rngVarEnv fvs]
-
-getFVSet :: FreeVarsInfo -> IdSet
-getFVSet fvs = mkVarSet (getFVs fvs)
-
-plusFVInfo (id1,top1,info1) (id2,top2,info2)
- = ASSERT (id1 == id2 && top1 == top2)
- (id1, top1, combineStgBinderInfo info1 info2)
-\end{code}
-
-\begin{code}
-rhsArity :: StgRhs -> Arity
-rhsArity (StgRhsCon _ _ _) = 0
-rhsArity (StgRhsClosure _ _ _ _ _ args _) = length args
-
-zapArity :: Id -> Id
-zapArity id = id `setIdArityInfo` UnknownArity
-\end{code}
-
-
-
let binds' = initSM us (go binds `thenSM` \ (binds', uds') ->
returnSM (dumpAllDictBinds uds' binds'))
- endPass dflags "Specialise"
- (dopt Opt_D_dump_spec dflags
- || dopt Opt_D_verbose_core2core dflags) binds'
+ endPass dflags "Specialise" Opt_D_dump_spec binds'
dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
(vcat (map dump_specs (concat (map bindersOf binds'))))
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
-%************************************************************************
-%* *
-\section[CoreToStg]{Converting core syntax to STG syntax}
-%* *
-%************************************************************************
+\section[CoreToStg]{Converts Core to STG Syntax}
-Convert a @CoreSyntax@ program to a @StgSyntax@ program.
+And, as we have the info in hand, we may convert some lets to
+let-no-escapes.
\begin{code}
-module CoreToStg ( topCoreBindsToStg, coreToStgExpr ) where
+module CoreToStg ( coreToStg, coreExprToStg ) where
#include "HsVersions.h"
-import CoreSyn -- input
-import StgSyn -- output
+import CoreSyn
+import CoreFVs
+import CoreUtils
+import SimplUtils
+import StgSyn
-import CoreUtils ( exprType )
-import SimplUtils ( findDefault )
-import CostCentre ( noCCS )
-import Id ( Id, mkSysLocal, idType, idStrictness,
- mkVanillaId, idName, idDemandInfo, idArity, setIdType,
- idFlavour
- )
-import Module ( Module )
-import IdInfo ( StrictnessInfo(..), IdFlavour(..) )
-import DataCon ( dataConWrapId, dataConTyCon )
+import Type
import TyCon ( isAlgTyCon )
-import Demand ( Demand, isStrict, wwLazy )
-import Name ( setNameUnique, globaliseName, isLocalName, isGlobalName )
+import Id
+import IdInfo
+import DataCon
+import CostCentre ( noCCS )
+import VarSet
import VarEnv
-import PrimOp ( PrimOp(..), setCCallUnique )
-import Type ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe,
- applyTy, repType, seqType, splitTyConApp_maybe, splitTyConApp,
- splitRepFunTys, mkFunTys,
- uaUTy, usOnce, usMany, isTyVarTy
- )
-import UniqSupply -- all of it, really
-import UniqSet ( emptyUniqSet )
-import ErrUtils ( showPass, dumpIfSet_dyn )
-import CmdLineOpts ( DynFlags, DynFlag(..) )
-import Maybes
+import DataCon ( dataConWrapId )
+import IdInfo ( OccInfo(..) )
+import PrimOp ( PrimOp(..), ccallMayGC )
+import TysPrim ( foreignObjPrimTyCon )
+import Maybes ( maybeToBool, orElse )
+import Name ( getOccName )
+import Module ( Module )
+import OccName ( occNameUserString )
+import BasicTypes ( TopLevelFlag(..), isNotTopLevel )
+import CmdLineOpts ( DynFlags )
import Outputable
-\end{code}
-
-
- *************************************************
- *************** OVERVIEW *********************
- *************************************************
-
-
-The business of this pass is to convert Core to Stg. On the way it
-does some important transformations:
-
-1. We discard type lambdas and applications. In so doing we discard
- "trivial" bindings such as
- x = y t1 t2
- where t1, t2 are types
-
-2. We get the program into "A-normal form". In particular:
-
- f E ==> let x = E in f x
- OR ==> case E of x -> f x
-
- where E is a non-trivial expression.
- Which transformation is used depends on whether f is strict or not.
- [Previously the transformation to case used to be done by the
- simplifier, but it's better done here. It does mean that f needs
- to have its strictness info correct!.]
-
- Similarly, convert any unboxed let's into cases.
- [I'm experimenting with leaving 'ok-for-speculation' rhss in let-form
- right up to this point.]
-
-3. We clone all local binders. The code generator uses the uniques to
- name chunks of code for thunks, so it's important that the names used
- are globally unique, not simply not-in-scope, which is all that
- the simplifier ensures.
-
-4. If we are going to do object-file splitting, we make ALL top-level
- names into Globals. Why?
-
- In certain (prelude only) modules we split up the .hc file into
- lots of separate little files, which are separately compiled by the C
- compiler. That gives lots of little .o files. The idea is that if
- you happen to mention one of them you don't necessarily pull them all
- in. (Pulling in a piece you don't need can be v bad, because it may
- mention other pieces you don't need either, and so on.)
-
- Sadly, splitting up .hc files means that local names (like s234) are
- now globally visible, which can lead to clashes between two .hc
- files. So we make them all Global, so they are printed complete
- with their module name.
-
- We don't want to do this in CoreTidy, because at that stage we use
- Global to mean "external" and hence "should appear in interface files".
- This object-file splitting thing is a code generator matter that we
- don't want to pollute earlier phases.
-
-NOTE THAT:
-
-* We don't pin on correct arities any more, because they can be mucked up
- by the lambda lifter. In particular, the lambda lifter can take a local
- letrec-bound variable and make it a lambda argument, which shouldn't have
- an arity. So SetStgVarInfo sets arities now.
-
-* 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.
-
-[Quite a bit of stuff that used to be here has moved
- to tidyCorePgm (SimplCore.lhs) SLPJ Nov 96]
-
-
-%************************************************************************
-%* *
-\subsection[coreToStg-programs]{Converting a core program and core bindings}
-%* *
-%************************************************************************
-
-March 98: We keep a small environment to give all locally bound
-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 = NoBindF
- | RecF [(Id, StgRhs)]
- | NonRecF
- Id
- StgExpr -- *Can* be a StgLam
- RhsDemand
- [StgFloatBind]
-
--- The interesting one is the NonRecF
--- NonRecF x rhs demand binds
--- means
--- x = let binds in rhs
--- (or possibly case etc if x demand is strict)
--- The binds are kept separate so they can be floated futher
--- if appropriate
-\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
- }
-
-mkDem :: Demand -> Bool -> RhsDemand
-mkDem strict once = RhsDemand (isStrict strict) once
-
-mkDemTy :: Demand -> Type -> RhsDemand
-mkDemTy strict ty = RhsDemand (isStrict strict) (isOnceTy ty)
-
-isOnceTy :: Type -> Bool
-isOnceTy ty
- =
-#ifdef USMANY
- opt_UsageSPOn && -- can't expect annotations if -fusagesp is off
-#endif
- once
- where
- u = uaUTy ty
- once | u == usOnce = True
- | u == usMany = False
- | isTyVarTy u = False -- if unknown at compile-time, is Top ie usMany
-
-bdrDem :: Id -> RhsDemand
-bdrDem id = mkDem (idDemandInfo id) (isOnceTy (idType id))
-
-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
-later. For this pass
-we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders.
-
-When printing out the Stg we need non-bottom values in these
-locations.
-
-\begin{code}
-bOGUS_LVs :: StgLiveVars
-bOGUS_LVs = emptyUniqSet
-
-bOGUS_FVs :: [Id]
-bOGUS_FVs = []
-\end{code}
-\begin{code}
-topCoreBindsToStg :: DynFlags -> Module -> [CoreBind] -> IO [StgBinding]
-topCoreBindsToStg dflags mod core_binds
- = do showPass dflags "Core2Stg"
- us <- mkSplitUniqSupply 'c'
- return (initUs_ us (coreBindsToStg emptyVarEnv core_binds))
- where
- top_flag = Top mod
-
- coreBindsToStg :: StgEnv -> [CoreBind] -> UniqSM [StgBinding]
-
- coreBindsToStg env [] = returnUs []
- coreBindsToStg env (b:bs)
- = coreBindToStg top_flag env b `thenUs` \ (bind_spec, new_env) ->
- coreBindsToStg new_env bs `thenUs` \ new_bs ->
- case bind_spec of
- NonRecF bndr rhs dem floats
- -> ASSERT2( not (isStrictDem dem) &&
- not (isUnLiftedType (idType bndr)),
- ppr b ) -- No top-level cases!
-
- mkStgBinds floats rhs `thenUs` \ new_rhs ->
- returnUs (StgNonRec bndr (exprToRhs dem top_flag new_rhs)
- : new_bs)
- -- Keep all the floats inside...
- -- Some might be cases etc
- -- We might want to revisit this decision
-
- RecF prs -> returnUs (StgRec prs : new_bs)
- NoBindF -> pprTrace "topCoreBindsToStg" (ppr b) $
- returnUs new_bs
+infixr 9 `thenLne`, `thenLne_`
\end{code}
%************************************************************************
%* *
-\subsection[coreToStgExpr]{Converting an expression (for the interpreter)}
+\subsection[live-vs-free-doc]{Documentation}
%* *
%************************************************************************
-\begin{code}
-coreToStgExpr :: DynFlags -> CoreExpr -> IO StgExpr
-coreToStgExpr dflags core_expr
- = do showPass dflags "Core2Stg"
- us <- mkSplitUniqSupply 'c'
- let stg_expr = initUs_ us (coreExprToStg emptyVarEnv core_expr)
- dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:" (ppr stg_expr)
- return stg_expr
-\end{code}
+(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.
%************************************************************************
%* *
-\subsection[coreToStg-binds]{Converting bindings}
+\subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs}
%* *
%************************************************************************
\begin{code}
-coreBindToStg :: TopLvl -> StgEnv -> CoreBind -> UniqSM (StgFloatBind, StgEnv)
-
-coreBindToStg top_lev env (NonRec binder rhs)
- = coreExprToStgFloat env rhs `thenUs` \ (floats, stg_rhs) ->
- case (floats, stg_rhs) of
- ([], StgApp var [])
- | not (isGlobalName (idName binder))
- -> returnUs (NoBindF, extendVarEnv env binder var)
-
- | otherwise
- -> newBinder top_lev env binder `thenUs` \ (new_env, new_binder) ->
- returnUs (NonRecF new_binder stg_rhs dem floats, extendVarEnv new_env binder var)
- -- A trivial binding let x = y in ...
- -- can arise if postSimplExpr floats a NoRep literal out
- -- so it seems sensible to deal with it well.
- -- But we don't want to discard exported things. They can
- -- occur; e.g. an exported user binding f = g
-
- other -> newBinder top_lev env binder `thenUs` \ (new_env, new_binder) ->
- returnUs (NonRecF new_binder stg_rhs dem floats, new_env)
- where
- dem = bdrDem binder
-
-
-coreBindToStg top_lev env (Rec pairs)
- = newBinders top_lev env binders `thenUs` \ (env', binders') ->
- mapUs (do_rhs env') pairs `thenUs` \ stg_rhss ->
- returnUs (RecF (binders' `zip` stg_rhss), env')
- where
- binders = map fst pairs
- do_rhs env (bndr,rhs) = coreExprToStgFloat env rhs `thenUs` \ (floats, stg_expr) ->
- mkStgBinds floats stg_expr `thenUs` \ stg_expr' ->
- -- NB: stg_expr' might still be a StgLam (and we want that)
- returnUs (exprToRhs (bdrDem bndr) top_lev stg_expr')
+coreToStg :: DynFlags -> Module -> [CoreBind] -> IO [StgBinding]
+coreToStg dflags this_mod pgm
+ = return (fst (initLne (coreTopBindsToStg pgm)))
+
+coreExprToStg :: CoreExpr -> StgExpr
+coreExprToStg expr
+ = new_expr where (new_expr,_,_) = initLne (coreToStgExpr expr)
+
+-- For top-level guys, we basically aren't worried about this
+-- live-variable stuff; we do need to keep adding to the environment
+-- as we step through the bindings (using @extendVarEnv@).
+
+coreTopBindsToStg :: [CoreBind] -> LneM ([StgBinding], FreeVarsInfo)
+
+coreTopBindsToStg [] = returnLne ([], emptyFVInfo)
+coreTopBindsToStg (bind:binds)
+ = let
+ binders = bindersOf bind
+ env_extension = binders `zip` repeat how_bound
+ how_bound = LetrecBound True {- top level -}
+ emptyVarSet
+ in
+
+ extendVarEnvLne env_extension (
+ coreTopBindsToStg binds `thenLne` \ (binds', fv_binds) ->
+ coreTopBindToStg binders fv_binds bind `thenLne` \ (bind', fv_bind) ->
+ returnLne (
+ (bind' : binds'),
+ (fv_binds `unionFVInfo` fv_bind) `minusFVBinders` binders
+ )
+ )
+
+
+coreTopBindToStg
+ :: [Id] -- New binders (with correct arity)
+ -> FreeVarsInfo -- Info about the body
+ -> CoreBind
+ -> LneM (StgBinding, FreeVarsInfo)
+
+coreTopBindToStg [binder] body_fvs (NonRec _ rhs)
+ = coreToStgRhs body_fvs TopLevel (binder,rhs) `thenLne` \ (rhs2, fvs, _) ->
+ returnLne (StgNonRec binder rhs2, fvs)
+
+coreTopBindToStg binders body_fvs (Rec pairs)
+ = fixLne (\ ~(_, rec_rhs_fvs) ->
+ let scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
+ in
+ mapAndUnzip3Lne (coreToStgRhs scope_fvs TopLevel) pairs
+ `thenLne` \ (rhss2, fvss, _) ->
+ let fvs = unionFVInfos fvss
+ in
+ returnLne (StgRec (binders `zip` rhss2), fvs)
+ )
\end{code}
-
-%************************************************************************
-%* *
-\subsection[coreToStg-rhss]{Converting right hand sides}
-%* *
-%************************************************************************
-
\begin{code}
-exprToRhs :: RhsDemand -> TopLvl -> StgExpr -> StgRhs
-exprToRhs dem _ (StgLam _ bndrs body)
- = ASSERT( not (null bndrs) )
- StgRhsClosure noCCS
- stgArgOcc
- noSRT
- bOGUS_FVs
- ReEntrant -- binders is non-empty
- bndrs
- body
-
-{-
- We reject the following candidates for 'static constructor'dom:
-
- - any dcon that takes a lit-lit as an arg.
- - [Win32 DLLs only]: any dcon that resides in a DLL
- (or takes as arg something that is.)
-
- These constraints are necessary to ensure that the code
- generated in the end for the static constructors, which
- live in the data segment, remain valid - i.e., it has to
- be constant. For obvious reasons, that's hard to guarantee
- with lit-lits. The second case of a constructor referring
- to static closures hiding out in some DLL is an artifact
- of the way Win32 DLLs handle global DLL variables. A (data)
- symbol exported from a DLL has to be accessed through a
- level of indirection at the site of use, so whereas
-
- extern StgClosure y_closure;
- extern StgClosure z_closure;
- x = { ..., &y_closure, &z_closure };
-
- is legal when the symbols are in scope at link-time, it is
- not when y_closure is in a DLL. So, any potential static
- closures that refers to stuff that's residing in a DLL
- will be put in an (updateable) thunk instead.
-
- An alternative strategy is to support the generation of
- constructors (ala C++ static class constructors) which will
- then be run at load time to fix up static closures.
--}
-exprToRhs dem toplev (StgConApp con args)
- | isNotTop toplev || not (isDllConApp con args)
- -- isDllConApp checks for LitLit args too
- = StgRhsCon noCCS con args
-
-exprToRhs dem toplev expr
- = upd `seq`
- StgRhsClosure noCCS -- No cost centre (ToDo?)
- stgArgOcc -- safe
- noSRT -- figure out later
- bOGUS_FVs
- upd
- []
- expr
- where
- upd = if isOnceDem dem
- then (if isNotTop toplev
- then SingleEntry -- HA! Paydirt for "dem"
- else
+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) ->
+ case new_rhs of
+
+ StgLam _ bndrs body
+ -> let binder_info = lookupFVInfo scope_fv_info binder
+ in returnLne (StgRhsClosure noCCS
+ binder_info
+ noSRT
+ (getFVs rhs_fvs)
+ ReEntrant
+ bndrs
+ body,
+ rhs_fvs, rhs_escs)
+
+ StgConApp con args
+ | isNotTopLevel top || not (isDllConApp con args)
+ -> returnLne (StgRhsCon noCCS con args, rhs_fvs, rhs_escs)
+
+ _other_expr
+ -> let binder_info = lookupFVInfo scope_fv_info binder
+ in returnLne (StgRhsClosure noCCS
+ binder_info
+ noSRT
+ (getFVs rhs_fvs)
+ (updatable [] new_rhs)
+ []
+ new_rhs,
+ rhs_fvs, rhs_escs
+ )
+
+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
+ 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,
-- at ClosureInfo.getEntryConvention) in the whole of nofib,
-- specifically Main.lvl6 in spectral/cryptarithm2.
-- So no great loss. KSW 2000-07.
+-}
\end{code}
+Detect thunks which will reduce immediately to PAPs, and make them
+non-updatable. This has several advantages:
-%************************************************************************
-%* *
-\subsection[coreToStg-atoms{Converting atoms}
-%* *
-%************************************************************************
+ - the non-updatable thunk behaves exactly like the PAP,
-\begin{code}
-coreArgsToStg :: StgEnv -> [(CoreArg,RhsDemand)] -> UniqSM ([StgFloatBind], [StgArg])
--- Arguments are all value arguments (tyargs already removed), paired with their demand
+ - the thunk is more efficient to enter, because it is
+ specialised to the task.
-coreArgsToStg env []
- = returnUs ([], [])
+ - we save one update frame, one stg_update_PAP, one update
+ and lots of PAP_enters.
-coreArgsToStg env (ad:ads)
- = coreArgToStg env ad `thenUs` \ (bs1, a') ->
- coreArgsToStg env ads `thenUs` \ (bs2, as') ->
- returnUs (bs1 ++ bs2, a' : as')
+ - 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.
-coreArgToStg :: StgEnv -> (CoreArg,RhsDemand) -> UniqSM ([StgFloatBind], StgArg)
--- This is where we arrange that a non-trivial argument is let-bound
-
-coreArgToStg env (arg,dem)
- = coreExprToStgFloat env arg `thenUs` \ (floats, arg') ->
- case arg' of
- StgApp v [] -> returnUs (floats, StgVarArg v)
- StgLit lit -> returnUs (floats, StgLitArg lit)
+\begin{code}
+isPAP (StgApp f args) = idArity f > length args
+isPAP _ = False
+
+-- ---------------------------------------------------------------------------
+-- Atoms
+-- ---------------------------------------------------------------------------
+
+coreToStgAtoms :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo)
+coreToStgAtoms atoms
+ = let val_atoms = filter isValArg atoms in
+ mapAndUnzipLne coreToStgAtom val_atoms `thenLne` \ (args', fvs_lists) ->
+ returnLne (args', unionFVInfos fvs_lists)
+ where
+ coreToStgAtom e
+ = coreToStgExpr e `thenLne` \ (expr, fvs, escs) ->
+ case expr of
+ StgApp v [] -> returnLne (StgVarArg v, fvs)
+ StgConApp con [] -> returnLne (StgVarArg (dataConWrapId con), fvs)
+ StgLit lit -> returnLne (StgLitArg lit, fvs)
+ _ -> pprPanic "coreToStgAtom" (ppr expr)
+
+-- ---------------------------------------------------------------------------
+-- Expressions
+-- ---------------------------------------------------------------------------
- StgConApp con [] -> returnUs (floats, StgVarArg (dataConWrapId con))
- -- A nullary constructor can be replaced with
- -- a ``call'' to its wrapper
+{-
+@varsExpr@ carries in a monad-ised environment, which binds each
+let(rec) variable (ie non top level, not imported, not lambda bound,
+not case-alternative bound) to:
+ - its STG arity, and
+ - its set of live vars.
+For normal variables the set of live vars is just the variable
+itself. For let-no-escaped variables, the set of live vars is the set
+live at the moment the variable is entered. The set is guaranteed to
+have no further let-no-escaped vars in it.
+-}
- other -> newStgVar arg_ty `thenUs` \ v ->
- returnUs ([NonRecF v arg' dem floats], StgVarArg v)
- where
- arg_ty = exprType arg
+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}
-
-%************************************************************************
-%* *
-\subsection[coreToStg-exprs]{Converting core expressions}
-%* *
-%************************************************************************
+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}
-coreExprToStg :: StgEnv -> CoreExpr -> UniqSM StgExpr
-coreExprToStg env expr
- = coreExprToStgFloat env expr `thenUs` \ (binds,stg_expr) ->
- mkStgBinds binds stg_expr `thenUs` \ stg_expr' ->
- deStgLam stg_expr'
-\end{code}
+coreToStgExpr (Lit l) = returnLne (StgLit l, emptyFVInfo, emptyVarSet)
-%************************************************************************
-%* *
-\subsubsection[coreToStg-let(rec)]{Let and letrec expressions}
-%* *
-%************************************************************************
+coreToStgExpr (Var v)
+ = coreToStgApp Nothing v []
-\begin{code}
-coreExprToStgFloat :: StgEnv -> CoreExpr
- -> UniqSM ([StgFloatBind], StgExpr)
--- Transform an expression to STG. The 'floats' are
--- any bindings we had to create for function arguments.
-\end{code}
+coreToStgExpr expr@(App _ _)
+ = let (f, args) = myCollectArgs expr
+ in
+ coreToStgApp Nothing (shouldBeVar f) args
-Simple cases first
+coreToStgExpr expr@(Lam _ _)
+ = let (args, body) = myCollectBinders expr
+ args' = filter isId args
+ in
+ extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $
+ coreToStgExpr body `thenLne` \ (body, body_fvs, body_escs) ->
+ let
+ set_of_args = mkVarSet args'
+ fvs = body_fvs `minusFVBinders` args'
+ escs = body_escs `minusVarSet` set_of_args
+ in
+ if null args'
+ then returnLne (body, fvs, escs)
+ else returnLne (StgLam (exprType expr) args' body, fvs, escs)
+
+coreToStgExpr (Note (SCC cc) expr)
+ = coreToStgExpr expr `thenLne` ( \ (expr2, fvs, escs) ->
+ returnLne (StgSCC cc expr2, fvs, escs) )
+
+coreToStgExpr (Note other_note expr)
+ = coreToStgExpr expr
-\begin{code}
-coreExprToStgFloat env (Var var)
- = mkStgApp env var [] (idType var) `thenUs` \ app ->
- returnUs ([], app)
-coreExprToStgFloat env (Lit lit)
- = returnUs ([], StgLit lit)
+-- Cases require a little more real work.
+
+coreToStgExpr (Case scrut bndr alts)
+ = getVarsLiveInCont `thenLne` \ live_in_cont ->
+ extendVarEnvLne [(bndr, CaseBound)] $
+ vars_alts (findDefault alts) `thenLne` \ (alts2, alts_fvs, alts_escs) ->
+ lookupLiveVarsForSet alts_fvs `thenLne` \ alts_lvs ->
+ let
+ -- determine whether the default binder is dead or not
+ bndr'= if (bndr `elementOfFVInfo` alts_fvs)
+ then bndr `setIdOccInfo` NoOccInfo
+ else bndr `setIdOccInfo` IAmDead
+
+ -- for a _ccall_GC_, some of the *arguments* need to live across the
+ -- call (see findLiveArgs comments.), so we annotate them as being live
+ -- in the alts to achieve the desired effect.
+ mb_live_across_case =
+ case scrut of
+ -- ToDo: Notes?
+ e@(App _ _) | (Var v, args) <- myCollectArgs e,
+ PrimOpId (CCallOp ccall) <- idFlavour v,
+ ccallMayGC ccall
+ -> Just (filterVarSet isForeignObjArg (exprFreeVars e))
+ _ -> Nothing
+
+ -- 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 = orElse (FMAP unionVarSet mb_live_across_case) id $
+ live_in_cont `unionVarSet`
+ (alts_lvs `minusVarSet` unitVarSet bndr)
+ in
+ -- we tell the scrutinee that everything live in the alts
+ -- is live in it, too.
+ setVarsLiveInCont live_in_alts (
+ coreToStgExpr scrut
+ ) `thenLne` \ (scrut2, scrut_fvs, scrut_escs) ->
-coreExprToStgFloat env (Let bind body)
- = coreBindToStg NotTop env bind `thenUs` \ (new_bind, new_env) ->
- coreExprToStgFloat new_env body `thenUs` \ (floats, stg_body) ->
- returnUs (new_bind:floats, stg_body)
+ lookupLiveVarsForSet scrut_fvs `thenLne` \ scrut_lvs ->
+ let
+ live_in_whole_case = live_in_alts `unionVarSet` scrut_lvs
+ in
+ returnLne (
+ StgCase scrut2 live_in_whole_case live_in_alts bndr' noSRT alts2,
+ (scrut_fvs `unionFVInfo` alts_fvs) `minusFVBinders` [bndr],
+ (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)
+ = 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),
+ rhs_fvs `minusFVBinders` binders,
+ rhs_escs `minusVarSet` mkVarSet binders
+ -- ToDo: remove the minusVarSet;
+ -- since escs won't include any of these binders
+ )
+
+ 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)
+
+ 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}
-Convert core @scc@ expression directly to STG @scc@ expression.
+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}
-coreExprToStgFloat env (Note (SCC cc) expr)
- = coreExprToStg env expr `thenUs` \ stg_expr ->
- returnUs ([], StgSCC cc stg_expr)
+coreToStgExpr (Let bind body)
+ = fixLne (\ ~(_, _, _, no_binder_escapes) ->
+ coreToStgLet no_binder_escapes bind body
+ ) `thenLne` \ (new_let, fvs, escs, _) ->
-coreExprToStgFloat env (Note other_note expr)
- = coreExprToStgFloat env expr
+ returnLne (new_let, fvs, escs)
\end{code}
+If we've got a case containing a _ccall_GC_ primop, we need to
+ensure that the arguments are kept live for the duration of the
+call. This only an issue
+
\begin{code}
-coreExprToStgFloat env expr@(Type _)
- = pprPanic "coreExprToStgFloat: tyarg unexpected:" $ ppr expr
+isForeignObjArg :: Id -> Bool
+isForeignObjArg x = isId x && isForeignObjPrimTy (idType x)
+
+isForeignObjPrimTy ty
+ = case splitTyConApp_maybe ty of
+ Just (tycon, _) -> tycon == foreignObjPrimTyCon
+ Nothing -> False
\end{code}
-%************************************************************************
-%* *
-\subsubsection[coreToStg-lambdas]{Lambda abstractions}
-%* *
-%************************************************************************
-
+Applications:
\begin{code}
-coreExprToStgFloat env expr@(Lam _ _)
- = let
- expr_ty = exprType expr
- (binders, body) = collectBinders expr
- id_binders = filter isId binders
+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
+ = getVarsLiveInCont `thenLne` \ live_in_cont ->
+ coreToStgAtoms args `thenLne` \ (args', args_fvs) ->
+ lookupVarLne f `thenLne` \ how_bound ->
+
+ let
+ n_args = length args
+ not_letrec_bound = not (isLetrecBound how_bound)
+ f_arity = idArity f
+ fun_fvs = singletonFVInfo f how_bound fun_occ
+
+ fun_occ
+ | not_letrec_bound = NoStgBinderInfo -- Uninteresting variable
+
+ -- Otherwise it is letrec bound; must have its arity
+ | n_args == 0 = stgFakeFunAppOcc -- Function Application
+ -- with no arguments.
+ -- used by the lambda lifter.
+ | f_arity > n_args = stgUnsatOcc -- Unsaturated
+
+ | f_arity == n_args &&
+ maybeToBool maybe_thunk_body -- Exactly saturated,
+ -- and rhs of thunk
+ = case maybe_thunk_body of
+ Just Updatable -> stgStdHeapOcc
+ Just SingleEntry -> stgNoUpdHeapOcc
+ other -> panic "coreToStgApp"
+
+ | otherwise = stgNormalOcc
+ -- Record only that it occurs free
+
+ myself = unitVarSet f
+
+ fun_escs | not_letrec_bound = emptyVarSet
+ -- Only letrec-bound escapees are interesting
+ | f_arity == n_args = emptyVarSet
+ -- Function doesn't escape
+ | otherwise = myself
+ -- 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.
+
+ -- XXX not needed?
+ -- live_at_call
+ -- = live_in_cont `unionVarSet` case how_bound of
+ -- LetrecBound _ lvs -> lvs `minusVarSet` myself
+ -- other -> emptyVarSet
+
+ app = case idFlavour f of
+ DataConId dc -> StgConApp dc args'
+ PrimOpId op -> StgPrimApp op args' (exprType (mkApps (Var f) args))
+ _other -> StgApp f args'
+
in
- if null id_binders then -- It was all type binders; tossed
- coreExprToStgFloat env body
- else
- -- At least some value binders
- newLocalBinders env id_binders `thenUs` \ (env', binders') ->
- coreExprToStgFloat env' body `thenUs` \ (floats, stg_body) ->
- mkStgBinds floats stg_body `thenUs` \ stg_body' ->
-
- case stg_body' of
- StgLam ty lam_bndrs lam_body ->
- -- If the body reduced to a lambda too, join them up
- returnUs ([], mkStgLam expr_ty (binders' ++ lam_bndrs) lam_body)
-
- other ->
- -- Body didn't reduce to a lambda, so return one
- returnUs ([], mkStgLam expr_ty binders' stg_body')
-\end{code}
+ 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.
+ )
+
+
+-- ---------------------------------------------------------------------------
+-- 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_bind_lvs, _, 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 emptyVarSet)
+ (vars_bind rec_bind_lvs rec_body_fvs bind)
+ `thenLne` \ (bind2, bind_fvs, bind_escs, env_ext) ->
+
+ -- The live variables of this binding are the ones which are live
+ -- by virtue of being accessible via the free vars of the binding (lvs_from_fvs)
+ -- together with the live_in_cont ones
+ lookupLiveVarsForSet (bind_fvs `minusFVBinders` binders)
+ `thenLne` \ lvs_from_fvs ->
+ let
+ bind_lvs = lvs_from_fvs `unionVarSet` live_in_cont
+ in
+ -- bind_fvs and bind_escs still include the binders of the let(rec)
+ -- but bind_lvs does not
-%************************************************************************
-%* *
-\subsubsection[coreToStg-applications]{Applications}
-%* *
-%************************************************************************
+ -- Do the body
+ extendVarEnvLne env_ext (
+ coreToStgExpr body `thenLne` \ (body2, body_fvs, body_escs) ->
+ lookupLiveVarsForSet body_fvs `thenLne` \ body_lvs ->
-\begin{code}
-coreExprToStgFloat env expr@(App _ _)
- = let
- (fun,rads,ty,ss) = collect_args expr
- ads = reverse rads
- final_ads | null ss = ads
- | otherwise = zap ads -- Too few args to satisfy strictness info
- -- so we have to ignore all the strictness info
- -- e.g. + (error "urk")
- -- Here, we can't evaluate the arg strictly,
- -- because this partial application might be seq'd
- in
- coreArgsToStg env final_ads `thenUs` \ (arg_floats, stg_args) ->
-
- -- Now deal with the function
- case (fun, stg_args) of
- (Var fn_id, _) -> -- A function Id, so do an StgApp; it's ok if
- -- there are no arguments.
- mkStgApp env fn_id stg_args ty `thenUs` \ app ->
- returnUs (arg_floats, app)
-
- (non_var_fun, []) -> -- No value args, so recurse into the function
- ASSERT( null arg_floats )
- coreExprToStgFloat env non_var_fun
-
- other -> -- A non-variable applied to things; better let-bind it.
- newStgVar (exprType fun) `thenUs` \ fn_id ->
- coreExprToStgFloat env fun `thenUs` \ (fun_floats, stg_fun) ->
- mkStgApp env fn_id stg_args ty `thenUs` \ app ->
- returnUs (NonRecF fn_id stg_fun onceDem fun_floats : arg_floats,
- app)
+ returnLne (bind2, bind_fvs, bind_escs, bind_lvs,
+ body2, body_fvs, body_escs, body_lvs)
- where
- -- Collect arguments and demands (*in reverse order*)
- -- collect_args e = (f, args_w_demands, ty, stricts)
- -- => e = f tys args, (i.e. args are just the value args)
- -- e :: ty
- -- stricts is the leftover demands of e on its further args
- -- If stricts runs out, we zap all the demands in args_w_demands
- -- because partial applications are lazy
-
- collect_args :: CoreExpr -> (CoreExpr, [(CoreExpr,RhsDemand)], Type, [Demand])
-
- collect_args (Note (Coerce ty _) e) = let (the_fun,ads,_,ss) = collect_args e
- in (the_fun,ads,ty,ss)
- collect_args (Note InlineCall e) = collect_args e
-
- collect_args (App fun (Type tyarg)) = let (the_fun,ads,fun_ty,ss) = collect_args fun
- in (the_fun,ads,applyTy fun_ty tyarg,ss)
- collect_args (App fun arg)
- = (the_fun, (arg, mkDemTy ss1 arg_ty) : ads, res_ty, ss_rest)
- where
- (ss1, ss_rest) = case ss of
- (ss1:ss_rest) -> (ss1, ss_rest)
- [] -> (wwLazy, [])
- (the_fun, ads, fun_ty, ss) = collect_args fun
- (arg_ty, res_ty) = expectJust "coreExprToStgFloat:collect_args" $
- splitFunTy_maybe fun_ty
-
- collect_args (Var v)
- = (Var v, [], idType v, stricts)
- where
- stricts = case idStrictness v of
- StrictnessInfo demands _ -> demands
- other -> repeat wwLazy
+ )) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs,
+ body2, body_fvs, body_escs, body_lvs) ->
- collect_args fun = (fun, [], exprType fun, repeat wwLazy)
- -- "zap" nukes the strictness info for a partial application
- zap ads = [(arg, RhsDemand False once) | (arg, RhsDemand _ once) <- ads]
-\end{code}
+ -- 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
+ = (bind_fvs `unionFVInfo` body_fvs) `minusFVBinders` binders
-%************************************************************************
-%* *
-\subsubsection[coreToStg-cases]{Case expressions}
-%* *
-%************************************************************************
+ live_in_whole_let
+ = bind_lvs `unionVarSet` (body_lvs `minusVarSet` set_of_binders)
-\begin{code}
-coreExprToStgFloat env (Case scrut bndr alts)
- = coreExprToStgFloat env scrut `thenUs` \ (binds, scrut') ->
- newLocalBinder env bndr `thenUs` \ (env', bndr') ->
- alts_to_stg env' (findDefault alts) `thenUs` \ alts' ->
- mkStgCase scrut' bndr' alts' `thenUs` \ expr' ->
- returnUs (binds, expr')
+ 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
- scrut_ty = idType bndr
- prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
-
- alts_to_stg env (alts, deflt)
- | prim_case
- = default_to_stg env deflt `thenUs` \ deflt' ->
- mapUs (prim_alt_to_stg env) alts `thenUs` \ alts' ->
- returnUs (mkStgPrimAlts scrut_ty alts' deflt')
-
- | otherwise
- = default_to_stg env deflt `thenUs` \ deflt' ->
- mapUs (alg_alt_to_stg env) alts `thenUs` \ alts' ->
- returnUs (mkStgAlgAlts scrut_ty alts' deflt')
-
- alg_alt_to_stg env (DataAlt con, bs, rhs)
- = newLocalBinders env (filter isId bs) `thenUs` \ (env', stg_bs) ->
- coreExprToStg env' rhs `thenUs` \ stg_rhs ->
- returnUs (con, stg_bs, [ True | b <- stg_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 (LitAlt lit, args, rhs)
- = ASSERT( null args )
- coreExprToStg env rhs `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 ->
- returnUs (StgBindDefault stg_rhs)
-\end{code}
+ set_of_binders = mkVarSet binders
+ binders = case bind of
+ NonRec binder rhs -> [binder]
+ Rec pairs -> map fst pairs
+
+ mk_binding bind_lvs binder
+ = (binder, LetrecBound False -- Not top level
+ live_vars
+ )
+ where
+ live_vars = if let_no_escape then
+ extendVarSet bind_lvs binder
+ else
+ unitVarSet binder
+
+ vars_bind :: StgLiveVars
+ -> FreeVarsInfo -- Free var info for body of binding
+ -> CoreBind
+ -> LneM (StgBinding,
+ FreeVarsInfo, EscVarsSet, -- free vars; escapee vars
+ [(Id, HowBound)])
+ -- extension to environment
+
+ vars_bind rec_bind_lvs rec_body_fvs (NonRec binder rhs)
+ = coreToStgRhs rec_body_fvs NotTopLevel (binder,rhs)
+ `thenLne` \ (rhs2, fvs, escs) ->
+ let
+ env_ext_item@(binder', _) = mk_binding rec_bind_lvs binder
+ in
+ returnLne (StgNonRec binder' rhs2, fvs, escs, [env_ext_item])
+ vars_bind rec_bind_lvs rec_body_fvs (Rec pairs)
+ = let
+ binders = map fst pairs
+ env_ext = map (mk_binding rec_bind_lvs) binders
+ in
+ extendVarEnvLne env_ext (
+ fixLne (\ ~(_, rec_rhs_fvs, _, _) ->
+ let
+ rec_scope_fvs = unionFVInfo rec_body_fvs rec_rhs_fvs
+ in
+ mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs NotTopLevel) pairs
+ `thenLne` \ (rhss2, fvss, escss) ->
+ let
+ fvs = unionFVInfos fvss
+ escs = unionVarSets escss
+ in
+ returnLne (StgRec (binders `zip` rhss2), fvs, escs, 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}
%************************************************************************
%* *
-\subsection[coreToStg-misc]{Miscellaneous helping functions}
+\subsection[LNE-monad]{A little monad for this let-no-escaping pass}
%* *
%************************************************************************
-There's not anything interesting we can ASSERT about \tr{var} if it
-isn't in the StgEnv. (WDP 94/06)
+There's a lot of stuff to pass around, so we use this @LneM@ monad to
+help. All the stuff here is only passed {\em down}.
-Invent a fresh @Id@:
\begin{code}
-newStgVar :: Type -> UniqSM Id
-newStgVar ty
- = getUniqueUs `thenUs` \ uniq ->
- seqType ty `seq`
- returnUs (mkSysLocal SLIT("stg") uniq ty)
+type LneM a = IdEnv HowBound
+ -> StgLiveVars -- vars live in continuation
+ -> a
+
+data HowBound
+ = ImportBound
+ | CaseBound
+ | LambdaBound
+ | LetrecBound
+ Bool -- True <=> bound at top level
+ StgLiveVars -- Live vars... see notes below
+
+isLetrecBound (LetrecBound _ _) = True
+isLetrecBound other = False
\end{code}
-\begin{code}
-----------------------------
-data TopLvl = Top Module | NotTop
-
-isNotTop NotTop = True
-isNotTop (Top _) = False
-
-----------------------------
-newBinder :: TopLvl -> StgEnv -> Id -> UniqSM (StgEnv, Id)
-newBinder (Top mod) env id = returnUs (env, newTopBinder mod id)
-newBinder NotTop env id = newLocalBinder env id
-
-newBinders (Top mod) env ids = returnUs (env, map (newTopBinder mod) ids)
-newBinders NotTop env ids = newLocalBinders env ids
+For a let(rec)-bound variable, x, we record what varibles 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 LetrecBound constructor; x itself *is* included.
+The std monad functions:
+\begin{code}
+initLne :: LneM a -> a
+initLne m = m emptyVarEnv emptyVarSet
+
+{-# INLINE thenLne #-}
+{-# INLINE thenLne_ #-}
+{-# INLINE returnLne #-}
+
+returnLne :: a -> LneM a
+returnLne e env lvs_cont = e
+
+thenLne :: LneM a -> (a -> LneM b) -> LneM b
+thenLne m k env lvs_cont
+ = case (m env lvs_cont) of
+ m_result -> k m_result env lvs_cont
+
+thenLne_ :: LneM a -> LneM b -> LneM b
+thenLne_ m k env lvs_cont
+ = case (m env lvs_cont) of
+ _ -> k env lvs_cont
+
+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)
+
+mapAndUnzipLne :: (a -> LneM (b,c)) -> [a] -> LneM ([b],[c])
+
+mapAndUnzipLne f [] = returnLne ([],[])
+mapAndUnzipLne f (x:xs)
+ = f x `thenLne` \ (r1, r2) ->
+ mapAndUnzipLne f xs `thenLne` \ (rs1, rs2) ->
+ returnLne (r1:rs1, r2:rs2)
+
+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
+ result = expr result env lvs_cont
+-- ^^^^^^ ------ ^^^^^^
+\end{code}
-----------------------------
-newTopBinder mod id
- -- Don't clone top-level binders. MkIface relies on their
- -- uniques staying the same, so it can snaffle IdInfo off the
- -- STG ids to put in interface files.
- = name' `seq`
- seqType ty `seq`
- mkVanillaId name' ty
+Functions specific to this monad:
+\begin{code}
+getVarsLiveInCont :: LneM StgLiveVars
+getVarsLiveInCont env lvs_cont = lvs_cont
+
+setVarsLiveInCont :: StgLiveVars -> 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.
+
+lookupLiveVarsForSet :: FreeVarsInfo -> LneM StgLiveVars
+
+lookupLiveVarsForSet fvs env lvs_cont
+ = returnLne (unionVarSets (map do_one (getFVs fvs)))
+ env lvs_cont
where
- name = idName id
- name' | isLocalName name = globaliseName name mod
- | otherwise = name
- ty = idType id
-
-----------------------------
-newLocalBinder :: StgEnv -> Id -> UniqSM (StgEnv, Id)
-newLocalBinder env id
- = -- Local binder, give it a new unique Id.
- getUniqueUs `thenUs` \ uniq ->
- let
- name = idName id
- ty = idType id
- new_id = mkVanillaId (setNameUnique name uniq) ty
- new_env = extendVarEnv env id new_id
- in
- name `seq`
- seqType ty `seq`
- returnUs (new_env, new_id)
-
-----------------------------
-newLocalBinders :: StgEnv -> [Id] -> UniqSM (StgEnv, [Id])
-newLocalBinders env []
- = returnUs (env, [])
-
-newLocalBinders env (b:bs)
- = newLocalBinder env b `thenUs` \ (env', b') ->
- newLocalBinders env' bs `thenUs` \ (env'', bs') ->
- returnUs (env'', b':bs')
+ do_one v
+ = if isLocalId v then
+ case (lookupVarEnv env v) of
+ Just (LetrecBound _ lvs) -> extendVarSet lvs v
+ Just _ -> unitVarSet v
+ Nothing -> pprPanic "lookupVarEnv/do_one:" (ppr v)
+ else
+ emptyVarSet
\end{code}
%************************************************************************
%* *
-\subsection{Building STG syn}
+\subsection[Free-var info]{Free variable information}
%* *
%************************************************************************
\begin{code}
--- There are two things going on in mkStgAlgAlts
--- a) We pull out the type constructor for the case, from the data
--- constructor, if there is one. See notes with the StgAlgAlts data type
--- b) We force the type constructor to avoid space leaks
-
-mkStgAlgAlts ty alts deflt
- = case alts of
- -- Get the tycon from the data con
- (dc, _, _, _):_ -> 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
- = case splitTyConApp ty of
- (tc,_) -> StgPrimAlts tc alts deflt
-
-mkStgLam ty bndrs body = seqType ty `seq` StgLam ty bndrs body
-
-mkStgApp :: StgEnv -> Id -> [StgArg] -> Type -> UniqSM StgExpr
- -- The type is the type of the entire application
-mkStgApp env fn args ty
- = case idFlavour fn_alias of
- DataConId dc
- -> saturate fn_alias args ty $ \ args' ty' ->
- returnUs (StgConApp dc args')
-
- PrimOpId (CCallOp ccall)
- -- Sigh...make a guaranteed unique name for a dynamic ccall
- -- Done here, not earlier, because it's a code-gen thing
- -> saturate fn_alias args ty $ \ args' ty' ->
- getUniqueUs `thenUs` \ uniq ->
- let ccall' = setCCallUnique ccall uniq in
- returnUs (StgPrimApp (CCallOp ccall') args' ty')
-
-
- PrimOpId op
- -> saturate fn_alias args ty $ \ args' ty' ->
- returnUs (StgPrimApp op args' ty')
-
- other -> returnUs (StgApp fn_alias args)
- -- Force the lookup
- where
- fn_alias = case (lookupVarEnv env fn) of -- In case it's been cloned
- Nothing -> fn
- Just fn' -> fn'
-
-saturate :: Id -> [StgArg] -> Type -> ([StgArg] -> Type -> UniqSM StgExpr) -> UniqSM StgExpr
- -- The type should be the type of (id args)
-saturate fn args ty thing_inside
- | excess_arity == 0 -- Saturated, so nothing to do
- = thing_inside args ty
-
- | otherwise -- An unsaturated constructor or primop; eta expand it
- = ASSERT2( excess_arity > 0 && excess_arity <= length arg_tys,
- ppr fn <+> ppr args <+> ppr excess_arity <+> parens (ppr ty) <+> ppr arg_tys )
- mapUs newStgVar extra_arg_tys `thenUs` \ arg_vars ->
- thing_inside (args ++ map StgVarArg arg_vars) final_res_ty `thenUs` \ body ->
- returnUs (StgLam ty arg_vars body)
- where
- fn_arity = idArity fn
- excess_arity = fn_arity - length args
- (arg_tys, res_ty) = splitRepFunTys ty
- extra_arg_tys = take excess_arity arg_tys
- final_res_ty = mkFunTys (drop excess_arity arg_tys) res_ty
+type FreeVarsInfo = IdEnv (Id, Bool, StgBinderInfo)
+ -- If f is mapped to NoStgBinderInfo, that means
+ -- that f *is* mentioned (else it wouldn't be in the
+ -- IdEnv at all), but only in a saturated applications.
+ --
+ -- All case/lambda-bound things are also mapped to
+ -- NoStgBinderInfo, since we aren't interested in their
+ -- occurence info.
+ --
+ -- The Bool is True <=> the Id is top level letrec bound
+
+type EscVarsSet = IdSet
\end{code}
\begin{code}
--- Stg doesn't have a lambda *expression*
-deStgLam (StgLam ty bndrs body)
- -- Try for eta reduction
- = ASSERT( not (null bndrs) )
- case eta body of
- Just e -> -- Eta succeeded
- returnUs e
-
- Nothing -> -- Eta failed, so let-bind the lambda
- newStgVar ty `thenUs` \ fn ->
- returnUs (StgLet (StgNonRec fn lam_closure) (StgApp fn []))
- where
- lam_closure = StgRhsClosure noCCS
- stgArgOcc
- noSRT
- bOGUS_FVs
- ReEntrant -- binders is non-empty
- bndrs
- body
-
- eta (StgApp f args)
- | n_remaining >= 0 &&
- and (zipWith ok bndrs last_args) &&
- notInExpr bndrs remaining_expr
- = Just remaining_expr
- where
- remaining_expr = StgApp f remaining_args
- (remaining_args, last_args) = splitAt n_remaining args
- n_remaining = length args - length bndrs
-
- eta (StgLet bind@(StgNonRec b r) body)
- | notInRhs bndrs r = case eta body of
- Just e -> Just (StgLet bind e)
- Nothing -> Nothing
-
- eta _ = Nothing
-
- ok bndr (StgVarArg arg) = bndr == arg
- ok bndr other = False
-
-deStgLam expr = returnUs expr
-
-
---------------------------------------------------
-notInExpr :: [Id] -> StgExpr -> Bool
-notInExpr vs (StgApp f args) = notInId vs f && notInArgs vs args
-notInExpr vs (StgLet (StgNonRec b r) body) = notInRhs vs r && notInExpr vs body
-notInExpr vs other = False -- Safe
-
-notInRhs :: [Id] -> StgRhs -> Bool
-notInRhs vs (StgRhsCon _ _ args) = notInArgs vs args
-notInRhs vs (StgRhsClosure _ _ _ _ _ _ body) = notInExpr vs body
- -- Conservative: we could delete the binders from vs, but
- -- cloning means this will never help
-
-notInArgs :: [Id] -> [StgArg] -> Bool
-notInArgs vs args = all ok args
- where
- ok (StgVarArg v) = notInId vs v
- ok (StgLitArg l) = True
+emptyFVInfo :: FreeVarsInfo
+emptyFVInfo = emptyVarEnv
-notInId :: [Id] -> Id -> Bool
-notInId vs v = not (v `elem` vs)
+singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
+singletonFVInfo id ImportBound info = emptyVarEnv
+singletonFVInfo id (LetrecBound top_level _) info = unitVarEnv id (id, top_level, info)
+singletonFVInfo id other info = unitVarEnv id (id, False, info)
+unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
+unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
+unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
+unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
-mkStgBinds :: [StgFloatBind]
- -> StgExpr -- *Can* be a StgLam
- -> UniqSM StgExpr -- *Can* be a StgLam
+minusFVBinders :: FreeVarsInfo -> [Id] -> FreeVarsInfo
+minusFVBinders fv ids = fv `delVarEnvList` ids
-mkStgBinds [] body = returnUs body
-mkStgBinds (b:bs) body
- = deStgLam body `thenUs` \ body' ->
- go (b:bs) body'
- where
- go [] body = returnUs body
- go (b:bs) body = go bs body `thenUs` \ body' ->
- mkStgBind b body'
+elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
+elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
--- The 'body' arg of mkStgBind can't be a StgLam
-mkStgBind NoBindF body = returnUs body
-mkStgBind (RecF prs) body = returnUs (StgLet (StgRec prs) body)
+lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
+lookupFVInfo fvs id = case lookupVarEnv fvs id of
+ Nothing -> NoStgBinderInfo
+ Just (_,_,info) -> info
-mkStgBind (NonRecF bndr rhs dem floats) body
-#ifdef DEBUG
- -- We shouldn't get let or case of the form v=w
- = case rhs of
- StgApp v [] -> pprTrace "mkStgLet" (ppr bndr <+> ppr v)
- (mk_stg_let bndr rhs dem floats body)
- other -> mk_stg_let bndr rhs dem floats body
+getFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only
+getFVs fvs = [id | (id,False,_) <- rngVarEnv fvs]
-mk_stg_let bndr rhs dem floats body
-#endif
- | isUnLiftedType bndr_rep_ty -- Use a case/PrimAlts
- = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
- mkStgCase rhs bndr (mkStgPrimAlts bndr_rep_ty [] (StgBindDefault body)) `thenUs` \ expr' ->
- mkStgBinds floats expr'
-
- | is_whnf
- = if is_strict then
- -- Strict let with WHNF rhs
- mkStgBinds floats $
- StgLet (StgNonRec bndr (exprToRhs dem NotTop rhs)) body
- else
- -- Lazy let with WHNF rhs; float until we find a strict binding
- let
- (floats_out, floats_in) = splitFloats floats
- in
- mkStgBinds floats_in rhs `thenUs` \ new_rhs ->
- mkStgBinds floats_out $
- StgLet (StgNonRec bndr (exprToRhs dem NotTop new_rhs)) body
-
- | otherwise -- Not WHNF
- = if is_strict then
- -- Strict let with non-WHNF rhs
- mkStgCase rhs bndr (mkStgAlgAlts bndr_rep_ty [] (StgBindDefault body)) `thenUs` \ expr' ->
- mkStgBinds floats expr'
- else
- -- Lazy let with non-WHNF rhs, so keep the floats in the RHS
- mkStgBinds floats rhs `thenUs` \ new_rhs ->
- returnUs (StgLet (StgNonRec bndr (exprToRhs dem NotTop new_rhs)) body)
-
- where
- bndr_rep_ty = repType (idType bndr)
- is_strict = isStrictDem dem
- is_whnf = case rhs of
- StgConApp _ _ -> True
- StgLam _ _ _ -> True
- other -> False
+getFVSet :: FreeVarsInfo -> IdSet
+getFVSet fvs = mkVarSet (getFVs fvs)
--- Split at the first strict binding
-splitFloats fs@(NonRecF _ _ dem _ : _)
- | isStrictDem dem = ([], fs)
-
-splitFloats (f : fs) = case splitFloats fs of
- (fs_out, fs_in) -> (f : fs_out, fs_in)
-
-splitFloats [] = ([], [])
+plusFVInfo (id1,top1,info1) (id2,top2,info2)
+ = ASSERT (id1 == id2 && top1 == top2)
+ (id1, top1, combineStgBinderInfo info1 info2)
\end{code}
-
-Making an STG case
-~~~~~~~~~~~~~~~~~~
-
-First, two special cases. We mangle cases involving
- par# and seq#
-inthe scrutinee.
-
-Up to this point, seq# will appear like this:
-
- case seq# e of
- 0# -> seqError#
- _ -> <stuff>
-
-This code comes from an unfolding for 'seq' in Prelude.hs.
-The 0# branch is purely to bamboozle the strictness analyser.
-For example, if <stuff> is strict in x, and there was no seqError#
-branch, the strictness analyser would conclude that the whole expression
-was strict in x, and perhaps evaluate x first -- but that would be a DISASTER.
-
-Now that the evaluation order is safe, we translate this into
-
- case e of
- _ -> ...
-
-This used to be done in the post-simplification phase, but we need
-unfoldings involving seq# to appear unmangled in the interface file,
-hence we do this mangling here.
-
-Similarly, par# has an unfolding in PrelConc.lhs that makes it show
-up like this:
-
- case par# e of
- 0# -> rhs
- _ -> parError#
-
-
- ==>
- case par# e of
- _ -> rhs
-
-fork# isn't handled like this - it's an explicit IO operation now.
-The reason is that fork# returns a ThreadId#, which gets in the
-way of the above scheme. And anyway, IO is the only guaranteed
-way to enforce ordering --SDM.
-
+Misc.
\begin{code}
--- Discard alernatives in case (par# ..) of
-mkStgCase scrut@(StgPrimApp ParOp _ _) bndr
- (StgPrimAlts tycon _ deflt@(StgBindDefault _))
- = returnUs (StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT (StgPrimAlts tycon [] deflt))
-
-mkStgCase (StgPrimApp SeqOp [scrut] _) bndr
- (StgPrimAlts _ _ deflt@(StgBindDefault rhs))
- = mkStgCase scrut_expr new_bndr new_alts
+shouldBeVar (Note _ e) = shouldBeVar e
+shouldBeVar (Var v) = v
+shouldBeVar e = pprPanic "shouldBeVar" (ppr e)
+
+-- 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 :: Expr b -> (Expr b, [Arg b])
+myCollectArgs expr
+ = go expr []
where
- new_alts | isUnLiftedType scrut_ty = WARN( True, text "mkStgCase" ) mkStgPrimAlts scrut_ty [] deflt
- | otherwise = mkStgAlgAlts scrut_ty [] deflt
- scrut_ty = stgArgType scrut
- new_bndr = setIdType bndr scrut_ty
- -- NB: SeqOp :: forall a. a -> Int#
- -- So bndr has type Int#
- -- But now we are going to scrutinise the SeqOp's argument directly,
- -- so we must change the type of the case binder to match that
- -- of the argument expression e.
-
- scrut_expr = case scrut of
- StgVarArg v -> StgApp v []
- -- Others should not happen because
- -- seq of a value should have disappeared
- StgLitArg l -> WARN( True, text "seq on" <+> ppr l ) StgLit l
-
-mkStgCase scrut bndr alts
- = deStgLam scrut `thenUs` \ scrut' ->
- -- It is (just) possible to get a lambda as a srutinee here
- -- Namely: fromDyn (toDyn ((+1)::Int->Int)) False)
- -- gives: case ...Bool == Int->Int... of
- -- True -> case coerce Bool (\x -> + 1 x) of
- -- True -> ...
- -- False -> ...
- -- False -> ...
- -- The True branch of the outer case will never happen, of course.
-
- returnUs (StgCase scrut' bOGUS_LVs bOGUS_LVs bndr noSRT alts)
+ go (App f a) as = go f (a:as)
+ go (Note (SCC _) e) as = panic "CoreToStg.myCollectArgs"
+ go (Note n e) as = go e as
+ go e as = (e, as)
\end{code}
let { binds_w_strictness = saTopBindsBinds binds };
#endif
- endPass dflags "Strictness analysis"
- (dopt Opt_D_dump_stranal dflags || dopt Opt_D_verbose_core2core dflags)
+ endPass dflags "Strictness analysis" Opt_D_dump_stranal
binds_w_strictness
}
\end{code}
let { binds' = workersAndWrappers us binds };
endPass dflags "Worker Wrapper binds"
- (dopt Opt_D_dump_worker_wrapper dflags ||
- dopt Opt_D_verbose_core2core dflags)
- binds'
+ Opt_D_dump_worker_wrapper binds'
}
\end{code}
projects / ghc-hetmet.git / commitdiff