X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FOccurAnal.lhs;h=ae09f03adfcf76d0f8b6ce86050404809f01e15b;hb=ca0b7c66f2e8e50f15a03c406408d9e86455f8eb;hp=48da14b010a6b0a0d1baa8385594cb3e2ad83ca9;hpb=fdc830018cb48210e2ca441942de8eae8e6aedd2;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index 48da14b..ae09f03 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -20,25 +20,25 @@ module OccurAnal ( import CoreSyn import CoreFVs ( idRuleVars ) import CoreUtils ( exprIsTrivial ) -import Id ( isDataConId, isOneShotLambda, setOneShotLambda, +import Id ( isDataConWorkId, isOneShotLambda, setOneShotLambda, idOccInfo, setIdOccInfo, - isExportedId, modifyIdInfo, idInfo, + isExportedId, modifyIdInfo, idInfo, idArity, idSpecialisation, isLocalId, idType, idUnique, Id ) -import IdInfo ( OccInfo(..), shortableIdInfo, copyIdInfo ) +import IdInfo ( copyIdInfo ) +import BasicTypes ( OccInfo(..), isOneOcc ) import VarSet import VarEnv -import Type ( splitFunTy_maybe, splitForAllTys ) -import Maybes ( maybeToBool, orElse ) +import Type ( isFunTy, dropForAlls ) +import Maybes ( orElse ) import Digraph ( stronglyConnCompR, SCC(..) ) import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey ) import Unique ( Unique ) import UniqFM ( keysUFM ) import Util ( zipWithEqual, mapAndUnzip ) -import FastTypes import Outputable \end{code} @@ -52,29 +52,19 @@ import Outputable Here's the externally-callable interface: \begin{code} -occurAnalyseExpr :: (Id -> Bool) -- Tells if a variable is interesting - -> CoreExpr - -> (IdEnv OccInfo, -- Occ info for interesting free vars - CoreExpr) - -occurAnalyseExpr interesting expr - = occAnal initial_env expr - where - initial_env = OccEnv interesting emptyVarSet [] - occurAnalyseGlobalExpr :: CoreExpr -> CoreExpr occurAnalyseGlobalExpr expr = -- Top level expr, so no interesting free vars, and -- discard occurence info returned - snd (occurAnalyseExpr (\_ -> False) expr) + snd (occAnal (initOccEnv emptyVarSet) expr) occurAnalyseRule :: CoreRule -> CoreRule -occurAnalyseRule rule@(BuiltinRule _) = rule -occurAnalyseRule (Rule str tpl_vars tpl_args rhs) +occurAnalyseRule rule@(BuiltinRule _ _) = rule +occurAnalyseRule (Rule str act tpl_vars tpl_args rhs) -- Add occ info to tpl_vars, rhs - = Rule str tpl_vars' tpl_args rhs' + = Rule str act tpl_vars' tpl_args rhs' where - (rhs_uds, rhs') = occurAnalyseExpr isLocalId rhs + (rhs_uds, rhs') = occAnal (initOccEnv (mkVarSet tpl_vars)) rhs (_, tpl_vars') = tagBinders rhs_uds tpl_vars \end{code} @@ -137,7 +127,7 @@ occurAnalyseBinds :: [CoreBind] -> [CoreBind] occurAnalyseBinds binds = binds' where - (_, _, binds') = go initialTopEnv binds + (_, _, binds') = go (initOccEnv emptyVarSet) binds go :: OccEnv -> [CoreBind] -> (UsageDetails, -- Occurrence info @@ -173,10 +163,6 @@ occurAnalyseBinds binds other -> -- Ho ho! The normal case (final_usage, ind_env, new_binds ++ binds') -initialTopEnv = OccEnv isLocalId -- Anything local is interesting - emptyVarSet - [] - -- Deal with any indirections zapBind ind_env (NonRec bndr rhs) @@ -209,10 +195,18 @@ shortMeOut ind_env exported_id local_id not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for then + True + +{- No longer needed if shortableIdInfo (idInfo exported_id) -- Only if its IdInfo is 'shortable' -- (see the defn of IdInfo.shortableIdInfo) then True - else pprTrace "shortMeOut:" (ppr exported_id) False + else +#ifdef DEBUG + pprTrace "shortMeOut:" (ppr exported_id) +#endif + False +-} else False \end{code} @@ -252,7 +246,7 @@ occAnalBind env (NonRec binder rhs) body_usage where (final_body_usage, tagged_binder) = tagBinder body_usage binder - (rhs_usage, rhs') = occAnalRhs env binder rhs + (rhs_usage, rhs') = occAnalRhs env tagged_binder rhs \end{code} Dropping dead code for recursive bindings is done in a very simple way: @@ -479,9 +473,7 @@ reOrderRec env (CyclicSCC (bind : binds)) inlineCandidate :: Id -> CoreExpr -> Bool inlineCandidate id (Note InlineMe _) = True - inlineCandidate id rhs = case idOccInfo id of - OneOcc _ _ -> True - other -> False + inlineCandidate id rhs = isOneOcc (idOccInfo id) -- Real example (the Enum Ordering instance from PrelBase): -- rec f = \ x -> case d of (p,q,r) -> p x @@ -493,9 +485,7 @@ reOrderRec env (CyclicSCC (bind : binds)) -- we didn't stupidly choose d as the loop breaker. -- But we won't because constructor args are marked "Many". - not_fun_ty ty = not (maybeToBool (splitFunTy_maybe rho_ty)) - where - (_, rho_ty) = splitForAllTys ty + not_fun_ty ty = not (isFunTy (dropForAlls ty)) \end{code} @occAnalRhs@ deals with the question of bindings where the Id is marked @@ -512,12 +502,34 @@ ToDo: try using the occurrence info for the inline'd binder. \begin{code} occAnalRhs :: OccEnv -> Id -> CoreExpr -- Binder and rhs + -- For non-recs the binder is alrady tagged + -- with occurrence info -> (UsageDetails, CoreExpr) occAnalRhs env id rhs = (final_usage, rhs') where - (rhs_usage, rhs') = occAnal (zapCtxt env) rhs + (rhs_usage, rhs') = occAnal ctxt rhs + ctxt | certainly_inline id = env + | otherwise = rhsCtxt env + -- Note that we generally use an rhsCtxt. This tells the occ anal n + -- that it's looking at an RHS, which has an effect in occAnalApp + -- + -- But there's a problem. Consider + -- x1 = a0 : [] + -- x2 = a1 : x1 + -- x3 = a2 : x2 + -- g = f x3 + -- First time round, it looks as if x1 and x2 occur as an arg of a + -- let-bound constructor ==> give them a many-occurrence. + -- But then x3 is inlined (unconditionally as it happens) and + -- next time round, x2 will be, and the next time round x1 will be + -- Result: multiple simplifier iterations. Sigh. + -- Crude solution: use rhsCtxt for things that occur just once... + + certainly_inline id = case idOccInfo id of + OneOcc in_lam one_br -> not in_lam && one_br + other -> False -- [March 98] A new wrinkle is that if the binder has specialisations inside -- it then we count the specialised Ids as "extra rhs's". That way @@ -529,6 +541,7 @@ occAnalRhs env id rhs add v u = addOneOcc u v NoOccInfo -- Give a non-committal binder info -- (i.e manyOcc) because many copies -- of the specialised thing can appear + \end{code} Expressions @@ -594,7 +607,7 @@ occAnal env (Note note body) \begin{code} occAnal env app@(App fun arg) - = occAnalApp env (collectArgs app) + = occAnalApp env (collectArgs app) False -- Ignore type variables altogether -- (a) occurrences inside type lambdas only not marked as InsideLam @@ -615,7 +628,7 @@ occAnal env expr@(Lam x body) | isTyVar x -- Then, the simplifier is careful when partially applying lambdas. occAnal env expr@(Lam _ _) - = case occAnal (env_body `addNewCands` binders) body of { (body_usage, body') -> + = case occAnal env_body body of { (body_usage, body') -> let (final_usage, tagged_binders) = tagBinders body_usage binders -- URGH! Sept 99: we don't seem to be able to use binders' here, because @@ -630,12 +643,15 @@ occAnal env expr@(Lam _ _) (really_final_usage, mkLams tagged_binders body') } where - (binders, body) = collectBinders expr - (linear, env_body, _) = oneShotGroup env binders + (binders, body) = collectBinders expr + (linear, env1, _) = oneShotGroup env binders + env2 = env1 `addNewCands` binders -- Add in-scope binders + env_body = vanillaCtxt env2 -- Body is (no longer) an RhsContext occAnal env (Case scrut bndr alts) - = case mapAndUnzip (occAnalAlt alt_env) alts of { (alts_usage_s, alts') -> - case occAnal (zapCtxt env) scrut of { (scrut_usage, scrut') -> + = case mapAndUnzip (occAnalAlt alt_env bndr) alts of { (alts_usage_s, alts') -> + case occAnal (vanillaCtxt env) scrut of { (scrut_usage, scrut') -> + -- No need for rhsCtxt let alts_usage = foldr1 combineAltsUsageDetails alts_usage_s alts_usage' = addCaseBndrUsage alts_usage @@ -668,7 +684,7 @@ occAnalArgs env args = case mapAndUnzip (occAnal arg_env) args of { (arg_uds_s, args') -> (foldr combineUsageDetails emptyDetails arg_uds_s, args')} where - arg_env = zapCtxt env + arg_env = vanillaCtxt env \end{code} Applications are dealt with specially because we want @@ -676,12 +692,23 @@ the "build hack" to work. \begin{code} -- Hack for build, fold, runST -occAnalApp env (Var fun, args) +occAnalApp env (Var fun, args) is_rhs = case args_stuff of { (args_uds, args') -> let - final_uds = fun_uds `combineUsageDetails` args_uds + -- We mark the free vars of the argument of a constructor or PAP + -- as "many", if it is the RHS of a let(rec). + -- This means that nothing gets inlined into a constructor argument + -- position, which is what we want. Typically those constructor + -- arguments are just variables, or trivial expressions. + -- + -- This is the *whole point* of the isRhsEnv predicate + final_args_uds + | isRhsEnv env, + isDataConWorkId fun || valArgCount args < idArity fun + = mapVarEnv markMany args_uds + | otherwise = args_uds in - (final_uds, mkApps (Var fun) args') } + (fun_uds `combineUsageDetails` final_args_uds, mkApps (Var fun) args') } where fun_uniq = idUnique fun @@ -691,39 +718,49 @@ occAnalApp env (Var fun, args) args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args | fun_uniq == augmentIdKey = appSpecial env 2 [True,True] args | fun_uniq == foldrIdKey = appSpecial env 3 [False,True] args - | fun_uniq == runSTRepIdKey = appSpecial env 2 [True] args - - | isDataConId fun = case occAnalArgs env args of - (arg_uds, args') -> (mapVarEnv markMany arg_uds, args') - -- We mark the free vars of the argument of a constructor as "many" - -- This means that nothing gets inlined into a constructor argument - -- position, which is what we want. Typically those constructor - -- arguments are just variables, or trivial expressions. - - | otherwise = occAnalArgs env args - - -occAnalApp env (fun, args) - = case occAnal (zapCtxt env) fun of { (fun_uds, fun') -> - case occAnalArgs env args of { (args_uds, args') -> + | fun_uniq == runSTRepIdKey = appSpecial env 2 [True] args + -- (foldr k z xs) may call k many times, but it never + -- shares a partial application of k; hence [False,True] + -- This means we can optimise + -- foldr (\x -> let v = ...x... in \y -> ...v...) z xs + -- by floating in the v + + | otherwise = occAnalArgs env args + + +occAnalApp env (fun, args) is_rhs + = case occAnal (addAppCtxt env args) fun of { (fun_uds, fun') -> + -- The addAppCtxt is a bit cunning. One iteration of the simplifier + -- often leaves behind beta redexs like + -- (\x y -> e) a1 a2 + -- Here we would like to mark x,y as one-shot, and treat the whole + -- thing much like a let. We do this by pushing some True items + -- onto the context stack. + + case occAnalArgs env args of { (args_uds, args') -> let final_uds = fun_uds `combineUsageDetails` args_uds in (final_uds, mkApps fun' args') }} -appSpecial :: OccEnv -> Int -> CtxtTy -> [CoreExpr] -> (UsageDetails, [CoreExpr]) +appSpecial :: OccEnv + -> Int -> CtxtTy -- Argument number, and context to use for it + -> [CoreExpr] + -> (UsageDetails, [CoreExpr]) appSpecial env n ctxt args = go n args where + arg_env = vanillaCtxt env + go n [] = (emptyDetails, []) -- Too few args go 1 (arg:args) -- The magic arg - = case occAnal (setCtxt env ctxt) arg of { (arg_uds, arg') -> - case occAnalArgs env args of { (args_uds, args') -> + = case occAnal (setCtxt arg_env ctxt) arg of { (arg_uds, arg') -> + case occAnalArgs env args of { (args_uds, args') -> (combineUsageDetails arg_uds args_uds, arg':args') }} go n (arg:args) - = case occAnal env arg of { (arg_uds, arg') -> + = case occAnal arg_env arg of { (arg_uds, arg') -> case go (n-1) args of { (args_uds, args') -> (combineUsageDetails arg_uds args_uds, arg':args') }} \end{code} @@ -731,31 +768,53 @@ appSpecial env n ctxt args Case alternatives ~~~~~~~~~~~~~~~~~ +If the case binder occurs at all, the other binders effectively do too. +For example + case e of x { (a,b) -> rhs } +is rather like + let x = (a,b) in rhs +If e turns out to be (e1,e2) we indeed get something like + let a = e1; b = e2; x = (a,b) in rhs + \begin{code} -occAnalAlt env (con, bndrs, rhs) +occAnalAlt env case_bndr (con, bndrs, rhs) = case occAnal (env `addNewCands` bndrs) rhs of { (rhs_usage, rhs') -> let (final_usage, tagged_bndrs) = tagBinders rhs_usage bndrs + final_bndrs | case_bndr `elemVarEnv` final_usage = bndrs + | otherwise = tagged_bndrs + -- Leave the binders untagged if the case + -- binder occurs at all; see note above in - (final_usage, (con, tagged_bndrs, rhs')) } + (final_usage, (con, final_bndrs, rhs')) } \end{code} %************************************************************************ %* * -\subsection[OccurAnal-types]{Data types} +\subsection[OccurAnal-types]{OccEnv} %* * %************************************************************************ \begin{code} --- We gather inforamtion for variables that are either --- (a) in scope or --- (b) interesting - -data OccEnv = - OccEnv (Id -> Bool) -- Tells whether an Id occurrence is interesting, - IdSet -- In-scope Ids - CtxtTy -- Tells about linearity +data OccEnv + = OccEnv IdSet -- In-scope Ids; we gather info about these only + OccEncl -- Enclosing context information + CtxtTy -- Tells about linearity + +-- OccEncl is used to control whether to inline into constructor arguments +-- For example: +-- x = (p,q) -- Don't inline p or q +-- y = /\a -> (p a, q a) -- Still don't inline p or q +-- z = f (p,q) -- Do inline p,q; it may make a rule fire +-- So OccEncl tells enought about the context to know what to do when +-- we encounter a contructor application or PAP. + +data OccEncl + = OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda + -- Don't inline into constructor args here + | OccVanilla -- Argument of function, body of lambda, scruintee of case etc. + -- Do inline into constructor args here type CtxtTy = [Bool] -- [] No info @@ -767,19 +826,25 @@ type CtxtTy = [Bool] -- be applied many times; but when it is, -- the CtxtTy inside applies +initOccEnv :: VarSet -> OccEnv +initOccEnv vars = OccEnv vars OccRhs [] + +isRhsEnv (OccEnv _ OccRhs _) = True +isRhsEnv (OccEnv _ OccVanilla _) = False + isCandidate :: OccEnv -> Id -> Bool -isCandidate (OccEnv ifun cands _) id = id `elemVarSet` cands || ifun id +isCandidate (OccEnv cands encl _) id = id `elemVarSet` cands addNewCands :: OccEnv -> [Id] -> OccEnv -addNewCands (OccEnv ifun cands ctxt) ids - = OccEnv ifun (cands `unionVarSet` mkVarSet ids) ctxt +addNewCands (OccEnv cands encl ctxt) ids + = OccEnv (extendVarSetList cands ids) encl ctxt addNewCand :: OccEnv -> Id -> OccEnv -addNewCand (OccEnv ifun cands ctxt) id - = OccEnv ifun (extendVarSet cands id) ctxt +addNewCand (OccEnv cands encl ctxt) id + = OccEnv (extendVarSet cands id) encl ctxt setCtxt :: OccEnv -> CtxtTy -> OccEnv -setCtxt (OccEnv ifun cands _) ctxt = OccEnv ifun cands ctxt +setCtxt (OccEnv cands encl _) ctxt = OccEnv cands encl ctxt oneShotGroup :: OccEnv -> [CoreBndr] -> (Bool, OccEnv, [CoreBndr]) -- True <=> this is a one-shot linear lambda group @@ -790,9 +855,9 @@ oneShotGroup :: OccEnv -> [CoreBndr] -> (Bool, OccEnv, [CoreBndr]) -- linearity context knows that c,n are one-shot, and it records that fact in -- the binder. This is useful to guide subsequent float-in/float-out tranformations -oneShotGroup (OccEnv ifun cands ctxt) bndrs +oneShotGroup (OccEnv cands encl ctxt) bndrs = case go ctxt bndrs [] of - (new_ctxt, new_bndrs) -> (all is_one_shot new_bndrs, OccEnv ifun cands new_ctxt, new_bndrs) + (new_ctxt, new_bndrs) -> (all is_one_shot new_bndrs, OccEnv cands encl new_ctxt, new_bndrs) where is_one_shot b = isId b && isOneShotLambda b @@ -807,9 +872,20 @@ oneShotGroup (OccEnv ifun cands ctxt) bndrs go ctxt (bndr:bndrs) rev_bndrs = go ctxt bndrs (bndr:rev_bndrs) -zapCtxt env@(OccEnv ifun cands []) = env -zapCtxt (OccEnv ifun cands _ ) = OccEnv ifun cands [] +vanillaCtxt (OccEnv cands _ _) = OccEnv cands OccVanilla [] +rhsCtxt (OccEnv cands _ _) = OccEnv cands OccRhs [] + +addAppCtxt (OccEnv cands encl ctxt) args + = OccEnv cands encl (replicate (valArgCount args) True ++ ctxt) +\end{code} +%************************************************************************ +%* * +\subsection[OccurAnal-types]{OccEnv} +%* * +%************************************************************************ + +\begin{code} type UsageDetails = IdEnv OccInfo -- A finite map from ids to their usage combineUsageDetails, combineAltsUsageDetails