From d364541154457a49e3c35d671d7a1b57c9c4cca3 Mon Sep 17 00:00:00 2001 From: simonmar Date: Wed, 6 Dec 2000 13:03:30 +0000 Subject: [PATCH] [project @ 2000-12-06 13:03:28 by simonmar] Re-engineer the transition from Core to STG syntax. Main changes in this commit: - a new pass, CoreSat, handles saturation of constructors and PrimOps, and puts the syntax into STG-like normal form (applications to atoms only, etc), modulo type applications and Notes. - CoreToStg is now done at the same time as StgVarInfo. Most of the contents of StgVarInfo.lhs have been copied into CoreToStg.lhs and some simplifications made. less major changes: - globalisation of names for the purposes of object splitting is now done by the C code generator (which is the Right Place in principle, but it was a bit fiddly). - CoreTidy now does cloning of local binders and collection of arity info. The IdInfo from CoreTidy is now *almost* the final IdInfo we put in the interface file, except for CafInfo. I'm going to move the CafInfo collection into CoreTidy in due course too. - and some other minor tidyups while I was in cluster-bomb commit mode. --- ghc/compiler/basicTypes/Name.lhs | 2 +- ghc/compiler/coreSyn/CoreLint.lhs | 9 +- ghc/compiler/coreSyn/CoreSat.lhs | 552 ++++++++++ ghc/compiler/coreSyn/CoreTidy.lhs | 300 +++--- ghc/compiler/coreSyn/CoreUtils.lhs | 17 +- ghc/compiler/cprAnalysis/CprAnalyse.lhs | 3 +- ghc/compiler/deSugar/Desugar.lhs | 6 +- ghc/compiler/main/CmdLineOpts.lhs | 5 +- ghc/compiler/main/DriverFlags.hs | 3 +- ghc/compiler/main/ErrUtils.lhs | 13 +- ghc/compiler/simplCore/CSE.lhs | 4 +- ghc/compiler/simplCore/FloatIn.lhs | 4 +- ghc/compiler/simplCore/FloatOut.lhs | 4 +- ghc/compiler/simplCore/LiberateCase.lhs | 4 +- ghc/compiler/simplCore/SimplCore.lhs | 7 +- ghc/compiler/simplStg/LambdaLift.lhs | 567 ----------- ghc/compiler/simplStg/SRT.lhs | 18 +- ghc/compiler/simplStg/SimplStg.lhs | 29 +- ghc/compiler/simplStg/StgVarInfo.lhs | 853 ---------------- ghc/compiler/specialise/Specialise.lhs | 4 +- ghc/compiler/stgSyn/CoreToStg.lhs | 1679 +++++++++++++++---------------- ghc/compiler/stranal/StrictAnal.lhs | 3 +- ghc/compiler/stranal/WorkWrap.lhs | 4 +- 23 files changed, 1584 insertions(+), 2506 deletions(-) create mode 100644 ghc/compiler/coreSyn/CoreSat.lhs delete mode 100644 ghc/compiler/simplStg/LambdaLift.lhs delete mode 100644 ghc/compiler/simplStg/StgVarInfo.lhs diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 7f0b19f..2dcc009 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -358,7 +358,7 @@ pprGlobal sty name uniq mod occ | 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 diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index f932db4..cbcfb56 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -27,7 +27,7 @@ import VarSet 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 ) @@ -58,13 +58,14 @@ place for them. They print out stuff before and after core passes, 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 @@ -78,7 +79,7 @@ endPassWithRules dflags pass_name dump_flag binds rules 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) diff --git a/ghc/compiler/coreSyn/CoreSat.lhs b/ghc/compiler/coreSyn/CoreSat.lhs new file mode 100644 index 0000000..f512d8c --- /dev/null +++ b/ghc/compiler/coreSyn/CoreSat.lhs @@ -0,0 +1,552 @@ +% +% (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} diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index 62d54f7..3407734 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -11,28 +11,29 @@ module CoreTidy ( #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 @@ -43,7 +44,7 @@ import Module ( Module, moduleName ) 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 ) @@ -80,7 +81,6 @@ exported with their unfoldings, so we produce not an IdSet but an IdEnv Bool - Step 2: Tidy the program ~~~~~~~~~~~~~~~~~~~~~~~~ Next we traverse the bindings top to bottom. For each top-level @@ -97,6 +97,10 @@ binder - 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 @@ -116,16 +120,19 @@ tidyCorePgm dflags mod pcs binds_in orphans_in ; 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) } @@ -138,12 +145,12 @@ tidyCorePgm dflags mod pcs binds_in orphans_in -- 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} @@ -248,7 +255,7 @@ addExternal (id,rhs) needed \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 @@ -257,44 +264,56 @@ type TopTidyEnv = (OrigNameNameEnv, TidyOccEnv, VarEnv Var) -- 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 @@ -307,15 +326,19 @@ tidyTopBinder mod ext_ids env_idinfo rhs env@(orig_env, occ_env, subst_env) id -- 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 @@ -325,23 +348,32 @@ tidyTopBinder mod ext_ids env_idinfo rhs env@(orig_env, occ_env, subst_env) id 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 @@ -354,18 +386,27 @@ tidyIdInfo (_, occ_env, subst_env) is_external unfold_info id 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') @@ -374,32 +415,34 @@ tidyTopName mod orig_env occ_env external name 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 @@ -409,51 +452,53 @@ tidyRule env (Rule name vars tpl_args rhs) \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} @@ -469,35 +514,38 @@ tidyVarOcc (_, var_env) v = case lookupVarEnv var_env v of 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} diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 69b244d..0bf8f9b 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -16,6 +16,7 @@ module CoreUtils ( exprIsValue,exprOkForSpeculation, exprIsBig, exprIsConApp_maybe, idAppIsBottom, idAppIsCheap, + exprArity, -- Expr transformation etaReduce, exprEtaExpandArity, @@ -491,8 +492,22 @@ exprIsConApp_maybe expr 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} %************************************************************************ %* * diff --git a/ghc/compiler/cprAnalysis/CprAnalyse.lhs b/ghc/compiler/cprAnalysis/CprAnalyse.lhs index c90aec6..ecba677 100644 --- a/ghc/compiler/cprAnalysis/CprAnalyse.lhs +++ b/ghc/compiler/cprAnalysis/CprAnalyse.lhs @@ -140,8 +140,7 @@ cprAnalyse dflags binds 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] diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index fb21765..4b2143b 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -70,11 +70,11 @@ deSugar dflags pcs hst mod_name unqual (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 } diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 731678b..335e8a9 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -189,9 +189,7 @@ data CoreToDo -- These are diff core-to-core passes, \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 @@ -231,6 +229,7 @@ data DynFlag | 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 diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs index 7db2531..db254e5 100644 --- a/ghc/compiler/main/DriverFlags.hs +++ b/ghc/compiler/main/DriverFlags.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $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 -- @@ -381,6 +381,7 @@ dynamic_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) ) diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index 84e6a17..ccc03ad 100644 --- a/ghc/compiler/main/ErrUtils.lhs +++ b/ghc/compiler/main/ErrUtils.lhs @@ -13,7 +13,7 @@ module ErrUtils ( printErrorsAndWarnings, pprBagOfErrors, pprBagOfWarnings, ghcExit, - doIfSet, doIfSet_dyn, dumpIfSet, dumpIfSet_dyn, showPass + doIfSet, doIfSet_dyn, dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, showPass ) where #include "HsVersions.h" @@ -122,10 +122,17 @@ dumpIfSet flag hdr doc | 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 "", diff --git a/ghc/compiler/simplCore/CSE.lhs b/ghc/compiler/simplCore/CSE.lhs index 69b35be..66038f3 100644 --- a/ghc/compiler/simplCore/CSE.lhs +++ b/ghc/compiler/simplCore/CSE.lhs @@ -109,9 +109,7 @@ cseProgram dflags binds = 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] diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs index f974d12..ec02ec0 100644 --- a/ghc/compiler/simplCore/FloatIn.lhs +++ b/ghc/compiler/simplCore/FloatIn.lhs @@ -39,10 +39,8 @@ floatInwards dflags binds = 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 diff --git a/ghc/compiler/simplCore/FloatOut.lhs b/ghc/compiler/simplCore/FloatOut.lhs index fdc20bf..0160906 100644 --- a/ghc/compiler/simplCore/FloatOut.lhs +++ b/ghc/compiler/simplCore/FloatOut.lhs @@ -96,10 +96,8 @@ floatOutwards dflags float_lams us pgm 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)" diff --git a/ghc/compiler/simplCore/LiberateCase.lhs b/ghc/compiler/simplCore/LiberateCase.lhs index 5d4d921..57b94be 100644 --- a/ghc/compiler/simplCore/LiberateCase.lhs +++ b/ghc/compiler/simplCore/LiberateCase.lhs @@ -153,10 +153,8 @@ liberateCase dflags binds = 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 [] = [] diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 1f59c63..6b50c4e 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -372,10 +372,7 @@ simplifyPgm dflags rule_base 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') } @@ -431,7 +428,7 @@ simplifyPgm dflags rule_base 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 [] ; diff --git a/ghc/compiler/simplStg/LambdaLift.lhs b/ghc/compiler/simplStg/LambdaLift.lhs deleted file mode 100644 index 96de466..0000000 --- a/ghc/compiler/simplStg/LambdaLift.lhs +++ /dev/null @@ -1,567 +0,0 @@ -% -% (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} diff --git a/ghc/compiler/simplStg/SRT.lhs b/ghc/compiler/simplStg/SRT.lhs index 0b8d20d..1adf5ff 100644 --- a/ghc/compiler/simplStg/SRT.lhs +++ b/ghc/compiler/simplStg/SRT.lhs @@ -9,14 +9,18 @@ bindings have no CAF references, and record the fact in their IdInfo. \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} @@ -273,6 +277,12 @@ srtExpr rho conts@(cont,lne) off 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} ----------------------------------------------------------------------------- diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs index e8ee16e..7233ee9 100644 --- a/ghc/compiler/simplStg/SimplStg.lhs +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -10,12 +10,10 @@ module SimplStg ( stg2stg ) where 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, @@ -47,27 +45,14 @@ stg2stg dflags module_name binds ; 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) @@ -86,20 +71,10 @@ stg2stg dflags module_name 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 diff --git a/ghc/compiler/simplStg/StgVarInfo.lhs b/ghc/compiler/simplStg/StgVarInfo.lhs deleted file mode 100644 index 6ab1841..0000000 --- a/ghc/compiler/simplStg/StgVarInfo.lhs +++ /dev/null @@ -1,853 +0,0 @@ -% -% (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} - - - diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index fad010b..e6d6897 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -585,9 +585,7 @@ specProgram dflags us binds 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')))) diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index b67458c..130a8f8 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -1,367 +1,206 @@ % -% (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, @@ -369,643 +208,711 @@ exprToRhs dem toplev expr -- 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# - _ -> - -This code comes from an unfolding for 'seq' in Prelude.hs. -The 0# branch is purely to bamboozle the strictness analyser. -For example, if 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} diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs index 4c85197..aeb1c3f 100644 --- a/ghc/compiler/stranal/StrictAnal.lhs +++ b/ghc/compiler/stranal/StrictAnal.lhs @@ -94,8 +94,7 @@ saBinds dflags binds 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} diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs index a128688..371920a 100644 --- a/ghc/compiler/stranal/WorkWrap.lhs +++ b/ghc/compiler/stranal/WorkWrap.lhs @@ -70,9 +70,7 @@ wwTopBinds dflags us binds 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} -- 1.7.10.4