+Note [Binders in case alternatives]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ case x of y { (a,b) -> f y }
+We treat 'a', 'b' as dead, because they don't physically occur in the
+case alternative. (Indeed, a variable is dead iff it doesn't occur in
+its scope in the output of OccAnal.) It really helps to know when
+binders are unused. See esp the call to isDeadBinder in
+Simplify.mkDupableAlt
+
+In this example, though, the Simplifier will bring 'a' and 'b' back to
+life, beause it binds 'y' to (a,b) (imagine got inlined and
+scrutinised y).
+
+\begin{code}
+occAnalAlt :: OccEnv
+ -> CoreBndr
+ -> CoreAlt
+ -> (UsageDetails, Alt IdWithOccInfo)
+occAnalAlt env case_bndr (con, bndrs, rhs)
+ = let
+ env' = trimOccEnv env bndrs
+ in
+ case occAnal env' rhs of { (rhs_usage1, rhs1) ->
+ let
+ proxies = getProxies env' case_bndr
+ (rhs_usage2, rhs2) = foldrBag wrapProxy (rhs_usage1, rhs1) proxies
+ (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage2 bndrs
+ bndrs' = tagged_bndrs -- See Note [Binders in case alternatives]
+ in
+ (alt_usg, (con, bndrs', rhs2)) }
+
+wrapProxy :: ProxyBind -> (UsageDetails, CoreExpr) -> (UsageDetails, CoreExpr)
+wrapProxy (bndr, rhs_var, co) (body_usg, body)
+ | not (bndr `usedIn` body_usg)
+ = (body_usg, body)
+ | otherwise
+ = (body_usg' +++ rhs_usg, Let (NonRec tagged_bndr rhs) body)
+ where
+ (body_usg', tagged_bndr) = tagBinder body_usg bndr
+ rhs_usg = unitVarEnv rhs_var NoOccInfo -- We don't need exact info
+ rhs = mkCoerce co (Var (zapIdOccInfo rhs_var)) -- See Note [Zap case binders in proxy bindings]
+\end{code}
+
+
+%************************************************************************
+%* *
+ OccEnv
+%* *
+%************************************************************************
+
+\begin{code}
+data OccEnv
+ = OccEnv { occ_encl :: !OccEncl -- Enclosing context information
+ , occ_ctxt :: !CtxtTy -- Tells about linearity
+ , occ_proxy :: ProxyEnv
+ , occ_rule_fvs :: ImpRuleUsage
+ , occ_rule_act :: Maybe (Activation -> Bool) -- Nothing => Rules are inactive
+ -- See Note [Finding rule RHS free vars]
+ }
+
+
+-----------------------------
+-- 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
+
+instance Outputable OccEncl where
+ ppr OccRhs = ptext (sLit "occRhs")
+ ppr OccVanilla = ptext (sLit "occVanilla")
+
+type CtxtTy = [Bool]
+ -- [] No info
+ --
+ -- True:ctxt Analysing a function-valued expression that will be
+ -- applied just once
+ --
+ -- False:ctxt Analysing a function-valued expression that may
+ -- be applied many times; but when it is,
+ -- the CtxtTy inside applies
+
+initOccEnv :: Maybe (Activation -> Bool) -> [CoreRule]
+ -> OccEnv
+initOccEnv active_rule imp_rules
+ = OccEnv { occ_encl = OccVanilla
+ , occ_ctxt = []
+ , occ_proxy = PE emptyVarEnv emptyVarSet
+ , occ_rule_fvs = findImpRuleUsage active_rule imp_rules
+ , occ_rule_act = active_rule }
+
+vanillaCtxt :: OccEnv -> OccEnv
+vanillaCtxt env = env { occ_encl = OccVanilla, occ_ctxt = [] }
+
+rhsCtxt :: OccEnv -> OccEnv
+rhsCtxt env = env { occ_encl = OccRhs, occ_ctxt = [] }
+
+setCtxtTy :: OccEnv -> CtxtTy -> OccEnv
+setCtxtTy env ctxt = env { occ_ctxt = ctxt }
+
+isRhsEnv :: OccEnv -> Bool
+isRhsEnv (OccEnv { occ_encl = OccRhs }) = True
+isRhsEnv (OccEnv { occ_encl = OccVanilla }) = False
+
+oneShotGroup :: OccEnv -> [CoreBndr] -> [CoreBndr]
+ -- The result binders have one-shot-ness set that they might not have had originally.
+ -- This happens in (build (\cn -> e)). Here the occurrence analyser
+ -- 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 { occ_ctxt = ctxt }) bndrs
+ = go ctxt bndrs []
+ where
+ go _ [] rev_bndrs = reverse rev_bndrs
+
+ go (lin_ctxt:ctxt) (bndr:bndrs) rev_bndrs
+ | isId bndr = go ctxt bndrs (bndr':rev_bndrs)
+ where
+ bndr' | lin_ctxt = setOneShotLambda bndr
+ | otherwise = bndr
+
+ go ctxt (bndr:bndrs) rev_bndrs = go ctxt bndrs (bndr:rev_bndrs)
+
+addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv
+addAppCtxt env@(OccEnv { occ_ctxt = ctxt }) args
+ = env { occ_ctxt = replicate (valArgCount args) True ++ ctxt }
+\end{code}
+
+%************************************************************************
+%* *
+ ImpRuleUsage
+%* *
+%************************************************************************
+
+\begin{code}
+type ImpRuleUsage = NameEnv UsageDetails
+ -- Maps an *imported* Id f to the UsageDetails for *local* Ids
+ -- used on the RHS for a *local* rule for f.
+\end{code}
+
+Note [ImpRuleUsage]
+~~~~~~~~~~~~~~~~
+Consider this, where A.g is an imported Id
+
+ f x = A.g x
+ {-# RULE "foo" forall x. A.g x = f x #-}
+
+Obviously there's a loop, but the danger is that the occurrence analyser
+will say that 'f' is not a loop breaker. Then the simplifier will
+optimise 'f' to
+ f x = f x
+and then gaily inline 'f'. Result infinite loop. More realistically,
+these kind of rules are generated when specialising imported INLINABLE Ids.
+
+Solution: treat an occurrence of A.g as an occurrence of all the local Ids
+that occur on the RULE's RHS. This mapping from imported Id to local Ids
+is held in occ_rule_fvs.
+
+\begin{code}
+findImpRuleUsage :: Maybe (Activation -> Bool) -> [CoreRule] -> ImpRuleUsage
+-- Find the *local* Ids that can be reached transitively,
+-- via local rules, from each *imported* Id.
+-- Sigh: this function seems more complicated than it is really worth
+findImpRuleUsage Nothing _ = emptyNameEnv
+findImpRuleUsage (Just is_active) rules
+ = mkNameEnv [ (f, mapUFM (\_ -> NoOccInfo) ls)
+ | f <- rule_names
+ , let ls = find_lcl_deps f
+ , not (isEmptyVarSet ls) ]
+ where
+ rule_names = map ru_fn rules
+ rule_name_set = mkNameSet rule_names
+
+ imp_deps :: NameEnv VarSet
+ -- (f,g) means imported Id 'g' appears in RHS of
+ -- rule for imported Id 'f', *or* does so transitively
+ imp_deps = foldr add_imp emptyNameEnv rules
+ add_imp rule acc
+ | is_active (ruleActivation rule)
+ = extendNameEnv_C unionVarSet acc (ru_fn rule)
+ (exprSomeFreeVars keep_imp (ru_rhs rule))
+ | otherwise = acc
+ keep_imp v = isId v && (idName v `elemNameSet` rule_name_set)
+ full_imp_deps = transClosureFV (ufmToList imp_deps)
+
+ lcl_deps :: NameEnv VarSet
+ -- (f, l) means localId 'l' appears immediately
+ -- in the RHS of a rule for imported Id 'f'
+ -- Remember, many rules might have the same ru_fn
+ -- so we do need to fold
+ lcl_deps = foldr add_lcl emptyNameEnv rules
+ add_lcl rule acc = extendNameEnv_C unionVarSet acc (ru_fn rule)
+ (exprFreeIds (ru_rhs rule))
+
+ find_lcl_deps :: Name -> VarSet
+ find_lcl_deps f
+ = foldVarSet (unionVarSet . lookup_lcl . idName) (lookup_lcl f)
+ (lookupNameEnv full_imp_deps f `orElse` emptyVarSet)
+ lookup_lcl :: Name -> VarSet
+ lookup_lcl g = lookupNameEnv lcl_deps g `orElse` emptyVarSet
+
+-------------
+transClosureFV :: Uniquable a => [(a, VarSet)] -> UniqFM VarSet
+-- If (f,g), (g,h) are in the input, then (f,h) is in the output
+transClosureFV fv_list
+ | no_change = env
+ | otherwise = transClosureFV new_fv_list
+ where
+ env = listToUFM fv_list
+ (no_change, new_fv_list) = mapAccumL bump True fv_list
+ bump no_change (b,fvs)
+ | no_change_here = (no_change, (b,fvs))
+ | otherwise = (False, (b,new_fvs))
+ where
+ (new_fvs, no_change_here) = extendFvs env fvs
+
+-------------
+extendFvs :: UniqFM VarSet -> VarSet -> (VarSet, Bool)
+-- (extendFVs env s) returns
+-- (s `union` env(s), env(s) `subset` s)
+extendFvs env s
+ = foldVarSet add (s, True) s
+ where
+ add v (vs, no_change_so_far)
+ = case lookupUFM env v of
+ Just fvs | not (fvs `subVarSet` s)
+ -> (vs `unionVarSet` fvs, False)
+ _ -> (vs, no_change_so_far)
+\end{code}
+
+
+%************************************************************************
+%* *
+ ProxyEnv
+%* *
+%************************************************************************
+
+\begin{code}
+data ProxyEnv -- See Note [ProxyEnv]
+ = PE (IdEnv -- Domain = scrutinee variables
+ (Id, -- The scrutinee variable again
+ [(Id,Coercion)])) -- The case binders that it maps to
+ VarSet -- Free variables of both range and domain
+\end{code}
+
+Note [ProxyEnv]
+~~~~~~~~~~~~~~~
+The ProxyEnv keeps track of the connection between case binders and
+scrutinee. Specifically, if
+ sc |-> (sc, [...(cb, co)...])
+is a binding in the ProxyEnv, then
+ cb = sc |> coi
+Typically we add such a binding when encountering the case expression
+ case (sc |> coi) of cb { ... }
+
+Things to note:
+ * The domain of the ProxyEnv is the variable (or casted variable)
+ scrutinees of enclosing cases. This is additionally used
+ to ensure we gather occurrence info even for GlobalId scrutinees;
+ see Note [Binder swap for GlobalId scrutinee]
+
+ * The ProxyEnv is just an optimisation; you can throw away any
+ element without losing correctness. And we do so when pushing
+ it inside a binding (see trimProxyEnv).
+
+ * One scrutinee might map to many case binders: Eg
+ case sc of cb1 { DEFAULT -> ....case sc of cb2 { ... } .. }
+
+INVARIANTS
+ * If sc1 |-> (sc2, [...(cb, co)...]), then sc1==sc2
+ It's a UniqFM and we sometimes need the domain Id
+
+ * Any particular case binder 'cb' occurs only once in entire range
+
+ * No loops
+
+The Main Reason for having a ProxyEnv is so that when we encounter
+ case e of cb { pi -> ri }
+we can find all the in-scope variables derivable from 'cb',
+and effectively add let-bindings for them (or at least for the
+ones *mentioned* in ri) thus:
+ case e of cb { pi -> let { x = ..cb..; y = ...cb.. }
+ in ri }
+In this way we'll replace occurrences of 'x', 'y' with 'cb',
+which implements the Binder-swap idea (see Note [Binder swap])
+
+The function getProxies finds these bindings; then we
+add just the necessary ones, using wrapProxy.
+
projects / ghc-hetmet.git / blobdiff