diff options
Diffstat (limited to 'ghc/compiler/simplStg')
| -rw-r--r-- | ghc/compiler/simplStg/LambdaLift.hi | 8 | ||||
| -rw-r--r-- | ghc/compiler/simplStg/LambdaLift.lhs | 527 | ||||
| -rw-r--r-- | ghc/compiler/simplStg/SatStgRhs.hi | 8 | ||||
| -rw-r--r-- | ghc/compiler/simplStg/SatStgRhs.lhs | 307 | ||||
| -rw-r--r-- | ghc/compiler/simplStg/SimplStg.hi | 12 | ||||
| -rw-r--r-- | ghc/compiler/simplStg/SimplStg.lhs | 354 | ||||
| -rw-r--r-- | ghc/compiler/simplStg/StgSAT.hi | 18 | ||||
| -rw-r--r-- | ghc/compiler/simplStg/StgSAT.lhs | 186 | ||||
| -rw-r--r-- | ghc/compiler/simplStg/StgSATMonad.hi | 22 | ||||
| -rw-r--r-- | ghc/compiler/simplStg/StgSATMonad.lhs | 182 | ||||
| -rw-r--r-- | ghc/compiler/simplStg/StgStats.hi | 7 | ||||
| -rw-r--r-- | ghc/compiler/simplStg/StgStats.lhs | 188 | ||||
| -rw-r--r-- | ghc/compiler/simplStg/StgVarInfo.hi | 7 | ||||
| -rw-r--r-- | ghc/compiler/simplStg/StgVarInfo.lhs | 790 | ||||
| -rw-r--r-- | ghc/compiler/simplStg/UpdAnal.hi | 7 | ||||
| -rw-r--r-- | ghc/compiler/simplStg/UpdAnal.lhs | 510 |
16 files changed, 3133 insertions, 0 deletions
diff --git a/ghc/compiler/simplStg/LambdaLift.hi b/ghc/compiler/simplStg/LambdaLift.hi new file mode 100644 index 0000000000..1ea1a64990 --- /dev/null +++ b/ghc/compiler/simplStg/LambdaLift.hi @@ -0,0 +1,8 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface LambdaLift where +import Id(Id) +import SplitUniq(SplitUniqSupply) +import StgSyn(StgBinding) +liftProgram :: SplitUniqSupply -> [StgBinding Id Id] -> [StgBinding Id Id] + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} + diff --git a/ghc/compiler/simplStg/LambdaLift.lhs b/ghc/compiler/simplStg/LambdaLift.lhs new file mode 100644 index 0000000000..158ce90bce --- /dev/null +++ b/ghc/compiler/simplStg/LambdaLift.lhs @@ -0,0 +1,527 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1995 +% +\section[LambdaLift]{A STG-code lambda lifter} + +\begin{code} +#include "HsVersions.h" + +module LambdaLift ( liftProgram ) where + +import StgSyn + +import AbsUniType ( mkForallTy, splitForalls, glueTyArgs, + UniType, RhoType(..), TauType(..) + ) +import Bag +import Id ( mkSysLocal, getIdUniType, addIdArity, Id ) +import IdEnv +import Maybes +import SplitUniq +import SrcLoc ( mkUnknownSrcLoc, SrcLoc ) +import UniqSet +import Util +\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 :: SplitUniqSupply -> [PlainStgBinding] -> [PlainStgBinding] +liftProgram us prog = concat (runLM Nothing us (mapLM liftTopBind prog)) + + +liftTopBind :: PlainStgBinding -> LiftM [PlainStgBinding] +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 :: PlainStgExpr + -> LiftM (PlainStgExpr, LiftInfo) + + +liftExpr expr@(StgConApp con args lvs) = returnLM (expr, emptyLiftInfo) +liftExpr expr@(StgPrimApp op args lvs) = returnLM (expr, emptyLiftInfo) + +liftExpr expr@(StgApp (StgLitAtom lit) args lvs) = returnLM (expr, emptyLiftInfo) +liftExpr expr@(StgApp (StgVarAtom v) args lvs) + = lookup v `thenLM` \ ~(sc, sc_args) -> -- NB the ~. We don't want to + -- poke these bindings too early! + returnLM (StgApp (StgVarAtom sc) (map StgVarAtom sc_args ++ args) lvs, + emptyLiftInfo) + -- The lvs field is probably wrong, but we reconstruct it + -- anyway following lambda lifting + +liftExpr (StgCase scrut lv1 lv2 uniq alts) + = liftExpr scrut `thenLM` \ (scrut', scrut_info) -> + lift_alts alts `thenLM` \ (alts', alts_info) -> + returnLM (StgCase scrut' lv1 lv2 uniq alts', scrut_info `unionLiftInfo` alts_info) + where + lift_alts (StgAlgAlts ty alg_alts deflt) + = mapAndUnzipLM lift_alg_alt alg_alts `thenLM` \ (alg_alts', alt_infos) -> + lift_deflt deflt `thenLM` \ (deflt', deflt_info) -> + returnLM (StgAlgAlts ty alg_alts' deflt', foldr unionLiftInfo deflt_info alt_infos) + + lift_alts (StgPrimAlts ty prim_alts deflt) + = mapAndUnzipLM lift_prim_alt prim_alts `thenLM` \ (prim_alts', alt_infos) -> + lift_deflt deflt `thenLM` \ (deflt', deflt_info) -> + returnLM (StgPrimAlts ty 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 var used rhs) + = liftExpr rhs `thenLM` \ (rhs', rhs_info) -> + returnLM (StgBindDefault var used 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 (binders `zipEqual` 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 (binders `zipEqual` 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 = unionManyUniqSets (map rhsFreeVars rhss) + `minusUniqSet` + mkUniqSet 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 ty cc expr) + = liftExpr expr `thenLM` \ (expr2, expr_info) -> + returnLM (StgSCC ty 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 :: PlainStgRhs -> 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 :: PlainStgRhs -> 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 +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 > 1 -- Too many free variables + ) + then {-trace ("LLRec: " ++ show (length fvs))-} True + else False +isLiftableRec other_rhs = False + +rhsFreeVars :: PlainStgRhs -> IdSet +rhsFreeVars (StgRhsClosure _ _ fvs _ _ _) = mkUniqSet 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 :: PlainStgRhs -> LiftM (PlainStgRhs, LiftInfo) + +dontLiftRhs rhs@(StgRhsCon cc v args) = returnLM (rhs, emptyLiftInfo) + +dontLiftRhs (StgRhsClosure cc bi fvs upd args body) + = liftExpr body `thenLM` \ (body', body_info) -> + returnLM (StgRhsClosure cc bi fvs upd args body', body_info) +\end{code} + + +\begin{code} +mkScPieces :: IdSet -- Extra args for the supercombinator + -> (Id, PlainStgRhs) -- The processed RHS and original Id + -> LiftM ((Id,[Id]), -- Replace abstraction with this; + -- the set is its free vars + (Id,PlainStgRhs)) -- Binding for supercombinator + +mkScPieces extra_arg_set (id, StgRhsClosure cc bi _ upd args body) + = ASSERT( n_args > 0 ) + -- Construct the rhs of the supercombinator, and its Id + -- this trace blackholes sometimes, don't use it + -- trace ("LL " ++ show (length (uniqSetToList extra_arg_set))) ( + newSupercombinator sc_ty arity `thenLM` \ sc_id -> + + returnLM ((sc_id, extra_args), (sc_id, sc_rhs)) + --) + where + n_args = length args + extra_args = uniqSetToList extra_arg_set + arity = n_args + length extra_args + + -- Construct the supercombinator type + type_of_original_id = getIdUniType id + extra_arg_tys = map getIdUniType extra_args + (tyvars, rest) = splitForalls type_of_original_id + sc_ty = mkForallTy tyvars (glueTyArgs extra_arg_tys rest) + + sc_rhs = StgRhsClosure cc bi [] 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 = LiftFlags + -> SplitUniqSupply + -> (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 :: LiftFlags -> SplitUniqSupply -> LiftM a -> a +runLM flags us m = m flags us nullIdEnv + +thenLM :: LiftM a -> (a -> LiftM b) -> LiftM b +thenLM m k ci us idenv + = k (m ci us1 idenv) ci us2 idenv + where + (us1, us2) = splitUniqSupply us + +returnLM :: a -> LiftM a +returnLM a ci us idenv = a + +fixLM :: (a -> LiftM a) -> LiftM a +fixLM k ci us idenv = r + where + r = k r 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 :: UniType + -> Int -- Arity + -> LiftM Id + +newSupercombinator ty arity ci us idenv + = (mkSysLocal SLIT("sc") uniq ty mkUnknownSrcLoc) -- ToDo: improve location + `addIdArity` arity + -- ToDo: rm the addIdArity? Just let subsequent stg-saturation pass do it? + where + uniq = getSUnique us + +lookup :: Id -> LiftM (Id,[Id]) +lookup v ci us idenv + = case lookupIdEnv idenv v of + Just result -> result + Nothing -> (v, []) + +addScInlines :: [Id] -> [(Id,[Id])] -> LiftM a -> LiftM a +addScInlines ids values m ci us idenv + = m ci us idenv' + where + idenv' = growIdEnvList 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 ci us idenv + = unionManyUniqSets (map munge_it (uniqSetToList free_vars)) + where + munge_it :: Id -> IdSet -- Takes a free var and maps it to the "real" + -- free var + munge_it id = case lookupIdEnv idenv id of + Just (_, args) -> mkUniqSet args + Nothing -> singletonUniqSet id + +\end{code} + + +%************************************************************************ +%* * +\subsection[Lift-info]{The LiftInfo type} +%* * +%************************************************************************ + +\begin{code} +type LiftInfo = Bag PlainStgBinding -- 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 :: PlainStgBinding -> LiftInfo +mkScInfo bind = unitBag bind + +nonRecScBind :: LiftInfo -- From body of supercombinator + -> (Id, PlainStgRhs) -- 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,PlainStgRhs)] -- Supercombinator rhs + -> LiftInfo + +recScBind binds pairs = unitBag (co_rec_ify (StgRec pairs : bagToList binds)) + +co_rec_ify :: [PlainStgBinding] -> PlainStgBinding +co_rec_ify binds = StgRec (concat (map f binds)) + where + f (StgNonRec id rhs) = [(id,rhs)] + f (StgRec pairs) = pairs + + +getScBinds :: LiftInfo -> [PlainStgBinding] +getScBinds binds = bagToList binds + +looksLikeSATRhs [(f,StgRhsClosure _ _ _ _ ls _)] (StgApp (StgVarAtom f') args _) + = (f == f') && (length args == length ls) +looksLikeSATRhs _ _ = False +\end{code} diff --git a/ghc/compiler/simplStg/SatStgRhs.hi b/ghc/compiler/simplStg/SatStgRhs.hi new file mode 100644 index 0000000000..de10f7c424 --- /dev/null +++ b/ghc/compiler/simplStg/SatStgRhs.hi @@ -0,0 +1,8 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface SatStgRhs where +import Id(Id) +import SplitUniq(SplitUniqSupply) +import StgSyn(StgBinding) +satStgRhs :: [StgBinding Id Id] -> SplitUniqSupply -> [StgBinding Id Id] + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "S" _N_ _N_ #-} + diff --git a/ghc/compiler/simplStg/SatStgRhs.lhs b/ghc/compiler/simplStg/SatStgRhs.lhs new file mode 100644 index 0000000000..a6793d7a78 --- /dev/null +++ b/ghc/compiler/simplStg/SatStgRhs.lhs @@ -0,0 +1,307 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[SatStgRhs]{Saturates RHSs when they are partial applications} + + +\begin{display} +Subject: arg satis check +Date: Wed, 29 Apr 92 13:33:58 +0100 +From: Simon L Peyton Jones <simonpj> + +Andre + +Another transformation to consider. We'd like to avoid +argument-satisfaction checks wherever possible. So, whenever we have an +STG binding application + + f = vs \ xs -> g e1 ... en + +where xs has one or more elements +and +where g is a known function with arity m+n, + +then: change it to + + f = vs \ xs++{x1...xm} -> g e1 ... en x1 .. xm + +Now g has enough args. One arg-satisfaction check disappears; +the one for the closure incorporates the one for g. + +You might like to consider variants, applying the transformation more +widely. I concluded that this was the only instance which made +sense, but I could be wrong. + +Simon +\end{display} + +The algorithm proceeds as follows: +\begin{enumerate} +\item +Gather the arity information of the functions defined in this module +(as @getIdArity@ only knows about the arity of @ImportedIds@). + +\item +for every definition of the form +\begin{verbatim} + v = /\ts -> \vs -> f args +\end{verbatim} +we try to match the arity of \tr{f} with the number of arguments. +If they do not match we insert extra lambdas to make that application +saturated. +\end{enumerate} + +This is done for local definitions as well. + +\begin{code} +#include "HsVersions.h" + +module SatStgRhs ( satStgRhs ) where + +import StgSyn + +import AbsUniType ( splitTypeWithDictsAsArgs, Class, + TyVarTemplate, TauType(..) + ) +import CostCentre +import IdEnv +import Id ( mkSysLocal, getIdUniType, getIdArity, addIdArity ) +import IdInfo -- SIGH: ( arityMaybe, ArityInfo, OptIdInfo(..) ) +import SrcLoc ( mkUnknownSrcLoc, SrcLoc ) +import SplitUniq +import Unique +import Util +import Maybes + +type Arity = Int +type Count = Int + +type ExprArityInfo = Maybe Int -- Just n => This expression has a guaranteed + -- arity of n + -- Nothing => Don't know how many args it needs + +type Id_w_Arity = Id -- An Id with correct arity info pinned on it +type SatEnv = IdEnv Id_w_Arity -- Binds only local, let(rec)-bound things +\end{code} + +This pass +\begin{itemize} +\item adds extra args where necessary; +\item pins the correct arity on everything. +\end{itemize} + +%************************************************************************ +%* * +\subsection{Top-level list of bindings (a ``program'')} +%* * +%************************************************************************ + +\begin{code} +satStgRhs :: PlainStgProgram -> SUniqSM PlainStgProgram + +satStgRhs p = satProgram nullIdEnv p + +satProgram :: SatEnv -> PlainStgProgram -> SUniqSM PlainStgProgram +satProgram env [] = returnSUs [] + +satProgram env (bind:binds) + = satBinding True{-toplevel-} env bind `thenSUs` \ (env2, bind2) -> + satProgram env2 binds `thenSUs` \ binds2 -> + returnSUs (bind2 : binds2) +\end{code} + +%************************************************************************ +%* * +\subsection{Bindings} +%* * +%************************************************************************ + +\begin{code} +satBinding :: Bool -- True <=> top-level + -> SatEnv + -> PlainStgBinding + -> SUniqSM (SatEnv, PlainStgBinding) + +satBinding top env (StgNonRec b rhs) + = satRhs top env (b, rhs) `thenSUs` \ (b2, rhs2) -> + let + env2 = addOneToIdEnv env b b2 + in + returnSUs (env2, StgNonRec b2 rhs2) + +satBinding top env (StgRec pairs) + = -- Do it once to get the arities right... + mapSUs (satRhs top env) pairs `thenSUs` \ pairs2 -> + let + env2 = growIdEnvList env (map fst pairs `zip` map fst pairs2) + in + -- Do it again to *use* those arities: + mapSUs (satRhs top env2) pairs `thenSUs` \ pairs3 -> + + returnSUs (env2, StgRec pairs3) + +satRhs :: Bool -> SatEnv -> (Id, PlainStgRhs) -> SUniqSM (Id_w_Arity, PlainStgRhs) + +satRhs top env (b, StgRhsCon cc con args) -- Nothing much to do here + = let + b2 = b `addIdArity` 0 -- bound to a saturated constructor; hence zero. + in + returnSUs (b2, StgRhsCon cc con (lookupArgs env args)) + +satRhs top env (b, StgRhsClosure cc bi fv u args body) + = satExpr env body `thenSUs` \ (arity_info, body2) -> + let + num_args = length args + in + (case arity_info of + Nothing -> + returnSUs (num_args, StgRhsClosure cc bi fv u args body2) + + Just needed_args -> + ASSERT(needed_args >= 1) + + let -- the arity we're aiming for is: what we already have ("args") + -- plus the ones requested in "arity_info" + new_arity = num_args + needed_args + + -- get type info for this function: + (_,all_arg_tys,_) = splitTypeWithDictsAsArgs (getIdUniType b) + + -- now, we already have "args"; we drop that many types + args_we_dont_have_tys = drop num_args all_arg_tys + + -- finally, we take some of those (up to maybe all of them), + -- depending on how many "needed_args" + args_to_add_tys = take needed_args args_we_dont_have_tys + in + -- make up names for them + mapSUs newName args_to_add_tys `thenSUs` \ nns -> + + -- and do the business + let + body3 = saturate body2 (map StgVarAtom nns) + + new_cc -- if we're adding args, we'd better not + -- keep calling something a CAF! (what about DICTs? ToDo: WDP 95/02) + = if not (isCafCC cc) + then cc -- unchanged + else if top then subsumedCosts else useCurrentCostCentre + in + returnSUs (new_arity, StgRhsClosure new_cc bi fv ReEntrant (args++nns) body3) + ) + `thenSUs` \ (arity, rhs2) -> + let + b2 = b `addIdArity` arity + in + returnSUs (b2, rhs2) +\end{code} + +%************************************************************************ +%* * +\subsection{Expressions} +%* * +%************************************************************************ + +\begin{code} +satExpr :: SatEnv -> PlainStgExpr -> SUniqSM (ExprArityInfo, PlainStgExpr) + +satExpr env app@(StgApp (StgLitAtom lit) [] lvs) = returnSUs (Nothing, app) + +satExpr env app@(StgApp (StgVarAtom f) as lvs) + = returnSUs (arity_to_return, StgApp (StgVarAtom f2) as2 lvs) + where + as2 = lookupArgs env as + f2 = lookupVar env f + arity_to_return = case arityMaybe (getIdArity f2) of + Nothing -> Nothing + + Just f_arity -> if remaining_arity > 0 + then Just remaining_arity + else Nothing + where + remaining_arity = f_arity - length as + +satExpr env app@(StgConApp con as lvs) + = returnSUs (Nothing, StgConApp con (lookupArgs env as) lvs) + +satExpr env app@(StgPrimApp op as lvs) + = returnSUs (Nothing, StgPrimApp op (lookupArgs env as) lvs) + +satExpr env (StgSCC ty l e) + = satExpr env e `thenSUs` \ (_, e2) -> + returnSUs (Nothing, StgSCC ty l e2) + +{- OMITTED: Let-no-escapery should come *after* saturation + +satExpr (StgLetNoEscape lvs_whole lvs_rhss binds body) + = satBinding binds `thenSUs` \ (binds2, c) -> + satExpr body `thenSUs` \ (_, body2, c2) -> + returnSUs (Nothing, StgLetNoEscape lvs_whole lvs_rhss binds2 body2, c + c2) +-} + +satExpr env (StgLet binds body) + = satBinding False{-not top-level-} env binds `thenSUs` \ (env2, binds2) -> + satExpr env2 body `thenSUs` \ (_, body2) -> + returnSUs (Nothing, StgLet binds2 body2) + +satExpr env (StgCase expr lve lva uniq alts) + = satExpr env expr `thenSUs` \ (_, expr2) -> + sat_alts alts `thenSUs` \ alts2 -> + returnSUs (Nothing, StgCase expr2 lve lva uniq alts2) + where + sat_alts (StgAlgAlts ty alts def) + = mapSUs sat_alg_alt alts `thenSUs` \ alts2 -> + sat_deflt def `thenSUs` \ def2 -> + returnSUs (StgAlgAlts ty alts2 def2) + where + sat_alg_alt (id, bs, use_mask, e) + = satExpr env e `thenSUs` \ (_, e2) -> + returnSUs (id, bs, use_mask, e2) + + sat_alts (StgPrimAlts ty alts def) + = mapSUs sat_prim_alt alts `thenSUs` \ alts2 -> + sat_deflt def `thenSUs` \ def2 -> + returnSUs (StgPrimAlts ty alts2 def2) + where + sat_prim_alt (l, e) + = satExpr env e `thenSUs` \ (_, e2) -> + returnSUs (l, e2) + + sat_deflt StgNoDefault + = returnSUs StgNoDefault + + sat_deflt (StgBindDefault b u expr) + = satExpr env expr `thenSUs` \ (_,expr2) -> + returnSUs (StgBindDefault b u expr2) +\end{code} + +%************************************************************************ +%* * +\subsection{Utility functions} +%* * +%************************************************************************ + +\begin{code} +saturate :: PlainStgExpr -> [PlainStgAtom] -> PlainStgExpr + +saturate (StgApp f as lvs) ids = StgApp f (as ++ ids) lvs +saturate other _ = panic "SatStgRhs: saturate" +\end{code} + +\begin{code} +lookupArgs :: SatEnv -> [PlainStgAtom] -> [PlainStgAtom] +lookupArgs env args = map do args + where + do (StgVarAtom v) = StgVarAtom (lookupVar env v) + do a@(StgLitAtom lit) = a + +lookupVar :: SatEnv -> Id -> Id +lookupVar env v = case lookupIdEnv env v of + Nothing -> v + Just v2 -> v2 + +newName :: UniType -> SUniqSM Id +newName ut + = getSUnique `thenSUs` \ uniq -> + returnSUs (mkSysLocal SLIT("sat") uniq ut mkUnknownSrcLoc) +\end{code} diff --git a/ghc/compiler/simplStg/SimplStg.hi b/ghc/compiler/simplStg/SimplStg.hi new file mode 100644 index 0000000000..08f6c91653 --- /dev/null +++ b/ghc/compiler/simplStg/SimplStg.hi @@ -0,0 +1,12 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface SimplStg where +import CmdLineOpts(GlobalSwitch, StgToDo, SwitchResult) +import CostCentre(CostCentre) +import Id(Id) +import PreludePS(_PackedString) +import Pretty(PprStyle) +import SplitUniq(SplitUniqSupply) +import StgSyn(StgBinding) +stg2stg :: [StgToDo] -> (GlobalSwitch -> SwitchResult) -> _PackedString -> PprStyle -> SplitUniqSupply -> [StgBinding Id Id] -> _State _RealWorld -> (([StgBinding Id Id], ([CostCentre], [CostCentre])), _State _RealWorld) + {-# GHC_PRAGMA _A_ 7 _U_ 1222122 _N_ _S_ "SSLLU(ALL)LL" _N_ _N_ #-} + diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs new file mode 100644 index 0000000000..6fdb44c02c --- /dev/null +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -0,0 +1,354 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% +\section[SimplStg]{Driver for simplifying @STG@ programs} + +\begin{code} +#include "HsVersions.h" + +module SimplStg ( stg2stg ) where + +IMPORT_Trace + +import StgSyn +import StgFuns + +import LambdaLift ( liftProgram ) +import SCCfinal ( stgMassageForProfiling ) +import SatStgRhs ( satStgRhs ) +import StgStats ( showStgStats ) +import StgVarInfo ( setStgVarInfo ) +import UpdAnal ( updateAnalyse ) + +import CmdLineOpts +import Id ( unlocaliseId ) +import IdEnv +import MainMonad +import Maybes ( maybeToBool, Maybe(..) ) +import Outputable +import Pretty +import SplitUniq +import StgLint ( lintStgBindings ) +import StgSAT ( doStaticArgs ) +import UniqSet +import Unique +import Util +\end{code} + +\begin{code} +stg2stg :: [StgToDo] -- spec of what stg-to-stg passes to do + -> (GlobalSwitch -> SwitchResult)-- access to all global cmd-line opts + -> FAST_STRING -- module name (profiling only) + -> PprStyle -- printing style (for debugging only) + -> SplitUniqSupply -- a name supply + -> [PlainStgBinding] -- input... + -> MainIO + ([PlainStgBinding], -- output program... + ([CostCentre], -- local cost-centres that need to be decl'd + [CostCentre])) -- "extern" cost-centres + +stg2stg stg_todos sw_chkr module_name ppr_style us binds + = BSCC("Stg2Stg") + case (splitUniqSupply us) of { (us4now, us4later) -> + + (if do_verbose_stg2stg then + writeMn stderr "VERBOSE STG-TO-STG:\n" `thenMn_` + writeMn stderr (ppShow 1000 + (ppAbove (ppStr ("*** Core2Stg:")) + (ppAboves (map (ppr ppr_style) (setStgVarInfo False binds))) + )) + else returnMn ()) `thenMn_` + + -- Do the main business! + foldl_mn do_stg_pass (binds, us4now, ([],[])) stg_todos + `thenMn` \ (processed_binds, _, cost_centres) -> + -- Do essential wind-up: part (a) is SatStgRhs + + -- Not optional, because correct arity information is used by + -- the code generator. Afterwards do setStgVarInfo; it gives + -- the wrong answers if arities are subsequently changed, + -- which stgSatRhs might do. Furthermore, setStgVarInfo + -- decides about let-no-escape things, which in turn do a + -- better job if arities are correct, which is done by + -- satStgRhs. + + case (satStgRhs processed_binds us4later) of { saturated_binds -> + + -- Essential wind-up: part (b), eliminate indirections + + let no_ind_binds = elimIndirections saturated_binds in + + + -- Essential wind-up: part (c), 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 + -- ToDo: provide proper flag control! + binds_to_mangle + = if not do_unlocalising + then no_ind_binds + else snd (unlocaliseStgBinds unlocal_tag nullIdEnv no_ind_binds) + in + returnMn (setStgVarInfo do_let_no_escapes binds_to_mangle, cost_centres) + }} + ESCC + where + switch_is_on = switchIsOn sw_chkr + + do_let_no_escapes = switch_is_on StgDoLetNoEscapes + do_verbose_stg2stg = switch_is_on D_verbose_stg2stg + + (do_unlocalising, unlocal_tag) + = case (stringSwitchSet sw_chkr EnsureSplittableC) of + Nothing -> (False, panic "tag") + Just tag -> (True, _PK_ tag) + + grp_name = case (stringSwitchSet sw_chkr SccGroup) of + Just xx -> _PK_ xx + Nothing -> module_name -- default: module name + + ------------- + stg_linter = if False -- LATER: switch_is_on DoCoreLinting -- ToDo: DoStgLinting flag + then lintStgBindings ppr_style + else ( \ whodunnit binds -> binds ) + + ------------------------------------------- + do_stg_pass (binds, us, ccs) to_do + = let + (us1, us2) = splitUniqSupply us + in + case to_do of + StgDoStaticArgs -> + ASSERT(null (fst ccs) && null (snd ccs)) + BSCC("StgStaticArgs") + let + binds3 = doStaticArgs binds us1 + in + end_pass us2 "StgStaticArgs" ccs binds3 + ESCC + + StgDoUpdateAnalysis -> + ASSERT(null (fst ccs) && null (snd ccs)) + BSCC("StgUpdAnal") + -- NB We have to do setStgVarInfo first! (There's one + -- place free-var info is used) But no let-no-escapes, + -- because update analysis doesn't care. + end_pass us2 "UpdAnal" ccs (updateAnalyse (setStgVarInfo False binds)) + ESCC + + D_stg_stats -> + trace (showStgStats binds) + end_pass us2 "StgStats" ccs binds + + StgDoLambdaLift -> + BSCC("StgLambdaLift") + -- NB We have to do setStgVarInfo first! + let + binds3 = liftProgram us1 (setStgVarInfo do_let_no_escapes binds) + in + end_pass us2 "LambdaLift" ccs binds3 + ESCC + + StgDoMassageForProfiling -> + BSCC("ProfMassage") + let + (collected_CCs, binds3) + = stgMassageForProfiling module_name grp_name us1 switch_is_on binds + in + end_pass us2 "ProfMassage" collected_CCs binds3 + ESCC + + end_pass us2 what ccs binds2 + = -- report verbosely, if required + (if do_verbose_stg2stg then + writeMn stderr (ppShow 1000 + (ppAbove (ppStr ("*** "++what++":")) + (ppAboves (map (ppr ppr_style) binds2)) + )) + else returnMn ()) `thenMn_` + let + linted_binds = stg_linter what binds2 + in + returnMn (linted_binds, us2, ccs) + -- return: processed binds + -- UniqueSupply for the next guy to use + -- cost-centres to be declared/registered (specialised) + -- add to description of what's happened (reverse order) + +-- here so it can be inlined... +foldl_mn f z [] = returnMn z +foldl_mn f z (x:xs) = f z x `thenMn` \ zz -> + foldl_mn f zz xs +\end{code} + +%************************************************************************ +%* * +\subsection[SimplStg-unlocalise]{Unlocalisation in STG code} +%* * +%************************************************************************ + +The idea of all this ``unlocalise'' stuff is that 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 unlocaliseWhatnot goes through making all the local things +into global things, essentially by giving them full names so when they +are printed they'll have their module name too. Pretty revolting +really. + +\begin{code} +type UnlocalEnv = IdEnv Id + +lookup_uenv :: UnlocalEnv -> Id -> Id +lookup_uenv env id = case lookupIdEnv env id of + Nothing -> id + Just new_id -> new_id + +unlocaliseStgBinds :: FAST_STRING -> UnlocalEnv -> [PlainStgBinding] -> (UnlocalEnv, [PlainStgBinding]) + +unlocaliseStgBinds mod uenv [] = (uenv, []) + +unlocaliseStgBinds mod uenv (b : bs) + = BIND unlocal_top_bind mod uenv b _TO_ (new_uenv, new_b) -> + BIND unlocaliseStgBinds mod new_uenv bs _TO_ (uenv3, new_bs) -> + (uenv3, new_b : new_bs) + BEND BEND + +------------------ + +unlocal_top_bind :: FAST_STRING -> UnlocalEnv -> PlainStgBinding -> (UnlocalEnv, PlainStgBinding) + +unlocal_top_bind mod uenv bind@(StgNonRec binder _) + = let new_uenv = case unlocaliseId mod binder of + Nothing -> uenv + Just new_binder -> addOneToIdEnv uenv binder new_binder + in + (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind) + +unlocal_top_bind mod uenv bind@(StgRec pairs) + = let maybe_unlocaliseds = [ (b, unlocaliseId mod b) | (b, _) <- pairs ] + new_uenv = growIdEnvList uenv [ (b,new_b) + | (b, Just new_b) <- maybe_unlocaliseds] + in + (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind) +\end{code} + +%************************************************************************ +%* * +\subsection[SimplStg-indirections]{Eliminating indirections in STG code} +%* * +%************************************************************************ + +In @elimIndirections@, we look for things at the top-level of the form... +\begin{verbatim} + x_local = ....rhs... + ... + x_exported = x_local + ... +\end{verbatim} +In cases we find like this, we go {\em backwards} and replace +\tr{x_local} with \tr{...rhs...}, to produce +\begin{verbatim} + x_exported = ...rhs... + ... + ... +\end{verbatim} +This saves a gratuitous jump +(from \tr{x_exported} to \tr{x_local}), and makes strictness +information propagate better. + +If more than one exported thing is equal to a local thing (i.e., the +local thing really is shared), then we eliminate only the first one. Thus: +\begin{verbatim} + x_local = ....rhs... + ... + x_exported1 = x_local + ... + x_exported2 = x_local + ... +\end{verbatim} +becomes +\begin{verbatim} + x_exported1 = ....rhs... + ... + ... + x_exported2 = x_exported1 + ... +\end{verbatim} + +We also have to watch out for + + f = \xyz -> g x y z + +This can arise post lambda lifting; the original might have been + + f = \xyz -> letrec g = [xy] \ [k] -> e + in + g z + +Strategy: first collect the info; then make a \tr{Id -> Id} mapping. +Then blast the whole program (LHSs as well as RHSs) with it. + +\begin{code} +elimIndirections :: [PlainStgBinding] -> [PlainStgBinding] + +elimIndirections binds_in + = if isNullIdEnv blast_env then + binds_in -- Nothing to do + else + [renameTopStgBind lookup_fn bind | Just bind <- reduced_binds] + where + lookup_fn id = case lookupIdEnv blast_env id of + Just new_id -> new_id + Nothing -> id + + (blast_env, reduced_binds) = mapAccumL try_bind nullIdEnv binds_in + + try_bind :: IdEnv Id -> PlainStgBinding -> (IdEnv Id, Maybe PlainStgBinding) + try_bind env_so_far + (StgNonRec exported_binder + (StgRhsClosure _ _ _ _ + lambda_args + (StgApp (StgVarAtom local_binder) fun_args _) + )) + | isExported exported_binder && -- Only if this is exported + not (isExported local_binder) && -- Only if this one is defined in this + isLocallyDefined local_binder && -- module, so that we *can* change its + -- binding to be the exported thing! + not (in_dom env_so_far local_binder) && -- Only if we havn't seen it before + args_match lambda_args fun_args -- Just an eta-expansion + + = (addOneToIdEnv env_so_far local_binder exported_binder, + Nothing) + where + args_match [] [] = True + args_match (la:las) (StgVarAtom fa:fas) = la == fa && args_match las fas + args_match _ _ = False + + try_bind env_so_far bind + = (env_so_far, Just bind) + + in_dom env id = maybeToBool (lookupIdEnv env id) +\end{code} + +@renameTopStgBind@ renames top level binders and all occurrences thereof. + +\begin{code} +renameTopStgBind :: (Id -> Id) -> PlainStgBinding -> PlainStgBinding + +renameTopStgBind fn (StgNonRec b rhs) = StgNonRec (fn b) (mapStgBindeesRhs fn rhs) +renameTopStgBind fn (StgRec pairs) = StgRec [ (fn b, mapStgBindeesRhs fn r) | (b, r) <- pairs ] +\end{code} diff --git a/ghc/compiler/simplStg/StgSAT.hi b/ghc/compiler/simplStg/StgSAT.hi new file mode 100644 index 0000000000..91f7a35243 --- /dev/null +++ b/ghc/compiler/simplStg/StgSAT.hi @@ -0,0 +1,18 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface StgSAT where +import CostCentre(CostCentre) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import PrimOps(PrimOp) +import SplitUniq(SplitUniqSupply) +import StgSyn(PlainStgProgram(..), StgAtom, StgBinding, StgCaseAlternatives, StgExpr, StgRhs) +import UniType(UniType) +import UniqFM(UniqFM) +import Unique(Unique) +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +type PlainStgProgram = [StgBinding Id Id] +data StgBinding a b {-# GHC_PRAGMA StgNonRec a (StgRhs a b) | StgRec [(a, StgRhs a b)] #-} +data StgExpr a b {-# GHC_PRAGMA StgApp (StgAtom b) [StgAtom b] (UniqFM b) | StgConApp Id [StgAtom b] (UniqFM b) | StgPrimApp PrimOp [StgAtom b] (UniqFM b) | StgCase (StgExpr a b) (UniqFM b) (UniqFM b) Unique (StgCaseAlternatives a b) | StgLet (StgBinding a b) (StgExpr a b) | StgLetNoEscape (UniqFM b) (UniqFM b) (StgBinding a b) (StgExpr a b) | StgSCC UniType CostCentre (StgExpr a b) #-} +doStaticArgs :: [StgBinding Id Id] -> SplitUniqSupply -> [StgBinding Id Id] + {-# GHC_PRAGMA _A_ 1 _U_ 22 _N_ _S_ "S" _N_ _N_ #-} + diff --git a/ghc/compiler/simplStg/StgSAT.lhs b/ghc/compiler/simplStg/StgSAT.lhs new file mode 100644 index 0000000000..80cdec4208 --- /dev/null +++ b/ghc/compiler/simplStg/StgSAT.lhs @@ -0,0 +1,186 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +%************************************************************************ +%* * +\section[SAT]{Static Argument Transformation pass} +%* * +%************************************************************************ + +May be seen as removing invariants from loops: +Arguments of recursive functions that do not change in recursive +calls are removed from the recursion, which is done locally +and only passes the arguments which effectively change. + +Example: +map = /\ ab -> \f -> \xs -> case xs of + [] -> [] + (a:b) -> f a : map f b + +as map is recursively called with the same argument f (unmodified) +we transform it to + +map = /\ ab -> \f -> \xs -> let map' ys = case ys of + [] -> [] + (a:b) -> f a : map' b + in map' xs + +Notice that for a compiler that uses lambda lifting this is +useless as map' will be transformed back to what map was. + +\begin{code} +#include "HsVersions.h" + +module StgSAT ( + doStaticArgs, + + -- and to make the interface self-sufficient... + PlainStgProgram(..), StgExpr, StgBinding, Id + ) where + +import IdEnv +import Maybes ( Maybe(..) ) +import StgSyn +import SATMonad ( SATEnv(..), SATInfo(..), Arg(..), updSAEnv, insSAEnv, + SatM(..), initSAT, thenSAT, thenSAT_, + emptyEnvSAT, returnSAT, mapSAT ) +import StgSATMonad +import SplitUniq +import Util +\end{code} + +\begin{code} +doStaticArgs :: PlainStgProgram -> SplitUniqSupply -> PlainStgProgram + +doStaticArgs binds + = initSAT (mapSAT sat_bind binds) + where + sat_bind (StgNonRec binder expr) + = emptyEnvSAT `thenSAT_` + satRhs expr `thenSAT` (\ expr' -> + returnSAT (StgNonRec binder expr')) + sat_bind (StgRec [(binder,rhs)]) + = emptyEnvSAT `thenSAT_` + insSAEnv binder (getArgLists rhs) `thenSAT_` + satRhs rhs `thenSAT` (\ rhs' -> + saTransform binder rhs') + sat_bind (StgRec pairs) + = emptyEnvSAT `thenSAT_` + mapSAT satRhs rhss `thenSAT` \ rhss' -> + returnSAT (StgRec (binders `zip` rhss')) + where + (binders, rhss) = unzip pairs +\end{code} + +\begin{code} +satAtom (StgVarAtom v) + = updSAEnv (Just (v,([],[]))) `thenSAT_` + returnSAT () + +satAtom _ = returnSAT () +\end{code} + +\begin{code} +satExpr :: PlainStgExpr -> SatM PlainStgExpr + +satExpr e@(StgConApp con args lvs) + = mapSAT satAtom args `thenSAT_` + returnSAT e + +satExpr e@(StgPrimApp op args lvs) + = mapSAT satAtom args `thenSAT_` + returnSAT e + +satExpr e@(StgApp (StgLitAtom _) _ _) + = returnSAT e + +satExpr e@(StgApp (StgVarAtom v) args _) + = updSAEnv (Just (v,([],map tagArg args))) `thenSAT_` + mapSAT satAtom args `thenSAT_` + returnSAT e + where + tagArg (StgVarAtom v) = Static v + tagArg _ = NotStatic + +satExpr (StgCase expr lv1 lv2 uniq alts) + = satExpr expr `thenSAT` \ expr' -> + sat_alts alts `thenSAT` \ alts' -> + returnSAT (StgCase expr' lv1 lv2 uniq alts') + where + sat_alts (StgAlgAlts ty alts deflt) + = mapSAT satAlgAlt alts `thenSAT` \ alts' -> + sat_default deflt `thenSAT` \ deflt' -> + returnSAT (StgAlgAlts ty alts' deflt') + where + satAlgAlt (con, params, use_mask, rhs) + = satExpr rhs `thenSAT` \ rhs' -> + returnSAT (con, params, use_mask, rhs') + + sat_alts (StgPrimAlts ty alts deflt) + = mapSAT satPrimAlt alts `thenSAT` \ alts' -> + sat_default deflt `thenSAT` \ deflt' -> + returnSAT (StgPrimAlts ty alts' deflt') + where + satPrimAlt (lit, rhs) + = satExpr rhs `thenSAT` \ rhs' -> + returnSAT (lit, rhs') + + sat_default StgNoDefault + = returnSAT StgNoDefault + sat_default (StgBindDefault binder used rhs) + = satExpr rhs `thenSAT` \ rhs' -> + returnSAT (StgBindDefault binder used rhs') + +satExpr (StgLetNoEscape lv1 lv2 (StgNonRec binder rhs) body) + = satExpr body `thenSAT` \ body' -> + satRhs rhs `thenSAT` \ rhs' -> + returnSAT (StgLetNoEscape lv1 lv2 (StgNonRec binder rhs') body') + +satExpr (StgLetNoEscape lv1 lv2 (StgRec [(binder,rhs)]) body) + = satExpr body `thenSAT` \ body' -> + insSAEnv binder (getArgLists rhs) `thenSAT_` + satRhs rhs `thenSAT` \ rhs' -> + saTransform binder rhs' `thenSAT` \ binding -> + returnSAT (StgLetNoEscape lv1 lv2 binding body') + +satExpr (StgLetNoEscape lv1 lv2 (StgRec binds) body) + = let (binders, rhss) = unzip binds + in + satExpr body `thenSAT` \ body' -> + mapSAT satRhs rhss `thenSAT` \ rhss' -> + returnSAT (StgLetNoEscape lv1 lv2 (StgRec (binders `zip` rhss')) body') + +satExpr (StgLet (StgNonRec binder rhs) body) + = satExpr body `thenSAT` \ body' -> + satRhs rhs `thenSAT` \ rhs' -> + returnSAT (StgLet (StgNonRec binder rhs') body') + +satExpr (StgLet (StgRec [(binder,rhs)]) body) + = satExpr body `thenSAT` \ body' -> + insSAEnv binder (getArgLists rhs) `thenSAT_` + satRhs rhs `thenSAT` \ rhs' -> + saTransform binder rhs' `thenSAT` \ binding -> + returnSAT (StgLet binding body') + +satExpr (StgLet (StgRec binds) body) + = let (binders, rhss) = unzip binds + in + satExpr body `thenSAT` \ body' -> + mapSAT satRhs rhss `thenSAT` \ rhss' -> + returnSAT (StgLet (StgRec (binders `zip` rhss')) body') + +satExpr (StgSCC ty cc expr) + = satExpr expr `thenSAT` \ expr' -> + returnSAT (StgSCC ty cc expr') + +-- ToDo: DPH stuff +\end{code} + +\begin{code} +satRhs rhs@(StgRhsCon cc v args) = returnSAT rhs +satRhs (StgRhsClosure cc bi fvs upd args body) + = satExpr body `thenSAT` \ body' -> + returnSAT (StgRhsClosure cc bi fvs upd args body') + +\end{code} + diff --git a/ghc/compiler/simplStg/StgSATMonad.hi b/ghc/compiler/simplStg/StgSATMonad.hi new file mode 100644 index 0000000000..a6940eb0d3 --- /dev/null +++ b/ghc/compiler/simplStg/StgSATMonad.hi @@ -0,0 +1,22 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface StgSATMonad where +import Class(Class) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import SATMonad(Arg) +import SplitUniq(SplitUniqSupply) +import StgSyn(PlainStgExpr(..), StgBinding, StgExpr, StgRhs) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import UniType(UniType) +import UniqFM(UniqFM) +import Unique(Unique) +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +type PlainStgExpr = StgExpr Id Id +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +getArgLists :: StgRhs Id Id -> ([Arg UniType], [Arg Id]) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +saTransform :: Id -> StgRhs Id Id -> SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> (StgBinding Id Id, UniqFM ([Arg UniType], [Arg Id])) + {-# GHC_PRAGMA _A_ 4 _U_ 2212 _N_ _S_ "LLU(LLL)L" _N_ _N_ #-} + diff --git a/ghc/compiler/simplStg/StgSATMonad.lhs b/ghc/compiler/simplStg/StgSATMonad.lhs new file mode 100644 index 0000000000..f0cb84d4d1 --- /dev/null +++ b/ghc/compiler/simplStg/StgSATMonad.lhs @@ -0,0 +1,182 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +%************************************************************************ +%* * +\section[SATMonad]{The Static Argument Transformation pass Monad} +%* * +%************************************************************************ + +\begin{code} +#include "HsVersions.h" + +module StgSATMonad ( + getArgLists, saTransform, + + Id, UniType, SplitUniqSupply, PlainStgExpr(..) + ) where + +import AbsUniType ( mkTyVarTy, mkSigmaTy, TyVarTemplate, + extractTyVarsFromTy, splitType, splitTyArgs, + glueTyArgs, instantiateTy, TauType(..), + Class, ThetaType(..), SigmaType(..), + InstTyEnv(..) + ) +import IdEnv +import Id ( mkSysLocal, getIdUniType, eqId ) +import Maybes ( Maybe(..) ) +import StgSyn +import SATMonad ( SATEnv(..), SATInfo(..), Arg(..), updSAEnv, insSAEnv, + SatM(..), initSAT, thenSAT, thenSAT_, + emptyEnvSAT, returnSAT, mapSAT, isStatic, dropStatics, + getSATInfo, newSATName ) +import SrcLoc ( SrcLoc, mkUnknownSrcLoc ) +import SplitUniq +import Unique +import UniqSet ( UniqSet(..), emptyUniqSet ) +import Util + +\end{code} + +%************************************************************************ +%* * +\subsection{Utility Functions} +%* * +%************************************************************************ + +\begin{code} +newSATNames :: [Id] -> SatM [Id] +newSATNames [] = returnSAT [] +newSATNames (id:ids) = newSATName id (getIdUniType id) `thenSAT` \ id' -> + newSATNames ids `thenSAT` \ ids' -> + returnSAT (id:ids) + +getArgLists :: PlainStgRhs -> ([Arg UniType],[Arg Id]) +getArgLists (StgRhsCon _ _ _) + = ([],[]) +getArgLists (StgRhsClosure _ _ _ _ args _) + = ([], [Static v | v <- args]) + +\end{code} + +\begin{code} +saTransform :: Id -> PlainStgRhs -> SatM PlainStgBinding +saTransform binder rhs + = getSATInfo binder `thenSAT` \ r -> + case r of + Just (_,args) | any isStatic args + -- [Andre] test: do it only if we have more than one static argument. + --Just (_,args) | length (filter isStatic args) > 1 + -> newSATName binder (new_ty args) `thenSAT` \ binder' -> + let non_static_args = get_nsa args (snd (getArgLists rhs)) + in + newSATNames non_static_args `thenSAT` \ non_static_args' -> + mkNewRhs binder binder' args rhs non_static_args' non_static_args + `thenSAT` \ new_rhs -> + trace ("SAT(STG) "++ show (length (filter isStatic args))) ( + returnSAT (StgNonRec binder new_rhs) + ) + _ -> returnSAT (StgRec [(binder, rhs)]) + + where + get_nsa :: [Arg a] -> [Arg a] -> [a] + get_nsa [] _ = [] + get_nsa _ [] = [] + get_nsa (NotStatic:args) (Static v:as) = v:get_nsa args as + get_nsa (_:args) (_:as) = get_nsa args as + + mkNewRhs binder binder' args rhs@(StgRhsClosure cc bi fvs upd rhsargs body) non_static_args' non_static_args + = let + local_body = StgApp (StgVarAtom binder') + [StgVarAtom a | a <- non_static_args] emptyUniqSet + + rec_body = StgRhsClosure cc bi fvs upd non_static_args' + (doStgSubst binder args subst_env body) + + subst_env = mkIdEnv + ((binder,binder'):zip non_static_args non_static_args') + in + returnSAT ( + StgRhsClosure cc bi fvs upd rhsargs + (StgLet (StgRec [(binder',rec_body)]) {-in-} local_body) + ) + + new_ty args + = instantiateTy [] (mkSigmaTy [] dict_tys' tau_ty') + where + -- get type info for the local function: + (tv_tmpl, dict_tys, tau_ty) = (splitType . getIdUniType) binder + (reg_arg_tys, res_type) = splitTyArgs tau_ty + + -- now, we drop the ones that are + -- static, that is, the ones we will not pass to the local function + l = length dict_tys + dict_tys' = dropStatics (take l args) dict_tys + reg_arg_tys' = dropStatics (drop l args) reg_arg_tys + tau_ty' = glueTyArgs reg_arg_tys' res_type +\end{code} + +NOTE: This does not keep live variable/free variable information!! + +\begin{code} +doStgSubst binder orig_args subst_env body + = substExpr body + where + substExpr (StgConApp con args lvs) + = StgConApp con (map substAtom args) emptyUniqSet + substExpr (StgPrimApp op args lvs) + = StgPrimApp op (map substAtom args) emptyUniqSet + substExpr expr@(StgApp (StgLitAtom _) [] _) + = expr + substExpr (StgApp atom@(StgVarAtom v) args lvs) + | v `eqId` binder + = StgApp (StgVarAtom (lookupNoFailIdEnv subst_env v)) + (remove_static_args orig_args args) emptyUniqSet + | otherwise + = StgApp (substAtom atom) (map substAtom args) lvs + substExpr (StgCase scrut lv1 lv2 uniq alts) + = StgCase (substExpr scrut) emptyUniqSet emptyUniqSet uniq (subst_alts alts) + where + subst_alts (StgAlgAlts ty alg_alts deflt) + = StgAlgAlts ty (map subst_alg_alt alg_alts) (subst_deflt deflt) + subst_alts (StgPrimAlts ty prim_alts deflt) + = StgPrimAlts ty (map subst_prim_alt prim_alts) (subst_deflt deflt) + subst_alg_alt (con, args, use_mask, rhs) + = (con, args, use_mask, substExpr rhs) + subst_prim_alt (lit, rhs) + = (lit, substExpr rhs) + subst_deflt StgNoDefault + = StgNoDefault + subst_deflt (StgBindDefault var used rhs) + = StgBindDefault var used (substExpr rhs) + substExpr (StgLetNoEscape fv1 fv2 b body) + = StgLetNoEscape emptyUniqSet emptyUniqSet (substBinding b) (substExpr body) + substExpr (StgLet b body) + = StgLet (substBinding b) (substExpr body) + substExpr (StgSCC ty cc expr) + = StgSCC ty cc (substExpr expr) + substRhs (StgRhsCon cc v args) + = StgRhsCon cc v (map substAtom args) + substRhs (StgRhsClosure cc bi fvs upd args body) + = StgRhsClosure cc bi [] upd args (substExpr body) + + substBinding (StgNonRec binder rhs) + = StgNonRec binder (substRhs rhs) + substBinding (StgRec pairs) + = StgRec (zip binders (map substRhs rhss)) + where + (binders,rhss) = unzip pairs + + substAtom atom@(StgLitAtom lit) = atom + substAtom atom@(StgVarAtom v) + = case lookupIdEnv subst_env v of + Just v' -> StgVarAtom v' + Nothing -> atom + + remove_static_args _ [] + = [] + remove_static_args (Static _:origs) (_:as) + = remove_static_args origs as + remove_static_args (NotStatic:origs) (a:as) + = substAtom a:remove_static_args origs as +\end{code} diff --git a/ghc/compiler/simplStg/StgStats.hi b/ghc/compiler/simplStg/StgStats.hi new file mode 100644 index 0000000000..7dc9282ed6 --- /dev/null +++ b/ghc/compiler/simplStg/StgStats.hi @@ -0,0 +1,7 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface StgStats where +import Id(Id) +import StgSyn(StgBinding) +showStgStats :: [StgBinding Id Id] -> [Char] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} + diff --git a/ghc/compiler/simplStg/StgStats.lhs b/ghc/compiler/simplStg/StgStats.lhs new file mode 100644 index 0000000000..2b16fc06c9 --- /dev/null +++ b/ghc/compiler/simplStg/StgStats.lhs @@ -0,0 +1,188 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% +\section[StgStats]{Gathers statistical information about programs} + + +The program gather statistics about +\begin{enumerate} +\item number of boxed cases +\item number of unboxed cases +\item number of let-no-escapes +\item number of non-updatable lets +\item number of updatable lets +\item number of applications +\item number of primitive applications +\item number of closures (does not include lets bound to constructors) +\item number of free variables in closures +%\item number of top-level functions +%\item number of top-level CAFs +\item number of constructors +\end{enumerate} + +\begin{code} +#include "HsVersions.h" + +module StgStats ( showStgStats ) where + +import StgSyn + +import FiniteMap + +import Util +\end{code} + +\begin{code} +data CounterType + = AlgCases + | PrimCases + | LetNoEscapes + | NonUpdatableLets + | UpdatableLets + | Applications + | PrimitiveApps + | FreeVariables + | Closures -- does not include lets bound to constructors +--| UpdatableTopLevelDefs +--| NonUpdatableTopLevelDefs + | Constructors + deriving (Eq, Ord, Text) + +type Count = Int +type StatEnv = FiniteMap CounterType Count +\end{code} + +\begin{code} +emptySE :: StatEnv +emptySE = emptyFM + +combineSE :: StatEnv -> StatEnv -> StatEnv +combineSE = plusFM_C (+) + +combineSEs :: [StatEnv] -> StatEnv +combineSEs = foldr combineSE emptySE + +countOne :: CounterType -> StatEnv +countOne c = singletonFM c 1 + +countN :: CounterType -> Int -> StatEnv +countN = singletonFM +\end{code} + +%************************************************************************ +%* * +\subsection{Top-level list of bindings (a ``program'')} +%* * +%************************************************************************ + +\begin{code} +showStgStats :: PlainStgProgram -> String +showStgStats prog = concat (map showc (fmToList (gatherStgStats prog))) + where + showc (AlgCases,n) = "AlgCases " ++ show n ++ "\n" + showc (PrimCases,n) = "PrimCases " ++ show n ++ "\n" + showc (LetNoEscapes,n) = "LetNoEscapes " ++ show n ++ "\n" + showc (NonUpdatableLets,n) = "NonUpdatableLets " ++ show n ++ "\n" + showc (UpdatableLets,n) = "UpdatableLets " ++ show n ++ "\n" + showc (Applications,n) = "Applications " ++ show n ++ "\n" + showc (PrimitiveApps,n) = "PrimitiveApps " ++ show n ++ "\n" + showc (Closures,n) = "Closures " ++ show n ++ "\n" + showc (FreeVariables,n) = "Free Vars in Closures " ++ show n ++ "\n" + showc (Constructors,n) = "Constructors " ++ show n ++ "\n" + +gatherStgStats :: PlainStgProgram -> StatEnv + +gatherStgStats binds + = combineSEs (map statBinding binds) +\end{code} + +%************************************************************************ +%* * +\subsection{Bindings} +%* * +%************************************************************************ + +\begin{code} +statBinding :: PlainStgBinding -> StatEnv + +statBinding (StgNonRec b rhs) + = statRhs (b, rhs) + +statBinding (StgRec pairs) + = combineSEs (map statRhs pairs) + +statRhs :: (Id, PlainStgRhs) -> StatEnv + +statRhs (b, StgRhsCon cc con args) + = countOne Constructors `combineSE` + countOne NonUpdatableLets + +statRhs (b, StgRhsClosure cc bi fv u args body) + = statExpr body `combineSE` + countN FreeVariables (length fv) `combineSE` + countOne Closures `combineSE` + (case u of + Updatable -> countOne UpdatableLets + _ -> countOne NonUpdatableLets) + +\end{code} + +%************************************************************************ +%* * +\subsection{Expressions} +%* * +%************************************************************************ + +\begin{code} +statExpr :: PlainStgExpr -> StatEnv + +statExpr (StgApp _ [] lvs) + = emptySE +statExpr (StgApp _ _ lvs) + = countOne Applications + +statExpr (StgConApp con as lvs) + = countOne Constructors + +statExpr (StgPrimApp op as lvs) + = countOne PrimitiveApps + +statExpr (StgSCC ty l e) + = statExpr e + +statExpr (StgLetNoEscape lvs_whole lvs_rhss binds body) + = statBinding binds `combineSE` + statExpr body `combineSE` + countOne LetNoEscapes + +statExpr (StgLet binds body) + = statBinding binds `combineSE` + statExpr body + +statExpr (StgCase expr lve lva uniq alts) + = statExpr expr `combineSE` + stat_alts alts + where + stat_alts (StgAlgAlts ty alts def) + = combineSEs (map stat_alg_alt alts) `combineSE` + stat_deflt def `combineSE` + countOne AlgCases + where + stat_alg_alt (id, bs, use_mask, e) + = statExpr e + + stat_alts (StgPrimAlts ty alts def) + = combineSEs (map stat_prim_alt alts) `combineSE` + stat_deflt def `combineSE` + countOne PrimCases + where + stat_prim_alt (l, e) + = statExpr e + + stat_deflt StgNoDefault + = emptySE + + stat_deflt (StgBindDefault b u expr) + = statExpr expr +\end{code} + diff --git a/ghc/compiler/simplStg/StgVarInfo.hi b/ghc/compiler/simplStg/StgVarInfo.hi new file mode 100644 index 0000000000..52f36e0ffd --- /dev/null +++ b/ghc/compiler/simplStg/StgVarInfo.hi @@ -0,0 +1,7 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface StgVarInfo where +import Id(Id) +import StgSyn(StgBinding) +setStgVarInfo :: Bool -> [StgBinding Id Id] -> [StgBinding Id Id] + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} + diff --git a/ghc/compiler/simplStg/StgVarInfo.lhs b/ghc/compiler/simplStg/StgVarInfo.lhs new file mode 100644 index 0000000000..10d618c4a7 --- /dev/null +++ b/ghc/compiler/simplStg/StgVarInfo.lhs @@ -0,0 +1,790 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% +\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} +#include "HsVersions.h" + +module StgVarInfo ( setStgVarInfo ) where + +IMPORT_Trace -- ToDo: rm (debugging only) +import Pretty +import Outputable + +import StgSyn + +import Id ( getIdArity, externallyVisibleId ) +import IdInfo -- ( arityMaybe, ArityInfo ) + +import IdEnv +import Maybes ( maybeToBool, Maybe(..) ) +import UniqSet +import Util + +infixr 9 `thenLne`, `thenLne_` +\end{code} + +%************************************************************************ +%* * +\subsection[live-vs-free-doc]{Documentation} +%* * +%************************************************************************ + +(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[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs} +%* * +%************************************************************************ + +Top-level: +\begin{code} +setStgVarInfo :: Bool -- True <=> do let-no-escapes + -> [PlainStgBinding] -- input + -> [PlainStgBinding] -- 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 :: [PlainStgBinding] -> LneM ([PlainStgBinding], FreeVarsInfo) + +varsTopBinds [] = returnLne ([], emptyFVInfo) +varsTopBinds (bind:binds) + = extendVarEnv env_extension ( + varsTopBinds binds `thenLne` \ (binds', fv_binds) -> + varsTopBind fv_binds bind `thenLne` \ (bind', fv_bind) -> + returnLne ((bind' : binds'), + (fv_binds `unionFVInfo` fv_bind) `minusFVBinders` binders + ) + + ) + where + env_extension = [(b, LetrecBound + True {- top level -} + (rhsArity rhs) + emptyUniqSet) + | (b,rhs) <- pairs] + + pairs = case bind of + StgNonRec binder rhs -> [(binder,rhs)] + StgRec pairs -> pairs + + binders = [b | (b,_) <- pairs] + + +varsTopBind :: FreeVarsInfo -- Info about the body + -> PlainStgBinding + -> LneM (PlainStgBinding, FreeVarsInfo) + +varsTopBind body_fvs (StgNonRec binder rhs) + = varsRhs body_fvs (binder,rhs) `thenLne` \ (rhs2, fvs, _) -> + returnLne (StgNonRec binder rhs2, fvs) + +varsTopBind body_fvs (StgRec pairs) + = let + (binders, rhss) = unzip pairs + in + 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,PlainStgRhs) + -> LneM (PlainStgRhs, FreeVarsInfo, EscVarsSet) + +varsRhs scope_fv_info (binder, StgRhsCon cc con args) + = varsAtoms args `thenLne` \ fvs -> + returnLne (StgRhsCon cc con args, fvs, getFVSet fvs) + +varsRhs scope_fv_info (binder, StgRhsClosure cc _ _ upd args body) + = extendVarEnv [ (a, LambdaBound) | a <- args ] ( + do_body args body `thenLne` \ (body2, body_fvs, body_escs) -> + let + set_of_args = mkUniqSet args + rhs_fvs = body_fvs `minusFVBinders` args + rhs_escs = body_escs `minusUniqSet` set_of_args + binder_info = lookupFVInfo scope_fv_info binder + in + returnLne (StgRhsClosure cc binder_info (getFVs rhs_fvs) upd args body2, + rhs_fvs, rhs_escs) + ) + where + -- Pick out special case of application in body of thunk + do_body [] (StgApp (StgVarAtom f) args _) = varsApp (Just upd) f args + do_body _ other_body = varsExpr other_body +\end{code} + +\begin{code} +varsAtoms :: [PlainStgAtom] + -> LneM FreeVarsInfo + +varsAtoms atoms + = mapLne var_atom atoms `thenLne` \ fvs_lists -> + returnLne (unionFVInfos fvs_lists) + where + var_atom a@(StgLitAtom _) = returnLne emptyFVInfo + var_atom a@(StgVarAtom v) + = lookupVarEnv v `thenLne` \ how_bound -> + returnLne (singletonFVInfo v how_bound stgArgOcc) +\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 :: PlainStgExpr + -> LneM (PlainStgExpr, -- 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 (StgApp lit@(StgLitAtom _) args _) + = --(if null args then id else (trace (ppShow 80 (ppr PprShowAll args)))) ( + returnLne (StgApp lit [] emptyUniqSet, emptyFVInfo, emptyUniqSet) + --) + +varsExpr (StgApp fun@(StgVarAtom f) args _) = varsApp Nothing f args + +varsExpr (StgConApp con args _) + = getVarsLiveInCont `thenLne` \ live_in_cont -> + varsAtoms args `thenLne` \ args_fvs -> + + returnLne (StgConApp con args live_in_cont, args_fvs, getFVSet args_fvs) + +varsExpr (StgPrimApp op args _) + = getVarsLiveInCont `thenLne` \ live_in_cont -> + varsAtoms args `thenLne` \ args_fvs -> + + returnLne (StgPrimApp op args live_in_cont, args_fvs, getFVSet args_fvs) + +varsExpr (StgSCC ty label expr) + = varsExpr expr `thenLne` ( \ (expr2, fvs, escs) -> + returnLne (StgSCC ty label expr2, fvs, escs) ) +\end{code} + +Cases require a little more real work. +\begin{code} +varsExpr (StgCase scrut _ _ uniq alts) + = getVarsLiveInCont `thenLne` \ live_in_cont -> + vars_alts alts `thenLne` \ (alts2, alts_fvs, alts_escs) -> + lookupLiveVarsForSet alts_fvs `thenLne` \ alts_lvs -> + let + live_in_alts = live_in_cont `unionUniqSets` alts_lvs + 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 `unionUniqSets` scrut_lvs + in + returnLne ( + StgCase scrut2 live_in_whole_case live_in_alts uniq alts2, + scrut_fvs `unionFVInfo` alts_fvs, + alts_escs `unionUniqSets` (getFVSet scrut_fvs) -- All free vars in the scrutinee escape + ) + where + vars_alts (StgAlgAlts ty alts deflt) + = mapAndUnzip3Lne vars_alg_alt alts + `thenLne` \ (alts2, alts_fvs_list, alts_escs_list) -> + let + alts_fvs = unionFVInfos alts_fvs_list + alts_escs = unionManyUniqSets alts_escs_list + in + vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) -> + returnLne ( + StgAlgAlts ty alts2 deflt2, + alts_fvs `unionFVInfo` deflt_fvs, + alts_escs `unionUniqSets` deflt_escs + ) + where + vars_alg_alt (con, binders, worthless_use_mask, rhs) + = extendVarEnv [(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 `minusUniqSet` mkUniqSet binders -- ToDo: remove the minusUniqSet; + -- since escs won't include + -- any of these binders + )) + + vars_alts (StgPrimAlts ty alts deflt) + = mapAndUnzip3Lne vars_prim_alt alts + `thenLne` \ (alts2, alts_fvs_list, alts_escs_list) -> + let + alts_fvs = unionFVInfos alts_fvs_list + alts_escs = unionManyUniqSets alts_escs_list + in + vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) -> + returnLne ( + StgPrimAlts ty alts2 deflt2, + alts_fvs `unionFVInfo` deflt_fvs, + alts_escs `unionUniqSets` 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, emptyUniqSet) + + vars_deflt (StgBindDefault binder _ rhs) + = extendVarEnv [(binder, CaseBound)] ( + varsExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) -> + let + used_in_rhs = binder `elementOfFVInfo` rhs_fvs + in + returnLne ( + StgBindDefault binder used_in_rhs rhs2, + rhs_fvs `minusFVBinders` [binder], + rhs_escs `minusUniqSet` singletonUniqSet binder + )) +\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} + +\begin{code} +#ifdef DPH +-- rest of varsExpr goes here + +#endif {- Data Parallel Haskell -} +\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 + -> [PlainStgAtom] -- Arguments + -> LneM (PlainStgExpr, FreeVarsInfo, EscVarsSet) + +varsApp maybe_thunk_body f args + = getVarsLiveInCont `thenLne` \ live_in_cont -> + + varsAtoms args `thenLne` \ args_fvs -> + + lookupVarEnv f `thenLne` \ how_bound -> + + let + n_args = length args + + fun_fvs = singletonFVInfo f how_bound fun_occ + + fun_occ = + case how_bound of + LetrecBound _ arity _ + | n_args == 0 -> stgFakeFunAppOcc -- Function Application + -- with no arguments. + -- used by the lambda lifter. + | arity > n_args -> stgUnsatOcc -- Unsaturated + + + | 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 + + other -> NoStgBinderInfo + -- uninteresting variable + + myself = singletonUniqSet f + + fun_escs = case how_bound of + + LetrecBound _ arity lvs -> + if arity == n_args then + emptyUniqSet -- Function doesn't escape + else + myself -- Inexact application; it does escape + + other -> emptyUniqSet -- Only letrec-bound escapees + -- are interesting + + -- 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. + + live_at_call + = live_in_cont `unionUniqSets` case how_bound of + LetrecBound _ _ lvs -> lvs `minusUniqSet` myself + other -> emptyUniqSet + in + returnLne ( + StgApp (StgVarAtom f) args live_at_call, + fun_fvs `unionFVInfo` args_fvs, + fun_escs `unionUniqSets` (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 + -> PlainStgBinding -- bindings + -> PlainStgExpr -- body + -> LneM (PlainStgExpr, -- 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 emptyUniqSet) + (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 `unionUniqSets` 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 + extendVarEnv 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 = if let_no_escape then + -- trace "StgLetNoEscape!" ( + StgLetNoEscape live_in_whole_let bind_lvs bind2 body2 + -- ) + else + StgLet bind2 body2 + + free_in_whole_let + = (bind_fvs `unionFVInfo` body_fvs) `minusFVBinders` binders + + live_in_whole_let + = bind_lvs `unionUniqSets` (body_lvs `minusUniqSet` 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 `unionUniqSets` body_escs) `minusUniqSet` set_of_binders + + all_escs = bind_escs `unionUniqSets` body_escs -- Still includes binders of + -- this let(rec) + + no_binder_escapes = isEmptyUniqSet (set_of_binders `intersectUniqSets` all_escs) + -- 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, + no_binder_escapes + )) + where + binders = case bind of + StgNonRec binder rhs -> [binder] + StgRec pairs -> map fst pairs + set_of_binders = mkUniqSet binders + + mk_binding bind_lvs (binder,rhs) + = (binder, + LetrecBound False -- Not top level + (stgArity rhs) + live_vars + ) + where + live_vars = if let_no_escape then + bind_lvs `unionUniqSets` singletonUniqSet binder + else + singletonUniqSet binder + + vars_bind :: PlainStgLiveVars + -> FreeVarsInfo -- Free var info for body of binding + -> PlainStgBinding + -> LneM (PlainStgBinding, + 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 = [mk_binding rec_bind_lvs (binder,rhs)] + in + returnLne (StgNonRec binder rhs2, fvs, escs, env_ext) + + vars_bind rec_bind_lvs rec_body_fvs (StgRec pairs) + = let + (binders, rhss) = unzip pairs + env_ext = map (mk_binding rec_bind_lvs) pairs + in + extendVarEnv 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 = unionManyUniqSets escss + in + returnLne (StgRec (binders `zip` rhss2), fvs, escs, env_ext) + )) +\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 HowBound + -> PlainStgLiveVars -- vars live in continuation + -> a + +type Arity = Int + +data HowBound + = ImportBound + | CaseBound + | LambdaBound + | LetrecBound + Bool -- True <=> bound at top level + Arity -- Arity + PlainStgLiveVars -- Live vars... see notes below +\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 nullIdEnv emptyUniqSet + +#ifdef __GLASGOW_HASKELL__ +{-# INLINE thenLne #-} +{-# INLINE thenLne_ #-} +{-# INLINE returnLne #-} +#endif + +returnLne :: a -> LneM a +returnLne e sw env lvs_cont = e + +thenLne :: LneM a -> (a -> LneM b) -> LneM b +(m `thenLne` 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 +(m `thenLne_` 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} +{- NOT USED: +ifSwitchSetLne :: GlobalSwitch -> LneM a -> LneM a -> LneM a +ifSwitchSetLne switch then_ else_ switch_checker env lvs_cont + = (if switch_checker switch then then_ else else_) switch_checker env lvs_cont +-} + +isSwitchSetLne :: LneM Bool +isSwitchSetLne want_LNEs env lvs_cont + = want_LNEs + +getVarsLiveInCont :: LneM PlainStgLiveVars +getVarsLiveInCont sw env lvs_cont = lvs_cont + +setVarsLiveInCont :: PlainStgLiveVars -> LneM a -> LneM a +setVarsLiveInCont new_lvs_cont expr sw env lvs_cont + = expr sw env new_lvs_cont + +extendVarEnv :: [(Id, HowBound)] -> LneM a -> LneM a +extendVarEnv extension expr sw env lvs_cont + = expr sw (growIdEnvList env extension) lvs_cont + +lookupVarEnv :: Id -> LneM HowBound +lookupVarEnv v sw env lvs_cont + = returnLne ( + case (lookupIdEnv env v) of + Just xx -> xx + Nothing -> --false:ASSERT(not (isLocallyDefined 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 PlainStgLiveVars + +lookupLiveVarsForSet fvs sw env lvs_cont + = returnLne (unionManyUniqSets (map do_one (getFVs fvs))) + sw env lvs_cont + where + do_one v + = if isLocallyDefined v then + case (lookupIdEnv env v) of + Just (LetrecBound _ _ lvs) -> lvs `unionUniqSets` singletonUniqSet v + Just _ -> singletonUniqSet v + Nothing -> pprPanic "lookupVarEnv/do_one:" (ppr PprShowAll v) + else + emptyUniqSet +\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 = UniqSet Id +\end{code} + +\begin{code} +emptyFVInfo :: FreeVarsInfo +emptyFVInfo = nullIdEnv + +singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo +singletonFVInfo id ImportBound info = nullIdEnv +singletonFVInfo id (LetrecBound top_level _ _) info = unitIdEnv id (id, top_level, info) +singletonFVInfo id other info = unitIdEnv id (id, False, info) + +unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo +unionFVInfo fv1 fv2 = combineIdEnvs plusFVInfo fv1 fv2 + +unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo +unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs + +minusFVBinders :: FreeVarsInfo -> [Id] -> FreeVarsInfo +minusFVBinders fv ids = fv `delManyFromIdEnv` ids + +elementOfFVInfo :: Id -> FreeVarsInfo -> Bool +elementOfFVInfo id fvs = maybeToBool (lookupIdEnv fvs id) + +lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo +lookupFVInfo fvs id = case lookupIdEnv fvs id of + Nothing -> NoStgBinderInfo + Just (_,_,info) -> info + +getFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only +getFVs fvs = [id | (id,False,_) <- rngIdEnv fvs] + +getFVSet :: FreeVarsInfo -> UniqSet Id +getFVSet fvs = mkUniqSet (getFVs fvs) + +plusFVInfo (id1,top1,info1) (id2,top2,info2) + = ASSERT (id1 == id2 && top1 == top2) + (id1, top1, combineStgBinderInfo info1 info2) +\end{code} + +\begin{code} +rhsArity :: PlainStgRhs -> Arity +rhsArity (StgRhsCon _ _ _) = 0 +rhsArity (StgRhsClosure _ _ _ _ args _) = length args +\end{code} + + + diff --git a/ghc/compiler/simplStg/UpdAnal.hi b/ghc/compiler/simplStg/UpdAnal.hi new file mode 100644 index 0000000000..c45043ea8e --- /dev/null +++ b/ghc/compiler/simplStg/UpdAnal.hi @@ -0,0 +1,7 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface UpdAnal where +import Id(Id) +import StgSyn(StgBinding) +updateAnalyse :: [StgBinding Id Id] -> [StgBinding Id Id] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} + diff --git a/ghc/compiler/simplStg/UpdAnal.lhs b/ghc/compiler/simplStg/UpdAnal.lhs new file mode 100644 index 0000000000..a50e672f65 --- /dev/null +++ b/ghc/compiler/simplStg/UpdAnal.lhs @@ -0,0 +1,510 @@ +\section{Update Avoidance Analyser} -*-haskell-literate-*- + +(c) Simon Marlow, Andre Santos 1992-1993 +(c) The AQUA Project, Glasgow University, 1995 + +%----------------------------------------------------------------------------- +\subsection{Module Interface} + +\begin{code} +#include "HsVersions.h" +\end{code} + +> module UpdAnal ( updateAnalyse ) where +> +> IMPORT_Trace + +> import AbsUniType ( splitTyArgs, splitType, Class, TyVarTemplate, +> TauType(..) +> ) +> import Id +> import IdEnv +> import IdInfo +> import Outputable ( isExported ) +> import Pretty +> import SrcLoc ( mkUnknownSrcLoc ) +> import StgSyn +> import UniqSet +> import Unique ( getBuiltinUniques ) +> import Util + +%----------------------------------------------------------------------------- +\subsection{Reverse application} + +This is used instead of lazy pattern bindings to avoid space leaks. + +> infixr 3 =: +> a =: k = k a + +%----------------------------------------------------------------------------- +\subsection{Types} + +List of closure references + +> type Refs = IdSet +> x `notInRefs` y = not (x `elementOfUniqSet` y) + +A closure value: environment of closures that are evaluated on entry, +a list of closures that are referenced from the result, and an +abstract value for the evaluated closure. + +An IdEnv is used for the reference counts, as these environments are +combined often. A generic environment is used for the main environment +mapping closure names to values; as a common operation is extension of +this environment, this representation should be efficient. + +> -- partain: funny synonyms to cope w/ the fact +> -- that IdEnvs know longer know what their keys are +> -- (94/05) ToDo: improve +> type IdEnvInt = IdEnv (Id, Int) +> type IdEnvClosure = IdEnv (Id, Closure) + +> -- backward-compat functions +> null_IdEnv :: IdEnv (Id, a) +> null_IdEnv = nullIdEnv +> +> unit_IdEnv :: Id -> a -> IdEnv (Id, a) +> unit_IdEnv k v = unitIdEnv k (k, v) +> +> mk_IdEnv :: [(Id, a)] -> IdEnv (Id, a) +> mk_IdEnv pairs = mkIdEnv [ (k, (k,v)) | (k,v) <- pairs ] +> +> grow_IdEnv :: IdEnv (Id, a) -> IdEnv (Id, a) -> IdEnv (Id, a) +> grow_IdEnv env1 env2 = growIdEnv env1 env2 +> +> addOneTo_IdEnv :: IdEnv (Id, a) -> Id -> a -> IdEnv (Id, a) +> addOneTo_IdEnv env k v = addOneToIdEnv env k (k, v) +> +> combine_IdEnvs :: (a->a->a) -> IdEnv (Id, a) -> IdEnv (Id, a) -> IdEnv (Id, a) +> combine_IdEnvs combiner env1 env2 = combineIdEnvs new_combiner env1 env2 +> where +> new_combiner (id, x) (_, y) = (id, combiner x y) +> +> dom_IdEnv :: IdEnv (Id, a) -> Refs +> dom_IdEnv env = mkUniqSet [ i | (i,_) <- rngIdEnv env ] +> +> lookup_IdEnv :: IdEnv (Id, a) -> Id -> Maybe a +> lookup_IdEnv env key = case lookupIdEnv env key of +> Nothing -> Nothing +> Just (_,a) -> Just a +> -- end backward compat stuff + +> type Closure = (IdEnvInt, Refs, AbFun) + +> type AbVal = IdEnvClosure -> Closure +> data AbFun = Fun (Closure -> Closure) + +> -- partain: speeding-up stuff +> +> type CaseBoundVars = IdSet +> noCaseBound = emptyUniqSet +> isCaseBound = elementOfUniqSet +> x `notCaseBound` y = not (isCaseBound x y) +> moreCaseBound :: CaseBoundVars -> [Id] -> CaseBoundVars +> moreCaseBound old new = old `unionUniqSets` mkUniqSet new +> +> -- end speeding-up + +%---------------------------------------------------------------------------- +\subsection{Environment lookup} + +If the requested value is not in the environment, we return an unknown +value. Lookup is designed to be partially applied to a variable, and +repeatedly applied to different environments after that. + +> lookup v +> | isImportedId v +> = const (case updateInfoMaybe (getIdUpdateInfo v) of +> Nothing -> unknownClosure +> Just spec -> convertUpdateSpec spec) +> | otherwise +> = \p -> case lookup_IdEnv p v of +> Just b -> b +> Nothing -> unknownClosure + +%----------------------------------------------------------------------------- +Represent a list of references as an ordered list. + +> mkRefs :: [Id] -> Refs +> mkRefs = mkUniqSet + +> noRefs :: Refs +> noRefs = emptyUniqSet + +> elemRefs = elementOfUniqSet + +> merge :: [Refs] -> Refs +> merge xs = foldr merge2 emptyUniqSet xs + +> merge2 :: Refs -> Refs -> Refs +> merge2 = unionUniqSets + +%----------------------------------------------------------------------------- +\subsection{Some non-interesting values} + +bottom will be used for abstract values that are not functions. +Hopefully its value will never be required! + +> bottom :: AbFun +> bottom = panic "Internal: (Update Analyser) bottom" + +noClosure is a value that is definitely not a function (i.e. primitive +values and constructor applications). unknownClosure is a value about +which we have no information at all. This should occur rarely, but +could happen when an id is imported and the exporting module was not +compiled with the update analyser. + +> noClosure, unknownClosure :: Closure +> noClosure = (null_IdEnv, noRefs, bottom) +> unknownClosure = (null_IdEnv, noRefs, dont_know noRefs) + +dont_know is a black hole: it is something we know nothing about. +Applying dont_know to anything will generate a new dont_know that simply +contains more buried references. + +> dont_know :: Refs -> AbFun +> dont_know b' +> = Fun (\(c,b,f) -> let b'' = dom_IdEnv c `merge2` b `merge2` b' +> in (null_IdEnv, b'', dont_know b'')) + +%----------------------------------------------------------------------------- + +> getrefs :: IdEnvClosure -> [AbVal] -> Refs -> Refs +> getrefs p vs rest = foldr merge2 rest (getrefs' (map ($ p) vs)) +> where +> getrefs' [] = [] +> getrefs' ((c,b,_):rs) = dom_IdEnv c : b : getrefs' rs + +%----------------------------------------------------------------------------- + +udData is used when we are putting a list of closure references into a +data structure, or something else that we know nothing about. + +> udData :: [PlainStgAtom] -> CaseBoundVars -> AbVal +> udData vs cvs +> = \p -> (null_IdEnv, getrefs p local_ids noRefs, bottom) +> where local_ids = [ lookup v | (StgVarAtom v) <- vs, v `notCaseBound` cvs ] + +%----------------------------------------------------------------------------- +\subsection{Analysing an atom} + +> udAtom :: CaseBoundVars -> PlainStgAtom -> AbVal +> udAtom cvs (StgVarAtom v) +> | v `isCaseBound` cvs = const unknownClosure +> | otherwise = lookup v +> +> udAtom cvs _ = const noClosure + +%----------------------------------------------------------------------------- +\subsection{Analysing an STG expression} + +> ud :: PlainStgExpr -- Expression to be analysed +> -> CaseBoundVars -- List of case-bound vars +> -> IdEnvClosure -- Current environment +> -> (PlainStgExpr, AbVal) -- (New expression, abstract value) +> +> ud e@(StgPrimApp _ vs _) cvs p = (e, udData vs cvs) +> ud e@(StgConApp _ vs _) cvs p = (e, udData vs cvs) +> ud e@(StgSCC ty lab a) cvs p = ud a cvs p =: \(a', abval_a) -> +> (StgSCC ty lab a', abval_a) + +Here is application. The first thing to do is analyse the head, and +get an abstract function. Multiple applications are performed by using +a foldl with the function doApp. Closures are actually passed to the +abstract function iff the atom is a local variable. + +I've left the type signature for doApp in to make things a bit clearer. + +> ud e@(StgApp a atoms lvs) cvs p +> = (e, abval_app) +> where +> abval_atoms = map (udAtom cvs) atoms +> abval_a = udAtom cvs a +> abval_app = \p -> +> let doApp :: Closure -> AbVal -> Closure +> doApp (c, b, Fun f) abval_atom = +> abval_atom p =: \e@(_,_,_) -> +> f e =: \(c', b', f') -> +> (combine_IdEnvs (+) c' c, b', f') +> in foldl doApp (abval_a p) abval_atoms + +> ud (StgCase expr lve lva uniq alts) cvs p +> = ud expr cvs p =: \(expr', abval_selector) -> +> udAlt alts p =: \(alts', abval_alts) -> +> let +> abval_case = \p -> +> abval_selector p =: \(c, b, abfun_selector) -> +> abval_alts p =: \(cs, bs, abfun_alts) -> +> let bs' = b `merge2` bs in +> (combine_IdEnvs (+) c cs, bs', dont_know bs') +> in +> (StgCase expr' lve lva uniq alts', abval_case) +> where +> +> udAlt :: PlainStgCaseAlternatives +> -> IdEnvClosure +> -> (PlainStgCaseAlternatives, AbVal) +> +> udAlt (StgAlgAlts ty [alt] StgNoDefault) p +> = udAlgAlt p alt =: \(alt', abval) -> +> (StgAlgAlts ty [alt'] StgNoDefault, abval) +> udAlt (StgAlgAlts ty [] def) p +> = udDef def p =: \(def', abval) -> +> (StgAlgAlts ty [] def', abval) +> udAlt (StgAlgAlts ty alts def) p +> = udManyAlts alts def udAlgAlt (StgAlgAlts ty) p +> udAlt (StgPrimAlts ty [alt] StgNoDefault) p +> = udPrimAlt p alt =: \(alt', abval) -> +> (StgPrimAlts ty [alt'] StgNoDefault, abval) +> udAlt (StgPrimAlts ty [] def) p +> = udDef def p =: \(def', abval) -> +> (StgPrimAlts ty [] def', abval) +> udAlt (StgPrimAlts ty alts def) p +> = udManyAlts alts def udPrimAlt (StgPrimAlts ty) p +> +> udPrimAlt p (l, e) +> = ud e cvs p =: \(e', v) -> ((l, e'), v) +> +> udAlgAlt p (id, vs, use_mask, e) +> = ud e (moreCaseBound cvs vs) p =: \(e', v) -> ((id, vs, use_mask, e'), v) +> +> udDef :: PlainStgCaseDefault +> -> IdEnvClosure +> -> (PlainStgCaseDefault, AbVal) +> +> udDef StgNoDefault p +> = (StgNoDefault, \p -> (null_IdEnv, noRefs, dont_know noRefs)) +> udDef (StgBindDefault v is_used expr) p +> = ud expr (moreCaseBound cvs [v]) p =: \(expr', abval) -> +> (StgBindDefault v is_used expr', abval) +> +> udManyAlts alts def udalt stgalts p +> = udDef def p =: \(def', abval_def) -> +> unzip (map (udalt p) alts) =: \(alts', abvals_alts) -> +> let +> abval_alts = \p -> +> abval_def p =: \(cd, bd, _) -> +> unzip3 (map ($ p) abvals_alts) =: \(cs, bs, _) -> +> let bs' = merge (bd:bs) in +> (foldr (combine_IdEnvs max) cd cs, bs', dont_know bs') +> in (stgalts alts' def', abval_alts) + +The heart of the analysis: here we decide whether to make a specific +closure updatable or not, based on the results of analysing the body. + +> ud (StgLet binds body) cvs p +> = udBinding binds cvs p =: \(binds', vs, abval1, abval2) -> +> abval1 p =: \(cs, p') -> +> grow_IdEnv p p' =: \p -> +> ud body cvs p =: \(body', abval_body) -> +> abval_body p =: \(c, b, abfun) -> +> tag b (combine_IdEnvs (+) cs c) binds' =: \tagged_binds -> +> let +> abval p +> = abval2 p =: \(c1, p') -> +> abval_body (grow_IdEnv p p') =: \(c2, b, abfun) -> +> (combine_IdEnvs (+) c1 c2, b, abfun) +> in +> (StgLet tagged_binds body', abval) + +%----------------------------------------------------------------------------- +\subsection{Analysing bindings} + +For recursive sets of bindings we perform one iteration of a fixed +point algorithm, using (dont_know fv) as a safe approximation to the +real fixed point, where fv are the (mappings in the environment of +the) free variables of the function. + +We'll return two new environments, one with the new closures in and +one without. There's no point in carrying around closures when their +respective bindings have already been analysed. + +We don't need to find anything out about closures with arguments, +constructor closures etc. + +> udBinding :: PlainStgBinding +> -> CaseBoundVars +> -> IdEnvClosure +> -> (PlainStgBinding, +> [Id], +> IdEnvClosure -> (IdEnvInt, IdEnvClosure), +> IdEnvClosure -> (IdEnvInt, IdEnvClosure)) +> +> udBinding (StgNonRec v rhs) cvs p +> = udRhs rhs cvs p =: \(rhs', abval) -> +> abval p =: \(c, b, abfun) -> +> let +> abval_rhs a = \p -> +> abval p =: \(c, b, abfun) -> +> (c, unit_IdEnv v (a, b, abfun)) +> a = case rhs of +> StgRhsClosure _ _ _ Updatable [] _ -> unit_IdEnv v 1 +> _ -> null_IdEnv +> in (StgNonRec v rhs', [v], abval_rhs a, abval_rhs null_IdEnv) +> +> udBinding (StgRec ve) cvs p +> = (StgRec ve', [], abval_rhs, abval_rhs) +> where +> (vs, ve', abvals) = unzip3 (map udBind ve) +> fv = (map lookup . filter (`notCaseBound` cvs) . concat . map collectfv) ve +> vs' = mkRefs vs +> abval_rhs = \p -> +> let +> p' = grow_IdEnv (mk_IdEnv (vs `zip` (repeat closure))) p +> closure = (null_IdEnv, fv', dont_know fv') +> fv' = getrefs p fv vs' +> (cs, ps) = unzip (doRec vs abvals) +> +> doRec [] _ = [] +> doRec (v:vs) (abval:as) +> = abval p' =: \(c,b,abfun) -> +> (c, (v,(null_IdEnv, b, abfun))) : doRec vs as +> +> in +> (foldr (combine_IdEnvs (+)) null_IdEnv cs, mk_IdEnv ps) +> +> udBind (v,rhs) +> = udRhs rhs cvs p =: \(rhs', abval) -> +> (v,(v,rhs'), abval) +> +> collectfv (_, StgRhsClosure _ _ fv _ _ _) = fv +> collectfv (_, StgRhsCon _ con args) = [ v | (StgVarAtom v) <- args ] + +%----------------------------------------------------------------------------- +\subsection{Analysing Right-Hand Sides} + +> udRhs e@(StgRhsCon _ _ vs) cvs p = (e, udData vs cvs) +> +> udRhs (StgRhsClosure cc bi fv u [] body) cvs p +> = ud body cvs p =: \(body', abval_body) -> +> (StgRhsClosure cc bi fv u [] body', abval_body) + +Here is the code for closures with arguments. A closure has a number +of arguments, which correspond to a set of nested lambda expressions. +We build up the analysis using foldr with the function doLam to +analyse each lambda expression. + +> udRhs (StgRhsClosure cc bi fv u args body) cvs p +> = ud body cvs p =: \(body', abval_body) -> +> let +> fv' = map lookup (filter (`notCaseBound` cvs) fv) +> abval_rhs = \p -> +> foldr doLam (\b -> abval_body) args (getrefs p fv' noRefs) p +> in +> (StgRhsClosure cc bi fv u args body', abval_rhs) +> where +> +> doLam :: Id -> (Refs -> AbVal) -> Refs -> AbVal +> doLam i f b p +> = (null_IdEnv, b, +> Fun (\x@(c',b',_) -> +> let b'' = dom_IdEnv c' `merge2` b' `merge2` b in +> f b'' (addOneTo_IdEnv p i x))) + +%----------------------------------------------------------------------------- +\subsection{Adjusting Update flags} + +The closure is tagged single entry iff it is used at most once, it is +not referenced from inside a data structure or function, and it has no +arguments (closures with arguments are re-entrant). + +> tag :: Refs -> IdEnvInt -> PlainStgBinding -> PlainStgBinding +> +> tag b c r@(StgNonRec v (StgRhsClosure cc bi fv Updatable [] body)) +> = if (v `notInRefs` b) && (lookupc c v <= 1) +> then -- trace "One!" ( +> StgNonRec v (StgRhsClosure cc bi fv SingleEntry [] body) +> -- ) +> else r +> tag b c other = other +> +> lookupc c v = case lookup_IdEnv c v of +> Just n -> n +> Nothing -> 0 + +%----------------------------------------------------------------------------- +\subsection{Top Level analysis} + +Should we tag top level closures? This could have good implications +for CAFs (i.e. they could be made non-updateable if only used once, +thus preventing a space leak). + +> updateAnalyse :: PlainStgProgram -> PlainStgProgram {- Exported -} +> updateAnalyse bs +> = udProgram bs null_IdEnv + +> udProgram :: PlainStgProgram -> IdEnvClosure -> PlainStgProgram +> udProgram [] p = [] +> udProgram (d:ds) p +> = udBinding d noCaseBound p =: \(d', vs, _, abval_bind) -> +> abval_bind p =: \(_, p') -> +> grow_IdEnv p p' =: \p'' -> +> attachUpdateInfoToBinds d' p'' =: \d'' -> +> d'' : udProgram ds p'' + +%----------------------------------------------------------------------------- +\subsection{Exporting Update Information} + +Convert the exported representation of a function's update function +into a real Closure value. + +> convertUpdateSpec :: UpdateSpec -> Closure +> convertUpdateSpec = mkClosure null_IdEnv noRefs noRefs + +> mkClosure :: IdEnvInt -> Refs -> Refs -> UpdateSpec -> Closure +> +> mkClosure c b b' [] = (c, b', dont_know b') +> mkClosure c b b' (0 : ns) = (null_IdEnv, b, Fun (\ _ -> mkClosure c b b' ns)) +> mkClosure c b b' (1 : ns) = (null_IdEnv, b, Fun (\ (c',b'',f) -> +> mkClosure +> (combine_IdEnvs (+) c c') +> (dom_IdEnv c' `merge2` b'' `merge2` b) +> (b'' `merge2` b') +> ns )) +> mkClosure c b b' (n : ns) = (null_IdEnv, b, Fun (\ (c',b'',f) -> +> mkClosure c +> (dom_IdEnv c' `merge2` b'' `merge2` b) +> (dom_IdEnv c' `merge2` b'' `merge2` b') +> ns )) + +Convert a Closure into a representation that can be placed in a .hi file. + +> mkUpdateSpec :: Id -> Closure -> UpdateSpec +> mkUpdateSpec v f = {- removeSuperfluous2s -} (map countUses ids) +> where +> (c,b,_) = foldl doApp f ids +> ids = map mkid (getBuiltinUniques arity) +> mkid u = mkSysLocal SLIT("upd") u noType mkUnknownSrcLoc +> countUses u = if u `elemRefs` b then 2 else min (lookupc c u) 2 +> noType = panic "UpdAnal: no type!" +> +> doApp (c,b,Fun f) i +> = f (unit_IdEnv i 1, noRefs, dont_know noRefs) =: \(c',b',f') -> +> (combine_IdEnvs (+) c' c, b', f') +> +> (_,dict_tys,tau_ty) = (splitType . getIdUniType) v +> (reg_arg_tys, _) = splitTyArgs tau_ty +> arity = length dict_tys + length reg_arg_tys + + removeSuperfluous2s = reverse . dropWhile (> 1) . reverse + +%----------------------------------------------------------------------------- +\subsection{Attaching the update information to top-level bindings} + +This is so that the information can later be retrieved for printing +out in the .hi file. This is not an ideal solution, however it will +suffice for now. + +> attachUpdateInfoToBinds b p +> = case b of +> StgNonRec v rhs -> StgNonRec (attachOne v) rhs +> StgRec bs -> StgRec [ (attachOne v, rhs) | (v, rhs) <- bs ] +> +> where attachOne v +> | isExported v +> = let c = lookup v p in +> addIdUpdateInfo v +> (mkUpdateInfo (mkUpdateSpec v c)) +> | otherwise = v + +%----------------------------------------------------------------------------- |