diff options
| author | John Ericson <John.Ericson@Obsidian.Systems> | 2022-05-26 16:11:58 +0000 |
|---|---|---|
| committer | John Ericson <John.Ericson@Obsidian.Systems> | 2023-01-17 19:04:50 -0500 |
| commit | 4322de246d35091e5e95a3a87fb4c1f9b7a61ee9 (patch) | |
| tree | 092cd0e518b59d5fc0d666c6f1bf56e0b3c421c2 | |
| parent | f4d50bafb7e14f76273aaf6f634815d5628ccc86 (diff) | |
| download | haskell-wip/rules-module.tar.gz | |
Split up `GHC.Core` somewhatwip/rules-module
- `GHC.Core.Annotated` now contains annotated Core
- `GHC.Core.Rules` now contains the rules definitions
- `GHC.Core.Orphans` now contains the orphans *something*
- `GHC.Core.Unfoldings` now contains the unfoldings defintions
- The old `GHC.Core.Rules`, which was about applying rules, is now
`GHC.Core.Rules.Apply`. Compare with `GHC.Core.Simplify.Inlin` which was also
about operations not the data structures and simple predictes
themselves (which is `GHC.Core.Unfold`).
69 files changed, 2636 insertions, 2517 deletions
diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs index 92b34ffc21..1c45e8de9b 100644 --- a/compiler/GHC/Core.hs +++ b/compiler/GHC/Core.hs @@ -50,65 +50,19 @@ module GHC.Core ( isValArg, isTypeArg, isCoArg, isTyCoArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar, - - -- * Unfolding data types - Unfolding(..), UnfoldingCache(..), UnfoldingGuidance(..), UnfoldingSource(..), - - -- ** Constructing 'Unfolding's - noUnfolding, bootUnfolding, evaldUnfolding, mkOtherCon, - unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk, - - -- ** Predicates and deconstruction on 'Unfolding' - unfoldingTemplate, expandUnfolding_maybe, - maybeUnfoldingTemplate, otherCons, - isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, - isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding, - isStableUnfolding, isStableUserUnfolding, isStableSystemUnfolding, - isInlineUnfolding, isBootUnfolding, - hasCoreUnfolding, hasSomeUnfolding, - canUnfold, neverUnfoldGuidance, isStableSource, - - -- * Annotated expression data types - AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt(..), - - -- ** Operations on annotated expressions - collectAnnArgs, collectAnnArgsTicks, - - -- ** Operations on annotations - deAnnotate, deAnnotate', deAnnAlt, deAnnBind, - collectAnnBndrs, collectNAnnBndrs, - - -- * Orphanhood - IsOrphan(..), isOrphan, notOrphan, chooseOrphanAnchor, - - -- * Core rule data types - CoreRule(..), - RuleName, RuleFun, IdUnfoldingFun, InScopeEnv, RuleOpts, - - -- ** Operations on 'CoreRule's - ruleArity, ruleName, ruleIdName, ruleActivation, - setRuleIdName, ruleModule, - isBuiltinRule, isLocalRule, isAutoRule, ) where import GHC.Prelude import GHC.Platform -import GHC.Types.Var.Env( InScopeSet ) import GHC.Types.Var import GHC.Core.Type import GHC.Core.Coercion -import GHC.Core.Rules.Config ( RuleOpts ) -import GHC.Types.Name -import GHC.Types.Name.Set import GHC.Types.Literal import GHC.Types.Tickish import GHC.Core.DataCon -import GHC.Unit.Module -import GHC.Types.Basic -import GHC.Types.Unique.Set +import GHC.Types.Basic (Arity, JoinArity) -import GHC.Utils.Binary import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic @@ -984,641 +938,9 @@ type OutAlt = CoreAlt type OutArg = CoreArg type MOutCoercion = MCoercion - -{- -************************************************************************ -* * - Orphans -* * -************************************************************************ --} - --- | Is this instance an orphan? If it is not an orphan, contains an 'OccName' --- witnessing the instance's non-orphanhood. --- See Note [Orphans] -data IsOrphan - = IsOrphan - | NotOrphan !OccName -- The OccName 'n' witnesses the instance's non-orphanhood - -- In that case, the instance is fingerprinted as part - -- of the definition of 'n's definition - deriving Data - --- | Returns true if 'IsOrphan' is orphan. -isOrphan :: IsOrphan -> Bool -isOrphan IsOrphan = True -isOrphan _ = False - --- | Returns true if 'IsOrphan' is not an orphan. -notOrphan :: IsOrphan -> Bool -notOrphan NotOrphan{} = True -notOrphan _ = False - -chooseOrphanAnchor :: NameSet -> IsOrphan --- Something (rule, instance) is relate to all the Names in this --- list. Choose one of them to be an "anchor" for the orphan. We make --- the choice deterministic to avoid gratuitous changes in the ABI --- hash (#4012). Specifically, use lexicographic comparison of --- OccName rather than comparing Uniques --- --- NB: 'minimum' use Ord, and (Ord OccName) works lexicographically --- -chooseOrphanAnchor local_names - | isEmptyNameSet local_names = IsOrphan - | otherwise = NotOrphan (minimum occs) - where - occs = map nameOccName $ nonDetEltsUniqSet local_names - -- It's OK to use nonDetEltsUFM here, see comments above - -instance Binary IsOrphan where - put_ bh IsOrphan = putByte bh 0 - put_ bh (NotOrphan n) = do - putByte bh 1 - put_ bh n - get bh = do - h <- getByte bh - case h of - 0 -> return IsOrphan - _ -> do - n <- get bh - return $ NotOrphan n - -{- -Note [Orphans] -~~~~~~~~~~~~~~ -Class instances, rules, and family instances are divided into orphans -and non-orphans. Roughly speaking, an instance/rule is an orphan if -its left hand side mentions nothing defined in this module. Orphan-hood -has two major consequences - - * A module that contains orphans is called an "orphan module". If - the module being compiled depends (transitively) on an orphan - module M, then M.hi is read in regardless of whether M is otherwise - needed. This is to ensure that we don't miss any instance decls in - M. But it's painful, because it means we need to keep track of all - the orphan modules below us. - - * The "visible orphan modules" are all the orphan module in the transitive - closure of the imports of this module. - - * During instance lookup, we filter orphan instances depending on - whether or not the instance is in a visible orphan module. - - * A non-orphan is not finger-printed separately. Instead, for - fingerprinting purposes it is treated as part of the entity it - mentions on the LHS. For example - data T = T1 | T2 - instance Eq T where .... - The instance (Eq T) is incorporated as part of T's fingerprint. - - In contrast, orphans are all fingerprinted together in the - mi_orph_hash field of the ModIface. - - See GHC.Iface.Recomp.addFingerprints. - -Orphan-hood is computed - * For class instances: - when we make a ClsInst in GHC.Core.InstEnv.mkLocalInstance - (because it is needed during instance lookup) - See Note [When exactly is an instance decl an orphan?] - in GHC.Core.InstEnv - - * For rules - when we generate a CoreRule (GHC.Core.Rules.mkRule) - - * For family instances: - when we generate an IfaceFamInst (GHC.Iface.Make.instanceToIfaceInst) - -Orphan-hood is persisted into interface files, in ClsInst, FamInst, -and CoreRules. - --} - -{- -************************************************************************ -* * -\subsection{Rewrite rules} -* * -************************************************************************ - -The CoreRule type and its friends are dealt with mainly in GHC.Core.Rules, but -GHC.Core.FVs, GHC.Core.Subst, GHC.Core.Ppr, GHC.Core.Tidy also inspect the -representation. --} - - --- | A 'CoreRule' is: --- --- * \"Local\" if the function it is a rule for is defined in the --- same module as the rule itself. --- --- * \"Orphan\" if nothing on the LHS is defined in the same module --- as the rule itself -data CoreRule - = Rule { - ru_name :: RuleName, -- ^ Name of the rule, for communication with the user - ru_act :: Activation, -- ^ When the rule is active - - -- Rough-matching stuff - -- see comments with InstEnv.ClsInst( is_cls, is_rough ) - ru_fn :: !Name, -- ^ Name of the 'GHC.Types.Id.Id' at the head of this rule - ru_rough :: [Maybe Name], -- ^ Name at the head of each argument to the left hand side - - -- Proper-matching stuff - -- see comments with InstEnv.ClsInst( is_tvs, is_tys ) - ru_bndrs :: [CoreBndr], -- ^ Variables quantified over - ru_args :: [CoreExpr], -- ^ Left hand side arguments - - -- And the right-hand side - ru_rhs :: CoreExpr, -- ^ Right hand side of the rule - -- Occurrence info is guaranteed correct - -- See Note [OccInfo in unfoldings and rules] - - -- Locality - ru_auto :: Bool, -- ^ @True@ <=> this rule is auto-generated - -- (notably by Specialise or SpecConstr) - -- @False@ <=> generated at the user's behest - -- See Note [Trimming auto-rules] in "GHC.Iface.Tidy" - -- for the sole purpose of this field. - - ru_origin :: !Module, -- ^ 'Module' the rule was defined in, used - -- to test if we should see an orphan rule. - - ru_orphan :: !IsOrphan, -- ^ Whether or not the rule is an orphan. - - ru_local :: Bool -- ^ @True@ iff the fn at the head of the rule is - -- defined in the same module as the rule - -- and is not an implicit 'Id' (like a record selector, - -- class operation, or data constructor). This - -- is different from 'ru_orphan', where a rule - -- can avoid being an orphan if *any* Name in - -- LHS of the rule was defined in the same - -- module as the rule. - } - - -- | Built-in rules are used for constant folding - -- and suchlike. They have no free variables. - -- A built-in rule is always visible (there is no such thing as - -- an orphan built-in rule.) - | BuiltinRule { - ru_name :: RuleName, -- ^ As above - ru_fn :: Name, -- ^ As above - ru_nargs :: Int, -- ^ Number of arguments that 'ru_try' consumes, - -- if it fires, including type arguments - ru_try :: RuleFun - -- ^ This function does the rewrite. It given too many - -- arguments, it simply discards them; the returned 'CoreExpr' - -- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args - } - -- See Note [Extra args in the target] in GHC.Core.Rules - --- | The 'InScopeSet' in the 'InScopeEnv' is a /superset/ of variables that are --- currently in scope. See Note [The InScopeSet invariant]. -type RuleFun = RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr -type InScopeEnv = (InScopeSet, IdUnfoldingFun) - -type IdUnfoldingFun = Id -> Unfolding --- A function that embodies how to unfold an Id if you need --- to do that in the Rule. The reason we need to pass this info in --- is that whether an Id is unfoldable depends on the simplifier phase - -isBuiltinRule :: CoreRule -> Bool -isBuiltinRule (BuiltinRule {}) = True -isBuiltinRule _ = False - -isAutoRule :: CoreRule -> Bool -isAutoRule (BuiltinRule {}) = False -isAutoRule (Rule { ru_auto = is_auto }) = is_auto - --- | The number of arguments the 'ru_fn' must be applied --- to before the rule can match on it -ruleArity :: CoreRule -> Int -ruleArity (BuiltinRule {ru_nargs = n}) = n -ruleArity (Rule {ru_args = args}) = length args - -ruleName :: CoreRule -> RuleName -ruleName = ru_name - -ruleModule :: CoreRule -> Maybe Module -ruleModule Rule { ru_origin } = Just ru_origin -ruleModule BuiltinRule {} = Nothing - -ruleActivation :: CoreRule -> Activation -ruleActivation (BuiltinRule { }) = AlwaysActive -ruleActivation (Rule { ru_act = act }) = act - --- | The 'Name' of the 'GHC.Types.Id.Id' at the head of the rule left hand side -ruleIdName :: CoreRule -> Name -ruleIdName = ru_fn - -isLocalRule :: CoreRule -> Bool -isLocalRule = ru_local - --- | Set the 'Name' of the 'GHC.Types.Id.Id' at the head of the rule left hand side -setRuleIdName :: Name -> CoreRule -> CoreRule -setRuleIdName nm ru = ru { ru_fn = nm } - {- ************************************************************************ * * - Unfoldings -* * -************************************************************************ - -The @Unfolding@ type is declared here to avoid numerous loops - -Note [Never put `OtherCon` unfoldings on lambda binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Based on #21496 we never attach unfoldings of any kind to lambda binders. -It's just too easy for the call site to change and invalidate the unfolding. -E.g. the caller of the lambda drops a seq (e.g. because the lambda is strict in it's binder) -which in turn makes the OtherCon[] unfolding a lie. -So unfoldings on lambda binders can never really be trusted when on lambda binders if there -is the chance of the call site to change. So it's easiest to just never attach any -to lambda binders to begin with, as well as stripping them off if we e.g. float out -and expression while abstracting over some arguments. --} - --- | Records the /unfolding/ of an identifier, which is approximately the form the --- identifier would have if we substituted its definition in for the identifier. --- This type should be treated as abstract everywhere except in "GHC.Core.Unfold" -data Unfolding - = NoUnfolding -- ^ We have no information about the unfolding. - - | BootUnfolding -- ^ We have no information about the unfolding, because - -- this 'Id' came from an @hi-boot@ file. - -- See Note [Inlining and hs-boot files] in "GHC.CoreToIface" - -- for what this is used for. - - | OtherCon [AltCon] -- ^ It ain't one of these constructors. - -- @OtherCon xs@ also indicates that something has been evaluated - -- and hence there's no point in re-evaluating it. - -- @OtherCon []@ is used even for non-data-type values - -- to indicated evaluated-ness. Notably: - -- - -- > data C = C !(Int -> Int) - -- > case x of { C f -> ... } - -- - -- Here, @f@ gets an @OtherCon []@ unfolding. - - | DFunUnfolding { -- The Unfolding of a DFunId - -- See Note [DFun unfoldings] - -- df = /\a1..am. \d1..dn. MkD t1 .. tk - -- (op1 a1..am d1..dn) - -- (op2 a1..am d1..dn) - df_bndrs :: [Var], -- The bound variables [a1..m],[d1..dn] - df_con :: DataCon, -- The dictionary data constructor (never a newtype datacon) - df_args :: [CoreExpr] -- Args of the data con: types, superclasses and methods, - } -- in positional order - - | CoreUnfolding { -- An unfolding for an Id with no pragma, - -- or perhaps a NOINLINE pragma - -- (For NOINLINE, the phase, if any, is in the - -- InlinePragInfo for this Id.) - uf_tmpl :: CoreExpr, -- Template; occurrence info is correct - uf_src :: UnfoldingSource, -- Where the unfolding came from - uf_is_top :: Bool, -- True <=> top level binding - uf_cache :: UnfoldingCache, -- Cache of flags computable from the expr - -- See Note [Tying the 'CoreUnfolding' knot] - uf_guidance :: UnfoldingGuidance -- Tells about the *size* of the template. - } - -- ^ An unfolding with redundant cached information. Parameters: - -- - -- uf_tmpl: Template used to perform unfolding; - -- NB: Occurrence info is guaranteed correct: - -- see Note [OccInfo in unfoldings and rules] - -- - -- uf_is_top: Is this a top level binding? - -- - -- uf_is_value: 'exprIsHNF' template (cached); it is ok to discard a 'seq' on - -- this variable - -- - -- uf_is_work_free: Does this waste only a little work if we expand it inside an inlining? - -- Basically this is a cached version of 'exprIsWorkFree' - -- - -- uf_guidance: Tells us about the /size/ of the unfolding template - - --- | Properties of a 'CoreUnfolding' that could be computed on-demand from its template. --- See Note [UnfoldingCache] -data UnfoldingCache - = UnfoldingCache { - uf_is_value :: !Bool, -- exprIsHNF template (cached); it is ok to discard - -- a `seq` on this variable - uf_is_conlike :: !Bool, -- True <=> applicn of constructor or CONLIKE function - -- Cached version of exprIsConLike - uf_is_work_free :: !Bool, -- True <=> doesn't waste (much) work to expand - -- inside an inlining - -- Cached version of exprIsCheap - uf_expandable :: !Bool -- True <=> can expand in RULE matching - -- Cached version of exprIsExpandable - } - deriving (Eq) - --- | 'UnfoldingGuidance' says when unfolding should take place -data UnfoldingGuidance - = UnfWhen { -- Inline without thinking about the *size* of the uf_tmpl - -- Used (a) for small *and* cheap unfoldings - -- (b) for INLINE functions - -- See Note [INLINE for small functions] in GHC.Core.Unfold - ug_arity :: Arity, -- Number of value arguments expected - - ug_unsat_ok :: Bool, -- True <=> ok to inline even if unsaturated - ug_boring_ok :: Bool -- True <=> ok to inline even if the context is boring - -- So True,True means "always" - } - - | UnfIfGoodArgs { -- Arose from a normal Id; the info here is the - -- result of a simple analysis of the RHS - - ug_args :: [Int], -- Discount if the argument is evaluated. - -- (i.e., a simplification will definitely - -- be possible). One elt of the list per *value* arg. - - ug_size :: Int, -- The "size" of the unfolding. - - ug_res :: Int -- Scrutinee discount: the discount to subtract if the thing is in - } -- a context (case (thing args) of ...), - -- (where there are the right number of arguments.) - - | UnfNever -- The RHS is big, so don't inline it - deriving (Eq) - -{- Note [UnfoldingCache] -~~~~~~~~~~~~~~~~~~~~~~~~ -The UnfoldingCache field of an Unfolding holds four (strict) booleans, -all derived from the uf_tmpl field of the unfolding. - -* We serialise the UnfoldingCache to and from interface files, for - reasons described in Note [Tying the 'CoreUnfolding' knot] in - GHC.IfaceToCore - -* Because it is a strict data type, we must be careful not to - pattern-match on it until we actually want its values. E.g - GHC.Core.Unfold.callSiteInline/tryUnfolding are careful not to force - it unnecessarily. Just saves a bit of work. - -* When `seq`ing Core to eliminate space leaks, to suffices to `seq` on - the cache, but not its fields, because it is strict in all fields. - -Note [Historical note: unfoldings for wrappers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We used to have a nice clever scheme in interface files for -wrappers. A wrapper's unfolding can be reconstructed from its worker's -id and its strictness. This decreased .hi file size (sometimes -significantly, for modules like GHC.Classes with many high-arity w/w -splits) and had a slight corresponding effect on compile times. - -However, when we added the second demand analysis, this scheme lead to -some Core lint errors. The second analysis could change the strictness -signatures, which sometimes resulted in a wrapper's regenerated -unfolding applying the wrapper to too many arguments. - -Instead of repairing the clever .hi scheme, we abandoned it in favor -of simplicity. The .hi sizes are usually insignificant (excluding the -+1M for base libraries), and compile time barely increases (~+1% for -nofib). The nicer upshot is that the UnfoldingSource no longer mentions -an Id, so, eg, substitutions need not traverse them. - - -Note [DFun unfoldings] -~~~~~~~~~~~~~~~~~~~~~~ -The Arity in a DFunUnfolding is total number of args (type and value) -that the DFun needs to produce a dictionary. That's not necessarily -related to the ordinary arity of the dfun Id, esp if the class has -one method, so the dictionary is represented by a newtype. Example - - class C a where { op :: a -> Int } - instance C a -> C [a] where op xs = op (head xs) - -The instance translates to - - $dfCList :: forall a. C a => C [a] -- Arity 2! - $dfCList = /\a.\d. $copList {a} d |> co - - $copList :: forall a. C a => [a] -> Int -- Arity 2! - $copList = /\a.\d.\xs. op {a} d (head xs) - -Now we might encounter (op (dfCList {ty} d) a1 a2) -and we want the (op (dfList {ty} d)) rule to fire, because $dfCList -has all its arguments, even though its (value) arity is 2. That's -why we record the number of expected arguments in the DFunUnfolding. - -Note that although it's an Arity, it's most convenient for it to give -the *total* number of arguments, both type and value. See the use -site in exprIsConApp_maybe. --} - --- Constants for the UnfWhen constructor -needSaturated, unSaturatedOk :: Bool -needSaturated = False -unSaturatedOk = True - -boringCxtNotOk, boringCxtOk :: Bool -boringCxtOk = True -boringCxtNotOk = False - ------------------------------------------------- -noUnfolding :: Unfolding --- ^ There is no known 'Unfolding' -evaldUnfolding :: Unfolding --- ^ This unfolding marks the associated thing as being evaluated - -noUnfolding = NoUnfolding -evaldUnfolding = OtherCon [] - --- | There is no known 'Unfolding', because this came from an --- hi-boot file. -bootUnfolding :: Unfolding -bootUnfolding = BootUnfolding - -mkOtherCon :: [AltCon] -> Unfolding -mkOtherCon = OtherCon - --- | Retrieves the template of an unfolding: panics if none is known -unfoldingTemplate :: Unfolding -> CoreExpr -unfoldingTemplate = uf_tmpl - --- | Retrieves the template of an unfolding if possible --- maybeUnfoldingTemplate is used mainly when specialising, and we do --- want to specialise DFuns, so it's important to return a template --- for DFunUnfoldings -maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr -maybeUnfoldingTemplate (CoreUnfolding { uf_tmpl = expr }) - = Just expr -maybeUnfoldingTemplate (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }) - = Just (mkLams bndrs (mkApps (Var (dataConWorkId con)) args)) -maybeUnfoldingTemplate _ - = Nothing - --- | The constructors that the unfolding could never be: --- returns @[]@ if no information is available -otherCons :: Unfolding -> [AltCon] -otherCons (OtherCon cons) = cons -otherCons _ = [] - --- | Determines if it is certainly the case that the unfolding will --- yield a value (something in HNF): returns @False@ if unsure -isValueUnfolding :: Unfolding -> Bool - -- Returns False for OtherCon -isValueUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_value cache -isValueUnfolding (DFunUnfolding {}) = True -isValueUnfolding _ = False - --- | Determines if it possibly the case that the unfolding will --- yield a value. Unlike 'isValueUnfolding' it returns @True@ --- for 'OtherCon' -isEvaldUnfolding :: Unfolding -> Bool - -- Returns True for OtherCon -isEvaldUnfolding (OtherCon _) = True -isEvaldUnfolding (DFunUnfolding {}) = True -isEvaldUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_value cache -isEvaldUnfolding _ = False - --- | @True@ if the unfolding is a constructor application, the application --- of a CONLIKE function or 'OtherCon' -isConLikeUnfolding :: Unfolding -> Bool -isConLikeUnfolding (OtherCon _) = True -isConLikeUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_conlike cache -isConLikeUnfolding _ = False - --- | Is the thing we will unfold into certainly cheap? -isCheapUnfolding :: Unfolding -> Bool -isCheapUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_work_free cache -isCheapUnfolding _ = False - -isExpandableUnfolding :: Unfolding -> Bool -isExpandableUnfolding (CoreUnfolding { uf_cache = cache }) = uf_expandable cache -isExpandableUnfolding _ = False - -expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr --- Expand an expandable unfolding; this is used in rule matching --- See Note [Expanding variables] in GHC.Core.Rules --- The key point here is that CONLIKE things can be expanded -expandUnfolding_maybe (CoreUnfolding { uf_cache = cache, uf_tmpl = rhs }) - | uf_expandable cache - = Just rhs -expandUnfolding_maybe _ = Nothing - -isCompulsoryUnfolding :: Unfolding -> Bool -isCompulsoryUnfolding (CoreUnfolding { uf_src = src }) = isCompulsorySource src -isCompulsoryUnfolding _ = False - -isStableUnfolding :: Unfolding -> Bool --- True of unfoldings that should not be overwritten --- by a CoreUnfolding for the RHS of a let-binding -isStableUnfolding (CoreUnfolding { uf_src = src }) = isStableSource src -isStableUnfolding (DFunUnfolding {}) = True -isStableUnfolding _ = False - -isStableUserUnfolding :: Unfolding -> Bool --- True of unfoldings that arise from an INLINE or INLINEABLE pragma -isStableUserUnfolding (CoreUnfolding { uf_src = src }) = isStableUserSource src -isStableUserUnfolding _ = False - -isStableSystemUnfolding :: Unfolding -> Bool --- True of unfoldings that arise from an INLINE or INLINEABLE pragma -isStableSystemUnfolding (CoreUnfolding { uf_src = src }) = isStableSystemSource src -isStableSystemUnfolding _ = False - -isInlineUnfolding :: Unfolding -> Bool --- ^ True of a /stable/ unfolding that is --- (a) always inlined; that is, with an `UnfWhen` guidance, or --- (b) a DFunUnfolding which never needs to be inlined -isInlineUnfolding (CoreUnfolding { uf_src = src, uf_guidance = guidance }) - | isStableSource src - , UnfWhen {} <- guidance - = True - -isInlineUnfolding (DFunUnfolding {}) - = True - --- Default case -isInlineUnfolding _ = False - - --- | Only returns False if there is no unfolding information available at all -hasSomeUnfolding :: Unfolding -> Bool -hasSomeUnfolding NoUnfolding = False -hasSomeUnfolding BootUnfolding = False -hasSomeUnfolding _ = True - -isBootUnfolding :: Unfolding -> Bool -isBootUnfolding BootUnfolding = True -isBootUnfolding _ = False - -neverUnfoldGuidance :: UnfoldingGuidance -> Bool -neverUnfoldGuidance UnfNever = True -neverUnfoldGuidance _ = False - -hasCoreUnfolding :: Unfolding -> Bool --- An unfolding "has Core" if it contains a Core expression, which --- may mention free variables. See Note [Fragile unfoldings] -hasCoreUnfolding (CoreUnfolding {}) = True -hasCoreUnfolding (DFunUnfolding {}) = True -hasCoreUnfolding _ = False - -- NoUnfolding, BootUnfolding, OtherCon have no Core - -canUnfold :: Unfolding -> Bool -canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g) -canUnfold _ = False - -{- Note [Fragile unfoldings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -An unfolding is "fragile" if it mentions free variables (and hence would -need substitution) or might be affected by optimisation. The non-fragile -ones are - - NoUnfolding, BootUnfolding - - OtherCon {} If we know this binder (say a lambda binder) will be - bound to an evaluated thing, we want to retain that - info in simpleOptExpr; see #13077. - -We consider even a StableUnfolding as fragile, because it needs substitution. - -Note [Stable unfoldings] -~~~~~~~~~~~~~~~~~~~~~~~~ -When you say - {-# INLINE f #-} - f x = <rhs> -you intend that calls (f e) are replaced by <rhs>[e/x] So we -should capture (\x.<rhs>) in the Unfolding of 'f', and never meddle -with it. Meanwhile, we can optimise <rhs> to our heart's content, -leaving the original unfolding intact in Unfolding of 'f'. For example - all xs = foldr (&&) True xs - any p = all . map p {-# INLINE any #-} -We optimise any's RHS fully, but leave the stable unfolding for `any` -saying "all . map p", which deforests well at the call site. - -So INLINE pragma gives rise to a stable unfolding, which captures the -original RHS. - -Moreover, it's only used when 'f' is applied to the -specified number of arguments; that is, the number of argument on -the LHS of the '=' sign in the original source definition. -For example, (.) is now defined in the libraries like this - {-# INLINE (.) #-} - (.) f g = \x -> f (g x) -so that it'll inline when applied to two arguments. If 'x' appeared -on the left, thus - (.) f g x = f (g x) -it'd only inline when applied to three arguments. This slightly-experimental -change was requested by Roman, but it seems to make sense. - -Note [OccInfo in unfoldings and rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In unfoldings and rules, we guarantee that the template is occ-analysed, -so that the occurrence info on the binders is correct. This is important, -because the Simplifier does not re-analyse the template when using it. If -the occurrence info is wrong - - We may get more simplifier iterations than necessary, because - once-occ info isn't there - - More seriously, we may get an infinite loop if there's a Rec - without a loop breaker marked - - -************************************************************************ -* * AltCon * * ************************************************************************ @@ -2110,97 +1432,3 @@ valBndrCount = count isId -- | The number of argument expressions that are values rather than types at their top level valArgCount :: [Arg b] -> Int valArgCount = count isValArg - -{- -************************************************************************ -* * -\subsection{Annotated core} -* * -************************************************************************ --} - --- | Annotated core: allows annotation at every node in the tree -type AnnExpr bndr annot = (annot, AnnExpr' bndr annot) - --- | A clone of the 'Expr' type but allowing annotation at every tree node -data AnnExpr' bndr annot - = AnnVar Id - | AnnLit Literal - | AnnLam bndr (AnnExpr bndr annot) - | AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot) - | AnnCase (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot] - | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot) - | AnnCast (AnnExpr bndr annot) (annot, Coercion) - -- Put an annotation on the (root of) the coercion - | AnnTick CoreTickish (AnnExpr bndr annot) - | AnnType Type - | AnnCoercion Coercion - --- | A clone of the 'Alt' type but allowing annotation at every tree node -data AnnAlt bndr annot = AnnAlt AltCon [bndr] (AnnExpr bndr annot) - --- | A clone of the 'Bind' type but allowing annotation at every tree node -data AnnBind bndr annot - = AnnNonRec bndr (AnnExpr bndr annot) - | AnnRec [(bndr, AnnExpr bndr annot)] - --- | Takes a nested application expression and returns the function --- being applied and the arguments to which it is applied -collectAnnArgs :: AnnExpr b a -> (AnnExpr b a, [AnnExpr b a]) -collectAnnArgs expr - = go expr [] - where - go (_, AnnApp f a) as = go f (a:as) - go e as = (e, as) - -collectAnnArgsTicks :: (CoreTickish -> Bool) -> AnnExpr b a - -> (AnnExpr b a, [AnnExpr b a], [CoreTickish]) -collectAnnArgsTicks tickishOk expr - = go expr [] [] - where - go (_, AnnApp f a) as ts = go f (a:as) ts - go (_, AnnTick t e) as ts | tickishOk t - = go e as (t:ts) - go e as ts = (e, as, reverse ts) - -deAnnotate :: AnnExpr bndr annot -> Expr bndr -deAnnotate (_, e) = deAnnotate' e - -deAnnotate' :: AnnExpr' bndr annot -> Expr bndr -deAnnotate' (AnnType t) = Type t -deAnnotate' (AnnCoercion co) = Coercion co -deAnnotate' (AnnVar v) = Var v -deAnnotate' (AnnLit lit) = Lit lit -deAnnotate' (AnnLam binder body) = Lam binder (deAnnotate body) -deAnnotate' (AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg) -deAnnotate' (AnnCast e (_,co)) = Cast (deAnnotate e) co -deAnnotate' (AnnTick tick body) = Tick tick (deAnnotate body) - -deAnnotate' (AnnLet bind body) - = Let (deAnnBind bind) (deAnnotate body) -deAnnotate' (AnnCase scrut v t alts) - = Case (deAnnotate scrut) v t (map deAnnAlt alts) - -deAnnAlt :: AnnAlt bndr annot -> Alt bndr -deAnnAlt (AnnAlt con args rhs) = Alt con args (deAnnotate rhs) - -deAnnBind :: AnnBind b annot -> Bind b -deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs) -deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs] - --- | As 'collectBinders' but for 'AnnExpr' rather than 'Expr' -collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot) -collectAnnBndrs e - = collect [] e - where - collect bs (_, AnnLam b body) = collect (b:bs) body - collect bs body = (reverse bs, body) - --- | As 'collectNBinders' but for 'AnnExpr' rather than 'Expr' -collectNAnnBndrs :: Int -> AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot) -collectNAnnBndrs orig_n e - = collect orig_n [] e - where - collect 0 bs body = (reverse bs, body) - collect n bs (_, AnnLam b body) = collect (n-1) (b:bs) body - collect _ _ _ = pprPanic "collectNBinders" $ int orig_n diff --git a/compiler/GHC/Core/Annotated.hs b/compiler/GHC/Core/Annotated.hs new file mode 100644 index 0000000000..497c00d9cd --- /dev/null +++ b/compiler/GHC/Core/Annotated.hs @@ -0,0 +1,122 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE BangPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Annotated Core +module GHC.Core.Annotated ( + -- * Annotated expression data types + AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt(..), + + -- ** Operations on annotated expressions + collectAnnArgs, collectAnnArgsTicks, + + -- ** Operations on annotations + deAnnotate, deAnnotate', deAnnAlt, deAnnBind, + collectAnnBndrs, collectNAnnBndrs, + ) where + +import GHC.Prelude + +import GHC.Types.Var +import GHC.Core +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Types.Literal +import GHC.Types.Tickish + +import GHC.Utils.Outputable +import GHC.Utils.Panic + +-- | Annotated core: allows annotation at every node in the tree +type AnnExpr bndr annot = (annot, AnnExpr' bndr annot) + +-- | A clone of the 'Expr' type but allowing annotation at every tree node +data AnnExpr' bndr annot + = AnnVar Id + | AnnLit Literal + | AnnLam bndr (AnnExpr bndr annot) + | AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot) + | AnnCase (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot] + | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot) + | AnnCast (AnnExpr bndr annot) (annot, Coercion) + -- Put an annotation on the (root of) the coercion + | AnnTick CoreTickish (AnnExpr bndr annot) + | AnnType Type + | AnnCoercion Coercion + +-- | A clone of the 'Alt' type but allowing annotation at every tree node +data AnnAlt bndr annot = AnnAlt AltCon [bndr] (AnnExpr bndr annot) + +-- | A clone of the 'Bind' type but allowing annotation at every tree node +data AnnBind bndr annot + = AnnNonRec bndr (AnnExpr bndr annot) + | AnnRec [(bndr, AnnExpr bndr annot)] + +-- | Takes a nested application expression and returns the function +-- being applied and the arguments to which it is applied +collectAnnArgs :: AnnExpr b a -> (AnnExpr b a, [AnnExpr b a]) +collectAnnArgs expr + = go expr [] + where + go (_, AnnApp f a) as = go f (a:as) + go e as = (e, as) + +collectAnnArgsTicks :: (CoreTickish -> Bool) -> AnnExpr b a + -> (AnnExpr b a, [AnnExpr b a], [CoreTickish]) +collectAnnArgsTicks tickishOk expr + = go expr [] [] + where + go (_, AnnApp f a) as ts = go f (a:as) ts + go (_, AnnTick t e) as ts | tickishOk t + = go e as (t:ts) + go e as ts = (e, as, reverse ts) + +deAnnotate :: AnnExpr bndr annot -> Expr bndr +deAnnotate (_, e) = deAnnotate' e + +deAnnotate' :: AnnExpr' bndr annot -> Expr bndr +deAnnotate' (AnnType t) = Type t +deAnnotate' (AnnCoercion co) = Coercion co +deAnnotate' (AnnVar v) = Var v +deAnnotate' (AnnLit lit) = Lit lit +deAnnotate' (AnnLam binder body) = Lam binder (deAnnotate body) +deAnnotate' (AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg) +deAnnotate' (AnnCast e (_,co)) = Cast (deAnnotate e) co +deAnnotate' (AnnTick tick body) = Tick tick (deAnnotate body) + +deAnnotate' (AnnLet bind body) + = Let (deAnnBind bind) (deAnnotate body) +deAnnotate' (AnnCase scrut v t alts) + = Case (deAnnotate scrut) v t (map deAnnAlt alts) + +deAnnAlt :: AnnAlt bndr annot -> Alt bndr +deAnnAlt (AnnAlt con args rhs) = Alt con args (deAnnotate rhs) + +deAnnBind :: AnnBind b annot -> Bind b +deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs) +deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs] + +-- | As 'collectBinders' but for 'AnnExpr' rather than 'Expr' +collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot) +collectAnnBndrs e + = collect [] e + where + collect bs (_, AnnLam b body) = collect (b:bs) body + collect bs body = (reverse bs, body) + +-- | As 'collectNBinders' but for 'AnnExpr' rather than 'Expr' +collectNAnnBndrs :: Int -> AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot) +collectNAnnBndrs orig_n e + = collect orig_n [] e + where + collect 0 bs body = (reverse bs, body) + collect n bs (_, AnnLam b body) = collect (n-1) (b:bs) body + collect _ _ _ = pprPanic "collectNBinders" $ int orig_n diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs index c7ade006e5..476a1cae77 100644 --- a/compiler/GHC/Core/Coercion.hs +++ b/compiler/GHC/Core/Coercion.hs @@ -995,7 +995,7 @@ mkCoVarCos = map mkCoVarCo {- Note [mkCoVarCo] ~~~~~~~~~~~~~~~~~~~ In the past, mkCoVarCo optimised (c :: t~t) to (Refl t). That is -valid (although see Note [Unbound RULE binders] in GHC.Core.Rules), but +valid (although see Note [Unbound RULE binders] in GHC.Core.Rules.Apply), but it's a relatively expensive test and perhaps better done in optCoercion. Not a big deal either way. -} diff --git a/compiler/GHC/Core/FVs.hs b/compiler/GHC/Core/FVs.hs index 65b654356e..0c339925de 100644 --- a/compiler/GHC/Core/FVs.hs +++ b/compiler/GHC/Core/FVs.hs @@ -58,6 +58,8 @@ module GHC.Core.FVs ( import GHC.Prelude import GHC.Core +import GHC.Core.Rules +import GHC.Core.Unfoldings import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Name.Set @@ -65,6 +67,7 @@ import GHC.Types.Name import GHC.Types.Tickish import GHC.Types.Var.Set import GHC.Types.Var +import GHC.Core.Annotated import GHC.Core.Type import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs diff --git a/compiler/GHC/Core/InstEnv.hs b/compiler/GHC/Core/InstEnv.hs index f06f12e89a..517e5d7e18 100644 --- a/compiler/GHC/Core/InstEnv.hs +++ b/compiler/GHC/Core/InstEnv.hs @@ -36,7 +36,7 @@ import GHC.Prelude hiding ( head, init, last, tail ) import GHC.Tc.Utils.TcType -- InstEnv is really part of the type checker, -- and depends on TcType in many ways -import GHC.Core ( IsOrphan(..), isOrphan, chooseOrphanAnchor ) +import GHC.Core.Orphans ( IsOrphan(..), isOrphan, chooseOrphanAnchor ) import GHC.Core.RoughMap import GHC.Core.Class import GHC.Core.Unify diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index 73faebd80d..4c1bfdad80 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -38,6 +38,7 @@ import GHC.Unit.Module.ModGuts import GHC.Platform import GHC.Core +import GHC.Core.Rules import GHC.Core.FVs import GHC.Core.Utils import GHC.Core.Stats ( coreBindsStats ) @@ -60,6 +61,7 @@ import GHC.Core.Coercion.Opt ( checkAxInstCo ) import GHC.Core.Opt.Arity ( typeArity, exprIsDeadEnd ) import GHC.Core.Opt.Monad +import GHC.Core.Unfoldings import GHC.Types.Literal import GHC.Types.Var as Var @@ -2037,7 +2039,7 @@ lintCoreRule fun fun_ty rule@(Rule { ru_name = name, ru_bndrs = bndrs rhs_fvs = exprFreeVars rhs is_bad_bndr :: Var -> Bool - -- See Note [Unbound RULE binders] in GHC.Core.Rules + -- See Note [Unbound RULE binders] in GHC.Core.Rules.Apply is_bad_bndr bndr = not (bndr `elemVarSet` lhs_fvs) && bndr `elemVarSet` rhs_fvs && isNothing (isReflCoVar_maybe bndr) diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs index 5ed015281a..d8ad51a5c8 100644 --- a/compiler/GHC/Core/Opt/Arity.hs +++ b/compiler/GHC/Core/Opt/Arity.hs @@ -49,6 +49,8 @@ where import GHC.Prelude import GHC.Core +import GHC.Core.Rules +import GHC.Core.Unfoldings import GHC.Core.FVs import GHC.Core.Utils import GHC.Core.DataCon diff --git a/compiler/GHC/Core/Opt/CSE.hs b/compiler/GHC/Core/Opt/CSE.hs index 2f7718709a..4786275d2a 100644 --- a/compiler/GHC/Core/Opt/CSE.hs +++ b/compiler/GHC/Core/Opt/CSE.hs @@ -21,6 +21,7 @@ import GHC.Core.Utils ( mkAltExpr import GHC.Core.FVs ( exprFreeVars ) import GHC.Core.Type ( tyConAppArgs ) import GHC.Core +import GHC.Core.Unfoldings import GHC.Utils.Outputable import GHC.Types.Basic import GHC.Types.Tickish diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs index 3d36368d5b..37c7c7d60f 100644 --- a/compiler/GHC/Core/Opt/ConstantFold.hs +++ b/compiler/GHC/Core/Opt/ConstantFold.hs @@ -43,6 +43,8 @@ import GHC.Types.Name ( Name, nameOccName ) import GHC.Types.Basic import GHC.Core +import GHC.Core.Rules +import GHC.Core.Unfoldings import GHC.Core.Make import GHC.Core.SimpleOpt ( exprIsConApp_maybe, exprIsLiteral_maybe ) import GHC.Core.DataCon ( DataCon,dataConTagZ, dataConTyCon, dataConWrapId, dataConWorkId ) diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs-boot b/compiler/GHC/Core/Opt/ConstantFold.hs-boot index 216af660ae..b47786ab03 100644 --- a/compiler/GHC/Core/Opt/ConstantFold.hs-boot +++ b/compiler/GHC/Core/Opt/ConstantFold.hs-boot @@ -1,8 +1,8 @@ module GHC.Core.Opt.ConstantFold where -import GHC.Prelude -import GHC.Core -import GHC.Builtin.PrimOps -import GHC.Types.Name +import GHC.Prelude ( Maybe ) +import GHC.Core.Rules( CoreRule ) +import GHC.Builtin.PrimOps ( PrimOp ) +import GHC.Types.Name ( Name ) primOpRules :: Name -> PrimOp -> Maybe CoreRule diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs index 87d9eb2ec7..3d77c20fd8 100644 --- a/compiler/GHC/Core/Opt/CprAnal.hs +++ b/compiler/GHC/Core/Opt/CprAnal.hs @@ -27,6 +27,7 @@ import GHC.Core.DataCon import GHC.Core.Type import GHC.Core.Utils import GHC.Core +import GHC.Core.Unfoldings import GHC.Core.Seq import GHC.Core.Opt.WorkWrap.Utils diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs index fbe843cff8..ee4f0c4f33 100644 --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -19,6 +19,8 @@ import GHC.Prelude import GHC.Core.Opt.WorkWrap.Utils import GHC.Types.Demand -- All of it import GHC.Core +import GHC.Core.Rules +import GHC.Core.Unfoldings import GHC.Core.Multiplicity ( scaledThing ) import GHC.Utils.Outputable import GHC.Types.Var.Env diff --git a/compiler/GHC/Core/Opt/Exitify.hs b/compiler/GHC/Core/Opt/Exitify.hs index 6ad4614286..e56619877c 100644 --- a/compiler/GHC/Core/Opt/Exitify.hs +++ b/compiler/GHC/Core/Opt/Exitify.hs @@ -40,6 +40,7 @@ import GHC.Types.Var import GHC.Types.Id import GHC.Types.Id.Info import GHC.Core +import GHC.Core.Annotated import GHC.Core.Utils import GHC.Utils.Monad.State.Strict import GHC.Builtin.Uniques diff --git a/compiler/GHC/Core/Opt/FloatIn.hs b/compiler/GHC/Core/Opt/FloatIn.hs index 2feef8a617..bbee9bb128 100644 --- a/compiler/GHC/Core/Opt/FloatIn.hs +++ b/compiler/GHC/Core/Opt/FloatIn.hs @@ -23,6 +23,7 @@ import GHC.Platform import GHC.Core import GHC.Core.Opt.Arity( isOneShotBndr ) +import GHC.Core.Annotated import GHC.Core.Make hiding ( wrapFloats ) import GHC.Core.Utils import GHC.Core.FVs diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs index d38f3e6c59..39e0ce791c 100644 --- a/compiler/GHC/Core/Opt/Monad.hs +++ b/compiler/GHC/Core/Opt/Monad.hs @@ -43,7 +43,7 @@ import GHC.Prelude hiding ( read ) import GHC.Driver.Session import GHC.Driver.Env -import GHC.Core.Rules ( RuleBase, RuleEnv, mkRuleEnv ) +import GHC.Core.Rules.Apply ( RuleBase, RuleEnv, mkRuleEnv ) import GHC.Core.Opt.Stats ( SimplCount, zeroSimplCount, plusSimplCount ) import GHC.Types.Annotations diff --git a/compiler/GHC/Core/Opt/OccurAnal.hs b/compiler/GHC/Core/Opt/OccurAnal.hs index fc374adb99..0a69e27b5b 100644 --- a/compiler/GHC/Core/Opt/OccurAnal.hs +++ b/compiler/GHC/Core/Opt/OccurAnal.hs @@ -25,6 +25,8 @@ module GHC.Core.Opt.OccurAnal ( import GHC.Prelude hiding ( head, init, last, tail ) import GHC.Core +import GHC.Core.Rules +import GHC.Core.Unfoldings import GHC.Core.FVs import GHC.Core.Utils ( exprIsTrivial, isDefaultAlt, isExpandableApp, mkCastMCo, mkTicks ) diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs index 8be830dbeb..754d9776c3 100644 --- a/compiler/GHC/Core/Opt/Pipeline.hs +++ b/compiler/GHC/Core/Opt/Pipeline.hs @@ -21,8 +21,9 @@ import GHC.Driver.Config.Core.Rules ( initRuleOpts ) import GHC.Platform.Ways ( hasWay, Way(WayProf) ) import GHC.Core +import GHC.Core.Rules import GHC.Core.Opt.CSE ( cseProgram ) -import GHC.Core.Rules ( RuleBase, mkRuleBase, ruleCheckProgram, getRules ) +import GHC.Core.Rules.Apply ( RuleBase, mkRuleBase, ruleCheckProgram, getRules ) import GHC.Core.Ppr ( pprCoreBindings ) import GHC.Core.Utils ( dumpIdInfoOfProgram ) import GHC.Core.Lint ( lintAnnots ) diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs index 95084cf7b6..51c171f438 100644 --- a/compiler/GHC/Core/Opt/SetLevels.hs +++ b/compiler/GHC/Core/Opt/SetLevels.hs @@ -66,6 +66,7 @@ module GHC.Core.Opt.SetLevels ( import GHC.Prelude import GHC.Core +import GHC.Core.Annotated import GHC.Core.Opt.Monad ( FloatOutSwitches(..) ) import GHC.Core.Utils ( exprType, exprIsHNF , exprOkForSpeculation @@ -81,6 +82,7 @@ import GHC.Core.Type ( Type, tyCoVarsOfType , mightBeUnliftedType, closeOverKindsDSet , typeHasFixedRuntimeRep ) +import GHC.Core.Unfoldings ( isStableUnfolding ) import GHC.Core.Multiplicity ( pattern ManyTy ) import GHC.Types.Id diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index 7b7b439e33..d585af35a9 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -11,6 +11,7 @@ import GHC.Driver.Flags import GHC.Core import GHC.Core.Rules +import GHC.Core.Rules.Apply import GHC.Core.Ppr ( pprCoreBindings, pprCoreExpr ) import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) import GHC.Core.Stats ( coreBindsSize, coreBindsStats, exprSize ) @@ -22,6 +23,7 @@ import GHC.Core.Opt.Simplify.Env import GHC.Core.Opt.Simplify.Monad import GHC.Core.Opt.Stats ( simplCountN ) import GHC.Core.FamInstEnv +import GHC.Core.Unfoldings import GHC.Utils.Error ( withTiming ) import GHC.Utils.Logger as Logger diff --git a/compiler/GHC/Core/Opt/Simplify/Inline.hs b/compiler/GHC/Core/Opt/Simplify/Inline.hs index f91319e754..10b74be6a4 100644 --- a/compiler/GHC/Core/Opt/Simplify/Inline.hs +++ b/compiler/GHC/Core/Opt/Simplify/Inline.hs @@ -23,6 +23,7 @@ import GHC.Driver.Flags import GHC.Core import GHC.Core.Unfold +import GHC.Core.Unfoldings import GHC.Types.Id import GHC.Types.Basic ( Arity, RecFlag(..) ) import GHC.Utils.Logger diff --git a/compiler/GHC/Core/Opt/Simplify/Iteration.hs b/compiler/GHC/Core/Opt/Simplify/Iteration.hs index e29581a2f0..6f917c3f8b 100644 --- a/compiler/GHC/Core/Opt/Simplify/Iteration.hs +++ b/compiler/GHC/Core/Opt/Simplify/Iteration.hs @@ -45,8 +45,10 @@ import GHC.Core.Opt.Arity ( ArityType, exprArity, arityTypeBotSigs_maybe , typeArity, arityTypeArity, etaExpandAT ) import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe ) import GHC.Core.FVs ( mkRuleInfo ) -import GHC.Core.Rules ( lookupRule, getRules ) +import GHC.Core.Rules +import GHC.Core.Rules.Apply ( lookupRule, getRules ) import GHC.Core.Multiplicity +import GHC.Core.Unfoldings import GHC.Types.Literal ( litIsLifted ) --, mkLitInt ) -- temporarily commented out. See #8326 import GHC.Types.SourceText diff --git a/compiler/GHC/Core/Opt/Simplify/Monad.hs b/compiler/GHC/Core/Opt/Simplify/Monad.hs index 826c11f335..12e2338530 100644 --- a/compiler/GHC/Core/Opt/Simplify/Monad.hs +++ b/compiler/GHC/Core/Opt/Simplify/Monad.hs @@ -28,7 +28,7 @@ import GHC.Types.Id ( Id, mkSysLocalOrCoVarM ) import GHC.Types.Id.Info ( IdDetails(..), vanillaIdInfo, setArityInfo ) import GHC.Core.Type ( Type, Mult ) import GHC.Core.Opt.Stats -import GHC.Core.Rules +import GHC.Core.Rules.Apply import GHC.Core.Utils ( mkLamTypes ) import GHC.Types.Unique.Supply import GHC.Driver.Flags diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs index 28b1ebc221..c4bf05a00a 100644 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -45,6 +45,7 @@ module GHC.Core.Opt.Simplify.Utils ( import GHC.Prelude hiding (head, init, last, tail) import GHC.Core +import GHC.Core.Rules import GHC.Types.Literal ( isLitRubbish ) import GHC.Core.Opt.Simplify.Env import GHC.Core.Opt.Simplify.Inline @@ -54,10 +55,11 @@ import GHC.Core.Ppr import GHC.Core.TyCo.Ppr ( pprParendType ) import GHC.Core.FVs import GHC.Core.Utils -import GHC.Core.Rules( RuleEnv, getRules ) +import GHC.Core.Rules.Apply ( RuleEnv, getRules ) import GHC.Core.Opt.Arity import GHC.Core.Unfold import GHC.Core.Unfold.Make +import GHC.Core.Unfoldings import GHC.Core.Opt.Simplify.Monad import GHC.Core.Type hiding( substTy ) import GHC.Core.Coercion hiding( substCo ) @@ -1065,7 +1067,7 @@ including those in the LHS of rules. This can cause somewhat surprising results; for instance, in #18162 we found that a rule template contained ticks in its arguments, because postInlineUnconditionally substituted in a trivial expression that contains -ticks. See Note [Tick annotations in RULE matching] in GHC.Core.Rules for +ticks. See Note [Tick annotations in RULE matching] in GHC.Core.Rules.Apply for details. Note [Cast swizzling on rule LHSs] diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs index 6a45129f06..4b10a924af 100644 --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -29,6 +29,7 @@ import GHC.Driver.Session ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen ) , gopt, hasPprDebug ) import GHC.Core +import GHC.Core.Rules import GHC.Core.Subst import GHC.Core.Utils import GHC.Core.Unfold @@ -40,8 +41,9 @@ import GHC.Core.Opt.OccurAnal( scrutBinderSwap_maybe ) import GHC.Core.DataCon import GHC.Core.Class( classTyVars ) import GHC.Core.Coercion hiding( substCo ) -import GHC.Core.Rules +import GHC.Core.Rules.Apply import GHC.Core.Predicate ( typeDeterminesValue ) +import GHC.Core.Unfoldings import GHC.Core.Type hiding ( substTy ) import GHC.Core.TyCon (TyCon, tyConName ) import GHC.Core.Multiplicity @@ -2586,19 +2588,19 @@ argToPat1 env in_scope val_env (Tick _ arg) arg_occ arg_str -- Ignore Notes. In particular, we want to ignore any InlineMe notes -- Perhaps we should not ignore profiling notes, but I'm going to -- ride roughshod over them all for now. - --- See Note [Tick annotations in RULE matching] in GHC.Core.Rules + --- See Note [Tick annotations in RULE matching] in GHC.Core.Rules.Apply argToPat1 env in_scope val_env (Let _ arg) arg_occ arg_str = argToPat env in_scope val_env arg arg_occ arg_str - -- See Note [Matching lets] in "GHC.Core.Rules" + -- See Note [Matching lets] in "GHC.Core.Rules.Apply" -- Look through let expressions -- e.g. f (let v = rhs in (v,w)) -- Here we can specialise for f (v,w) -- because the rule-matcher will look through the let. -{- Disabled; see Note [Matching cases] in "GHC.Core.Rules" +{- Disabled; see Note [Matching cases] in "GHC.Core.Rules.Apply" argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ - | exprOkForSpeculation scrut -- See Note [Matching cases] in "GHC.Core.Rules" + | exprOkForSpeculation scrut -- See Note [Matching cases] in "GHC.Core.Rules.Apply" = argToPat env in_scope val_env rhs arg_occ -} @@ -2702,7 +2704,7 @@ argToPat1 env in_scope val_env (Var v) arg_occ arg_str -- And by not wild-carding we tend to get forall'd -- variables that are in scope, which in turn can -- expose the weakness in let-matching --- See Note [Matching lets] in GHC.Core.Rules +-- See Note [Matching lets] in GHC.Core.Rules.Apply -- Check for a variable bound inside the function. -- Don't make a wild-card, because we may usefully share diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs index dda10da34e..d9f9f7e38e 100644 --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -27,6 +27,8 @@ import GHC.Core import GHC.Core.Make ( mkLitRubbish ) import GHC.Core.Unify ( tcMatchTy ) import GHC.Core.Rules +import GHC.Core.Rules.Apply +import GHC.Core.Unfoldings import GHC.Core.Utils ( exprIsTrivial , mkCast, exprType , stripTicksTop, mkInScopeSetBndrs ) diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs index 29f1e3973f..aefbafe03c 100644 --- a/compiler/GHC/Core/Opt/WorkWrap.hs +++ b/compiler/GHC/Core/Opt/WorkWrap.hs @@ -14,6 +14,7 @@ where import GHC.Prelude import GHC.Core +import GHC.Core.Rules import GHC.Core.Unfold.Make import GHC.Core.Utils ( exprType, exprIsHNF ) import GHC.Core.Type diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs index f599975355..b45fb1210b 100644 --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -22,6 +22,7 @@ where import GHC.Prelude import GHC.Core +import GHC.Core.Unfoldings import GHC.Core.Utils import GHC.Core.DataCon import GHC.Core.Make diff --git a/compiler/GHC/Core/Orphans.hs b/compiler/GHC/Core/Orphans.hs new file mode 100644 index 0000000000..6634812403 --- /dev/null +++ b/compiler/GHC/Core/Orphans.hs @@ -0,0 +1,112 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE BangPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | GHC.Core holds all the main data types for use by for the Glasgow Haskell Compiler midsection +module GHC.Core.Orphans ( + IsOrphan(..), isOrphan, notOrphan, chooseOrphanAnchor, + ) where + +import GHC.Prelude + +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Unique.Set + +import GHC.Utils.Binary + +import Data.Data hiding (TyCon) + +-- | Is this instance an orphan? If it is not an orphan, contains an 'OccName' +-- witnessing the instance's non-orphanhood. +-- See Note [Orphans] +data IsOrphan + = IsOrphan + | NotOrphan !OccName -- The OccName 'n' witnesses the instance's non-orphanhood + -- In that case, the instance is fingerprinted as part + -- of the definition of 'n's definition + deriving Data + +-- | Returns true if 'IsOrphan' is orphan. +isOrphan :: IsOrphan -> Bool +isOrphan IsOrphan = True +isOrphan _ = False + +-- | Returns true if 'IsOrphan' is not an orphan. +notOrphan :: IsOrphan -> Bool +notOrphan NotOrphan{} = True +notOrphan _ = False + +chooseOrphanAnchor :: NameSet -> IsOrphan +-- Something (rule, instance) is relate to all the Names in this +-- list. Choose one of them to be an "anchor" for the orphan. We make +-- the choice deterministic to avoid gratuitous changes in the ABI +-- hash (#4012). Specifically, use lexicographic comparison of +-- OccName rather than comparing Uniques +-- +-- NB: 'minimum' use Ord, and (Ord OccName) works lexicographically +-- +chooseOrphanAnchor local_names + | isEmptyNameSet local_names = IsOrphan + | otherwise = NotOrphan (minimum occs) + where + occs = map nameOccName $ nonDetEltsUniqSet local_names + -- It's OK to use nonDetEltsUFM here, see comments above + +instance Binary IsOrphan where + put_ bh IsOrphan = putByte bh 0 + put_ bh (NotOrphan n) = do + putByte bh 1 + put_ bh n + get bh = do + h <- getByte bh + case h of + 0 -> return IsOrphan + _ -> do + n <- get bh + return $ NotOrphan n + +{- +Note [Orphans] +~~~~~~~~~~~~~~ +Class instances, rules, and family instances are divided into orphans +and non-orphans. Roughly speaking, an instance/rule is an orphan if +its left hand side mentions nothing defined in this module. Orphan-hood +has two major consequences + + * A module that contains orphans is called an "orphan module". If + the module being compiled depends (transitively) on an orphan + module M, then M.hi is read in regardless of whether M is otherwise + needed. This is to ensure that we don't miss any instance decls in + M. But it's painful, because it means we need to keep track of all + the orphan modules below us. + + * A non-orphan is not finger-printed separately. Instead, for + fingerprinting purposes it is treated as part of the entity it + mentions on the LHS. For example + data T = T1 | T2 + instance Eq T where .... + The instance (Eq T) is incorporated as part of T's fingerprint. + + In contrast, orphans are all fingerprinted together in the + mi_orph_hash field of the ModIface. + + See GHC.Iface.Recomp.addFingerprints. + +Orphan-hood is computed + * For class instances: + when we make a ClsInst + (because it is needed during instance lookup) + + * For rules and family instances: + when we generate an IfaceRule (GHC.Iface.Make.coreRuleToIfaceRule) + or IfaceFamInst (GHC.Iface.Make.instanceToIfaceInst) +-} diff --git a/compiler/GHC/Core/Ppr.hs b/compiler/GHC/Core/Ppr.hs index d5d21e294d..01fe541968 100644 --- a/compiler/GHC/Core/Ppr.hs +++ b/compiler/GHC/Core/Ppr.hs @@ -30,6 +30,8 @@ module GHC.Core.Ppr ( import GHC.Prelude import GHC.Core +import GHC.Core.Rules +import GHC.Core.Unfoldings import GHC.Core.Stats (exprStats) import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Types.Literal( pprLiteral ) diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs index d9bd0a912c..92fc1665f9 100644 --- a/compiler/GHC/Core/Rules.hs +++ b/compiler/GHC/Core/Rules.hs @@ -1,1715 +1,143 @@ {- +(c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[CoreRules]{Rewrite rules} -} +{-# LANGUAGE NamedFieldPuns #-} --- | Functions for collecting together and applying rewrite rules to a module. --- The 'CoreRule' datatype itself is declared elsewhere. +-- | The CoreRule type and its friends are dealt with mainly in +-- GHC.Core.Rules, but GHC.Core.FVs, GHC.Core.Subst, GHC.Core.Ppr, +-- GHC.Core.Tidy also inspect the representation. module GHC.Core.Rules ( - -- ** Looking up rules - lookupRule, - - -- ** RuleBase, RuleEnv - RuleBase, RuleEnv(..), mkRuleEnv, emptyRuleEnv, - updExternalPackageRules, addLocalRules, updLocalRules, - emptyRuleBase, mkRuleBase, extendRuleBaseList, - pprRuleBase, - - -- ** Checking rule applications - ruleCheckProgram, - - -- ** Manipulating 'RuleInfo' rules - extendRuleInfo, addRuleInfo, - addIdSpecialisations, - - -- ** RuleBase and RuleEnv - - -- * Misc. CoreRule helpers - rulesOfBinds, getRules, pprRulesForUser, - - -- * Making rules - mkRule, mkSpecRule, roughTopNames - + -- * Core rule data types + CoreRule(..), + RuleName, RuleFun, IdUnfoldingFun, InScopeEnv, RuleOpts, + + -- ** Operations on 'CoreRule's + ruleArity, ruleName, ruleIdName, ruleActivation, + setRuleIdName, ruleModule, + isBuiltinRule, isLocalRule, isAutoRule, ) where import GHC.Prelude -import GHC.Unit.Module ( Module ) -import GHC.Unit.Module.Env -import GHC.Unit.Module.ModGuts( ModGuts(..) ) -import GHC.Unit.Module.Deps( Dependencies(..) ) - -import GHC.Driver.Session( DynFlags ) -import GHC.Driver.Ppr( showSDoc ) - -import GHC.Core -- All of it -import GHC.Core.Subst -import GHC.Core.SimpleOpt ( exprIsLambda_maybe ) -import GHC.Core.FVs ( exprFreeVars, exprsFreeVars, bindFreeVars - , rulesFreeVarsDSet, exprsOrphNames ) -import GHC.Core.Utils ( exprType, mkTick, mkTicks - , stripTicksTopT, stripTicksTopE - , isJoinBind, mkCastMCo ) -import GHC.Core.Ppr ( pprRules ) -import GHC.Core.Unify as Unify ( ruleMatchTyKiX ) -import GHC.Core.Type as Type - ( Type, extendTvSubst, extendCvSubst - , substTy, getTyVar_maybe ) -import GHC.Core.TyCo.Ppr( pprParendType ) -import GHC.Core.Coercion as Coercion -import GHC.Core.Tidy ( tidyRules ) -import GHC.Core.Map.Expr ( eqCoreExpr ) -import GHC.Core.Opt.Arity( etaExpandToJoinPointRule ) - -import GHC.Tc.Utils.TcType ( tcSplitTyConApp_maybe ) -import GHC.Builtin.Types ( anyTypeOfKind ) - -import GHC.Types.Id -import GHC.Types.Id.Info ( RuleInfo( RuleInfo ) ) +import GHC.Types.Var.Env( InScopeSet ) import GHC.Types.Var -import GHC.Types.Var.Env -import GHC.Types.Var.Set -import GHC.Types.Name ( Name, NamedThing(..), nameIsLocalOrFrom ) -import GHC.Types.Name.Set -import GHC.Types.Name.Env -import GHC.Types.Name.Occurrence( occNameFS ) -import GHC.Types.Unique.FM -import GHC.Types.Tickish +import GHC.Core +import GHC.Core.Orphans +import GHC.Core.Unfoldings +import GHC.Core.Rules.Config ( RuleOpts ) +import GHC.Types.Name +import GHC.Unit.Module import GHC.Types.Basic -import GHC.Data.FastString -import GHC.Data.Maybe -import GHC.Data.Bag - -import GHC.Utils.Misc as Utils -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Utils.Constants (debugIsOn) - -import Data.List (sortBy, mapAccumL, isPrefixOf) -import Data.Function ( on ) -import Control.Monad ( guard ) - -{- -Note [Overall plumbing for rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* After the desugarer: - - The ModGuts initially contains mg_rules :: [CoreRule] of - locally-declared rules for imported Ids. - - Locally-declared rules for locally-declared Ids are attached to - the IdInfo for that Id. See Note [Attach rules to local ids] in - GHC.HsToCore.Binds - -* GHC.Iface.Tidy strips off all the rules from local Ids and adds them to - mg_rules, so that the ModGuts has *all* the locally-declared rules. - -* The HomePackageTable contains a ModDetails for each home package - module. Each contains md_rules :: [CoreRule] of rules declared in - that module. The HomePackageTable grows as ghc --make does its - up-sweep. In batch mode (ghc -c), the HPT is empty; all imported modules - are treated by the "external" route, discussed next, regardless of - which package they come from. - -* The ExternalPackageState has a single eps_rule_base :: RuleBase for - Ids in other packages. This RuleBase simply grow monotonically, as - ghc --make compiles one module after another. - - During simplification, interface files may get demand-loaded, - as the simplifier explores the unfoldings for Ids it has in - its hand. (Via an unsafePerformIO; the EPS is really a cache.) - That in turn may make the EPS rule-base grow. In contrast, the - HPT never grows in this way. - -* The result of all this is that during Core-to-Core optimisation - there are four sources of rules: - - (a) Rules in the IdInfo of the Id they are a rule for. These are - easy: fast to look up, and if you apply a substitution then - it'll be applied to the IdInfo as a matter of course. - - (b) Rules declared in this module for imported Ids, kept in the - ModGuts. If you do a substitution, you'd better apply the - substitution to these. There are seldom many of these. - - (c) Rules declared in the HomePackageTable. These never change. - - (d) Rules in the ExternalPackageTable. These can grow in response - to lazy demand-loading of interfaces. - -* At the moment (c) is carried in a reader-monad way by the GHC.Core.Opt.Monad. - The HomePackageTable doesn't have a single RuleBase because technically - we should only be able to "see" rules "below" this module; so we - generate a RuleBase for (c) by combining rules from all the modules - "below" us. That's why we can't just select the home-package RuleBase - from HscEnv. - - [NB: we are inconsistent here. We should do the same for external - packages, but we don't. Same for type-class instances.] - -* So in the outer simplifier loop (simplifyPgmIO), we combine (b & c) into a single - RuleBase, reading - (b) from the ModGuts, - (c) from the GHC.Core.Opt.Monad, and - just before doing rule matching we read - (d) from its mutable variable - and combine it with the results from (b & c). - - In a single simplifier run new rules can be added into the EPS so it matters - to keep an up-to-date view of which rules have been loaded. For examples of - where this went wrong and caused cryptic performance regressions - see T19790 and !6735. - - -************************************************************************ -* * -\subsection[specialisation-IdInfo]{Specialisation info about an @Id@} -* * -************************************************************************ - -A CoreRule holds details of one rule for an Id, which -includes its specialisations. - -For example, if a rule for f is - RULE "f" forall @a @b d. f @(List a) @b d = f' a b - -then when we find an application of f to matching types, we simply replace -it by the matching RHS: - f (List Int) Bool dict ===> f' Int Bool -All the stuff about how many dictionaries to discard, and what types -to apply the specialised function to, are handled by the fact that the -Rule contains a template for the result of the specialisation. --} - -mkRule :: Module -> Bool -> Bool -> RuleName -> Activation - -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule --- ^ Used to make 'CoreRule' for an 'Id' defined in the module being --- compiled. See also 'GHC.Core.CoreRule' -mkRule this_mod is_auto is_local name act fn bndrs args rhs - = Rule { ru_name = name, ru_fn = fn, ru_act = act, - ru_bndrs = bndrs, ru_args = args, - ru_rhs = rhs, - ru_rough = roughTopNames args, - ru_origin = this_mod, - ru_orphan = orph, - ru_auto = is_auto, ru_local = is_local } - where - -- Compute orphanhood. See Note [Orphans] in GHC.Core.InstEnv - -- A rule is an orphan only if none of the variables - -- mentioned on its left-hand side are locally defined - lhs_names = extendNameSet (exprsOrphNames args) fn - - -- Since rules get eventually attached to one of the free names - -- from the definition when compiling the ABI hash, we should make - -- it deterministic. This chooses the one with minimal OccName - -- as opposed to uniq value. - local_lhs_names = filterNameSet (nameIsLocalOrFrom this_mod) lhs_names - orph = chooseOrphanAnchor local_lhs_names - --------------- -mkSpecRule :: DynFlags -> Module -> Bool -> Activation -> SDoc - -> Id -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule --- Make a specialisation rule, for Specialise or SpecConstr -mkSpecRule dflags this_mod is_auto inl_act herald fn bndrs args rhs - = case isJoinId_maybe fn of - Just join_arity -> etaExpandToJoinPointRule join_arity rule - Nothing -> rule - where - rule = mkRule this_mod is_auto is_local - rule_name - inl_act -- Note [Auto-specialisation and RULES] - (idName fn) - bndrs args rhs - - is_local = isLocalId fn - rule_name = mkSpecRuleName dflags herald fn args - -mkSpecRuleName :: DynFlags -> SDoc -> Id -> [CoreExpr] -> FastString -mkSpecRuleName dflags herald fn args - = mkFastString $ showSDoc dflags $ - herald <+> ftext (occNameFS (getOccName fn)) - -- This name ends up in interface files, so use occNameFS. - -- Otherwise uniques end up there, making builds - -- less deterministic (See #4012 comment:61 ff) - <+> hsep (mapMaybe ppr_call_key_ty args) - where - ppr_call_key_ty :: CoreExpr -> Maybe SDoc - ppr_call_key_ty (Type ty) = case getTyVar_maybe ty of - Just {} -> Just (text "@_") - Nothing -> Just $ char '@' <> pprParendType ty - ppr_call_key_ty _ = Nothing - - --------------- -roughTopNames :: [CoreExpr] -> [Maybe Name] --- ^ Find the \"top\" free names of several expressions. --- Such names are either: --- --- 1. The function finally being applied to in an application chain --- (if that name is a GlobalId: see "GHC.Types.Var#globalvslocal"), or --- --- 2. The 'TyCon' if the expression is a 'Type' --- --- This is used for the fast-match-check for rules; --- if the top names don't match, the rest can't -roughTopNames args = map roughTopName args - -roughTopName :: CoreExpr -> Maybe Name -roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of - Just (tc,_) -> Just (getName tc) - Nothing -> Nothing -roughTopName (Coercion _) = Nothing -roughTopName (App f _) = roughTopName f -roughTopName (Var f) | isGlobalId f -- Note [Care with roughTopName] - , isDataConWorkId f || idArity f > 0 - = Just (idName f) -roughTopName (Tick t e) | tickishFloatable t - = roughTopName e -roughTopName _ = Nothing - -ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool --- ^ @ruleCantMatch tpl actual@ returns True only if @actual@ --- definitely can't match @tpl@ by instantiating @tpl@. --- It's only a one-way match; unlike instance matching we --- don't consider unification. --- --- Notice that [_$_] --- @ruleCantMatch [Nothing] [Just n2] = False@ --- Reason: a template variable can be instantiated by a constant --- Also: --- @ruleCantMatch [Just n1] [Nothing] = False@ --- Reason: a local variable @v@ in the actuals might [_$_] - -ruleCantMatch (Just n1 : ts) (Just n2 : as) = n1 /= n2 || ruleCantMatch ts as -ruleCantMatch (_ : ts) (_ : as) = ruleCantMatch ts as -ruleCantMatch _ _ = False - -{- -Note [Care with roughTopName] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this - module M where { x = a:b } - module N where { ...f x... - RULE f (p:q) = ... } -You'd expect the rule to match, because the matcher can -look through the unfolding of 'x'. So we must avoid roughTopName -returning 'M.x' for the call (f x), or else it'll say "can't match" -and we won't even try!! - -However, suppose we have - RULE g (M.h x) = ... - foo = ...(g (M.k v)).... -where k is a *function* exported by M. We never really match -functions (lambdas) except by name, so in this case it seems like -a good idea to treat 'M.k' as a roughTopName of the call. --} - -pprRulesForUser :: [CoreRule] -> SDoc --- (a) tidy the rules --- (b) sort them into order based on the rule name --- (c) suppress uniques (unless -dppr-debug is on) --- This combination makes the output stable so we can use in testing --- It's here rather than in GHC.Core.Ppr because it calls tidyRules -pprRulesForUser rules - = withPprStyle defaultUserStyle $ - pprRules $ - sortBy (lexicalCompareFS `on` ruleName) $ - tidyRules emptyTidyEnv rules - -{- -************************************************************************ -* * - RuleInfo: the rules in an IdInfo -* * -************************************************************************ --} - -extendRuleInfo :: RuleInfo -> [CoreRule] -> RuleInfo -extendRuleInfo (RuleInfo rs1 fvs1) rs2 - = RuleInfo (rs2 ++ rs1) (rulesFreeVarsDSet rs2 `unionDVarSet` fvs1) - -addRuleInfo :: RuleInfo -> RuleInfo -> RuleInfo -addRuleInfo (RuleInfo rs1 fvs1) (RuleInfo rs2 fvs2) - = RuleInfo (rs1 ++ rs2) (fvs1 `unionDVarSet` fvs2) - -addIdSpecialisations :: Id -> [CoreRule] -> Id -addIdSpecialisations id rules - | null rules - = id - | otherwise - = setIdSpecialisation id $ - extendRuleInfo (idSpecialisation id) rules - --- | Gather all the rules for locally bound identifiers from the supplied bindings -rulesOfBinds :: [CoreBind] -> [CoreRule] -rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds - - -{- -************************************************************************ -* * - RuleBase -* * -************************************************************************ --} - --- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules -type RuleBase = NameEnv [CoreRule] - -- The rules are unordered; - -- we sort out any overlaps on lookup - -emptyRuleBase :: RuleBase -emptyRuleBase = emptyNameEnv - -mkRuleBase :: [CoreRule] -> RuleBase -mkRuleBase rules = extendRuleBaseList emptyRuleBase rules - -extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase -extendRuleBaseList rule_base new_guys - = foldl' extendRuleBase rule_base new_guys - -extendRuleBase :: RuleBase -> CoreRule -> RuleBase -extendRuleBase rule_base rule - = extendNameEnv_Acc (:) Utils.singleton rule_base (ruleIdName rule) rule - -pprRuleBase :: RuleBase -> SDoc -pprRuleBase rules = pprUFM rules $ \rss -> - vcat [ pprRules (tidyRules emptyTidyEnv rs) - | rs <- rss ] - --- | A full rule environment which we can apply rules from. Like a 'RuleBase', --- but it also includes the set of visible orphans we use to filter out orphan --- rules which are not visible (even though we can see them...) --- See Note [Orphans] in GHC.Core -data RuleEnv - = RuleEnv { re_local_rules :: !RuleBase -- Rules from this module - , re_home_rules :: !RuleBase -- Rule from the home package - -- (excl this module) - , re_eps_rules :: !RuleBase -- Rules from other packages - -- see Note [External package rules] - , re_visible_orphs :: !ModuleSet - } - -mkRuleEnv :: ModGuts -> RuleBase -> RuleBase -> RuleEnv -mkRuleEnv (ModGuts { mg_module = this_mod - , mg_deps = deps - , mg_rules = local_rules }) - eps_rules hpt_rules - = RuleEnv { re_local_rules = mkRuleBase local_rules - , re_home_rules = hpt_rules - , re_eps_rules = eps_rules - , re_visible_orphs = mkModuleSet vis_orphs } - where - vis_orphs = this_mod : dep_orphs deps - -updExternalPackageRules :: RuleEnv -> RuleBase -> RuleEnv --- Completely over-ride the external rules in RuleEnv -updExternalPackageRules rule_env eps_rules - = rule_env { re_eps_rules = eps_rules } - -updLocalRules :: RuleEnv -> [CoreRule] -> RuleEnv --- Completely over-ride the local rules in RuleEnv -updLocalRules rule_env local_rules - = rule_env { re_local_rules = mkRuleBase local_rules } - -addLocalRules :: RuleEnv -> [CoreRule] -> RuleEnv --- Add new local rules -addLocalRules rule_env rules - = rule_env { re_local_rules = extendRuleBaseList (re_local_rules rule_env) rules } - -emptyRuleEnv :: RuleEnv -emptyRuleEnv = RuleEnv { re_local_rules = emptyNameEnv - , re_home_rules = emptyNameEnv - , re_eps_rules = emptyNameEnv - , re_visible_orphs = emptyModuleSet } - -getRules :: RuleEnv -> Id -> [CoreRule] --- Given a RuleEnv and an Id, find the visible rules for that Id --- See Note [Where rules are found] -getRules (RuleEnv { re_local_rules = local_rules - , re_home_rules = home_rules - , re_eps_rules = eps_rules - , re_visible_orphs = orphs }) fn - - | Just {} <- isDataConId_maybe fn -- Short cut for data constructor workers - = [] -- and wrappers, which never have any rules - - | otherwise - = idCoreRules fn ++ - get local_rules ++ - find_visible home_rules ++ - find_visible eps_rules - - where - fn_name = idName fn - find_visible rb = filter (ruleIsVisible orphs) (get rb) - get rb = lookupNameEnv rb fn_name `orElse` [] - -ruleIsVisible :: ModuleSet -> CoreRule -> Bool -ruleIsVisible _ BuiltinRule{} = True -ruleIsVisible vis_orphs Rule { ru_orphan = orph, ru_origin = origin } - = notOrphan orph || origin `elemModuleSet` vis_orphs - -{- Note [Where rules are found] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The rules for an Id come from two places: - (a) the ones it is born with, stored inside the Id itself (idCoreRules fn), - (b) rules added in other modules, stored in the global RuleBase (imp_rules) - -It's tempting to think that - - LocalIds have only (a) - - non-LocalIds have only (b) - -but that isn't quite right: - - - PrimOps and ClassOps are born with a bunch of rules inside the Id, - even when they are imported - - - The rules in GHC.Core.Opt.ConstantFold.builtinRules should be active even - in the module defining the Id (when it's a LocalId), but - the rules are kept in the global RuleBase - - Note [External package rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In Note [Overall plumbing for rules], it is explained that the final -RuleBase which we must consider is combined from 4 different sources. - -During simplifier runs, the fourth source of rules is constantly being updated -as new interfaces are loaded into the EPS. Therefore just before we check to see -if any rules match we get the EPS RuleBase and combine it with the existing RuleBase -and then perform exactly 1 lookup into the new map. - -It is more efficient to avoid combining the environments and store the uncombined -environments as we can instead perform 1 lookup into each environment and then combine -the results. - -Essentially we use the identity: - -> lookupNameEnv n (plusNameEnv_C (++) rb1 rb2) -> = lookupNameEnv n rb1 ++ lookupNameEnv n rb2 - -The latter being more efficient as we don't construct an intermediate -map. --} - -{- -************************************************************************ -* * - Matching -* * -************************************************************************ --} - --- | The main rule matching function. Attempts to apply all (active) --- supplied rules to this instance of an application in a given --- context, returning the rule applied and the resulting expression if --- successful. -lookupRule :: RuleOpts -> InScopeEnv - -> (Activation -> Bool) -- When rule is active - -> Id -- Function head - -> [CoreExpr] -- Args - -> [CoreRule] -- Rules - -> Maybe (CoreRule, CoreExpr) - --- See Note [Extra args in the target] --- See comments on matchRule -lookupRule opts rule_env@(in_scope,_) is_active fn args rules - = -- pprTrace "lookupRule" (ppr fn <+> ppr args $$ ppr rules $$ ppr in_scope) $ - case go [] rules of - [] -> Nothing - (m:ms) -> Just (findBest in_scope (fn,args') m ms) - where - rough_args = map roughTopName args - - -- Strip ticks from arguments, see Note [Tick annotations in RULE - -- matching]. We only collect ticks if a rule actually matches - - -- this matters for performance tests. - args' = map (stripTicksTopE tickishFloatable) args - ticks = concatMap (stripTicksTopT tickishFloatable) args - - go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)] - go ms [] = ms - go ms (r:rs) - | Just e <- matchRule opts rule_env is_active fn args' rough_args r - = go ((r,mkTicks ticks e):ms) rs - | otherwise - = -- pprTrace "match failed" (ppr r $$ ppr args $$ - -- ppr [ (arg_id, unfoldingTemplate unf) - -- | Var arg_id <- args - -- , let unf = idUnfolding arg_id - -- , isCheapUnfolding unf] ) - go ms rs - -findBest :: InScopeSet -> (Id, [CoreExpr]) - -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr) --- All these pairs matched the expression --- Return the pair the most specific rule --- The (fn,args) is just for overlap reporting - -findBest _ _ (rule,ans) [] = (rule,ans) -findBest in_scope target (rule1,ans1) ((rule2,ans2):prs) - | isMoreSpecific in_scope rule1 rule2 = findBest in_scope target (rule1,ans1) prs - | isMoreSpecific in_scope rule2 rule1 = findBest in_scope target (rule2,ans2) prs - | debugIsOn = let pp_rule rule - = ifPprDebug (ppr rule) - (doubleQuotes (ftext (ruleName rule))) - in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)" - (vcat [ whenPprDebug $ - text "Expression to match:" <+> ppr fn - <+> sep (map ppr args) - , text "Rule 1:" <+> pp_rule rule1 - , text "Rule 2:" <+> pp_rule rule2]) $ - findBest in_scope target (rule1,ans1) prs - | otherwise = findBest in_scope target (rule1,ans1) prs - where - (fn,args) = target - -isMoreSpecific :: InScopeSet -> CoreRule -> CoreRule -> Bool --- The call (rule1 `isMoreSpecific` rule2) --- sees if rule2 can be instantiated to look like rule1 --- See Note [isMoreSpecific] -isMoreSpecific _ (BuiltinRule {}) _ = False -isMoreSpecific _ (Rule {}) (BuiltinRule {}) = True -isMoreSpecific in_scope (Rule { ru_bndrs = bndrs1, ru_args = args1 }) - (Rule { ru_bndrs = bndrs2, ru_args = args2 - , ru_name = rule_name2, ru_rhs = rhs2 }) - = isJust (matchN (full_in_scope, id_unfolding_fun) - rule_name2 bndrs2 args2 args1 rhs2) - where - id_unfolding_fun _ = NoUnfolding -- Don't expand in templates - full_in_scope = in_scope `extendInScopeSetList` bndrs1 - -noBlackList :: Activation -> Bool -noBlackList _ = False -- Nothing is black listed - -{- Note [isMoreSpecific] -~~~~~~~~~~~~~~~~~~~~~~~~ -The call (rule1 `isMoreSpecific` rule2) -sees if rule2 can be instantiated to look like rule1. - -Wrinkle: - -* We take the view that a BuiltinRule is less specific than - anything else, because we want user-defined rules to "win" - In particular, class ops have a built-in rule, but we - prefer any user-specific rules to win: - eg (#4397) - truncate :: (RealFrac a, Integral b) => a -> b - {-# RULES "truncate/Double->Int" truncate = double2Int #-} - double2Int :: Double -> Int - We want the specific RULE to beat the built-in class-op rule - -Note [Extra args in the target] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we find a matching rule, we return (Just (rule, rhs)), -/but/ the rule firing has only consumed as many of the input args -as the ruleArity says. The unused arguments are handled by the code in -GHC.Core.Opt.Simplify.tryRules, using the arity of the returned rule. - -E.g. Rule "foo": forall a b. f p1 p2 = rhs - Target: f e1 e2 e3 - -Then lookupRule returns Just (Rule "foo", rhs), where Rule "foo" -has ruleArity 2. The real rewrite is - f e1 e2 e3 ==> rhs e3 - -You might think it'd be cleaner for lookupRule to deal with the -leftover arguments, by applying 'rhs' to them, but the main call -in the Simplifier works better as it is. Reason: the 'args' passed -to lookupRule are the result of a lazy substitution - -Historical note: - -At one stage I tried to match even if there are more args in the -/template/ than the target. I now think this is probably a bad idea. -Should the template (map f xs) match (map g)? I think not. For a -start, in general eta expansion wastes work. SLPJ July 99 --} - ------------------------------------- -matchRule :: RuleOpts -> InScopeEnv -> (Activation -> Bool) - -> Id -> [CoreExpr] -> [Maybe Name] - -> CoreRule -> Maybe CoreExpr - --- If (matchRule rule args) returns Just (name,rhs) --- then (f args) matches the rule, and the corresponding --- rewritten RHS is rhs --- --- The returned expression is occurrence-analysed --- --- Example --- --- The rule --- forall f g x. map f (map g x) ==> map (f . g) x --- is stored --- CoreRule "map/map" --- [f,g,x] -- tpl_vars --- [f,map g x] -- tpl_args --- map (f.g) x) -- rhs --- --- Then the expression --- map e1 (map e2 e3) e4 --- results in a call to --- matchRule the_rule [e1,map e2 e3,e4] --- = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3) --- --- NB: The 'surplus' argument e4 in the input is simply dropped. --- See Note [Extra args in the target] - -matchRule opts rule_env _is_active fn args _rough_args - (BuiltinRule { ru_try = match_fn }) --- Built-in rules can't be switched off, it seems - = case match_fn opts rule_env fn args of - Nothing -> Nothing - Just expr -> Just expr - -matchRule _ rule_env is_active _ args rough_args - (Rule { ru_name = rule_name, ru_act = act, ru_rough = tpl_tops - , ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs }) - | not (is_active act) = Nothing - | ruleCantMatch tpl_tops rough_args = Nothing - | otherwise = matchN rule_env rule_name tpl_vars tpl_args args rhs - - ---------------------------------------- -matchN :: InScopeEnv - -> RuleName -> [Var] -> [CoreExpr] - -> [CoreExpr] -> CoreExpr -- ^ Target; can have more elements than the template - -> Maybe CoreExpr --- For a given match template and context, find bindings to wrap around --- the entire result and what should be substituted for each template variable. --- --- Fail if there are too few actual arguments from the target to match the template --- --- See Note [Extra args in the target] --- If there are too /many/ actual arguments, we simply ignore the --- trailing ones, returning the result of applying the rule to a prefix --- of the actual arguments. - -matchN (in_scope, id_unf) rule_name tmpl_vars tmpl_es target_es rhs - = do { rule_subst <- match_exprs init_menv emptyRuleSubst tmpl_es target_es - ; let (_, matched_es) = mapAccumL (lookup_tmpl rule_subst) - (mkEmptySubst in_scope) $ - tmpl_vars `zip` tmpl_vars1 - bind_wrapper = rs_binds rule_subst - -- Floated bindings; see Note [Matching lets] - ; return (bind_wrapper $ - mkLams tmpl_vars rhs `mkApps` matched_es) } - where - (init_rn_env, tmpl_vars1) = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars - -- See Note [Cloning the template binders] - - init_menv = RV { rv_tmpls = mkVarSet tmpl_vars1 - , rv_lcl = init_rn_env - , rv_fltR = mkEmptySubst (rnInScopeSet init_rn_env) - , rv_unf = id_unf } - - lookup_tmpl :: RuleSubst -> Subst -> (InVar,OutVar) -> (Subst, CoreExpr) - -- Need to return a RuleSubst solely for the benefit of mk_fake_ty - lookup_tmpl (RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst }) - tcv_subst (tmpl_var, tmpl_var1) - | isId tmpl_var1 - = case lookupVarEnv id_subst tmpl_var1 of - Just e | Coercion co <- e - -> (Type.extendCvSubst tcv_subst tmpl_var1 co, Coercion co) - | otherwise - -> (tcv_subst, e) - Nothing | Just refl_co <- isReflCoVar_maybe tmpl_var1 - , let co = Coercion.substCo tcv_subst refl_co - -> -- See Note [Unbound RULE binders] - (Type.extendCvSubst tcv_subst tmpl_var1 co, Coercion co) - | otherwise - -> unbound tmpl_var - - | otherwise - = (Type.extendTvSubst tcv_subst tmpl_var1 ty', Type ty') - where - ty' = case lookupVarEnv tv_subst tmpl_var1 of - Just ty -> ty - Nothing -> fake_ty -- See Note [Unbound RULE binders] - fake_ty = anyTypeOfKind (Type.substTy tcv_subst (tyVarKind tmpl_var1)) - -- This substitution is the sole reason we accumulate - -- TCvSubst in lookup_tmpl - - unbound tmpl_var - = pprPanic "Template variable unbound in rewrite rule" $ - vcat [ text "Variable:" <+> ppr tmpl_var <+> dcolon <+> ppr (varType tmpl_var) - , text "Rule" <+> pprRuleName rule_name - , text "Rule bndrs:" <+> ppr tmpl_vars - , text "LHS args:" <+> ppr tmpl_es - , text "Actual args:" <+> ppr target_es ] - ----------------------- -match_exprs :: RuleMatchEnv -> RuleSubst - -> [CoreExpr] -- Templates - -> [CoreExpr] -- Targets - -> Maybe RuleSubst --- If the targets are longer than templates, succeed, simply ignoring --- the leftover targets. This matters in the call in matchN. --- --- Precondition: corresponding elements of es1 and es2 have the same --- type, assuming earlier elements match. --- Example: f :: forall v. v -> blah --- match_exprs [Type a, y::a] [Type Int, 3] --- Then, after matching Type a against Type Int, --- the type of (y::a) matches that of (3::Int) -match_exprs _ subst [] _ - = Just subst -match_exprs renv subst (e1:es1) (e2:es2) - = do { subst' <- match renv subst e1 e2 MRefl - ; match_exprs renv subst' es1 es2 } -match_exprs _ _ _ _ = Nothing - - -{- Note [Unbound RULE binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It can be the case that the binder in a rule is not actually -bound on the LHS: - -* Type variables. Type synonyms with phantom args can give rise to - unbound template type variables. Consider this (#10689, - simplCore/should_compile/T10689): - - type Foo a b = b - - f :: Eq a => a -> Bool - f x = x==x - - {-# RULES "foo" forall (x :: Foo a Char). f x = True #-} - finkle = f 'c' - - The rule looks like - forall (a::*) (d::Eq Char) (x :: Foo a Char). - f (Foo a Char) d x = True - - Matching the rule won't bind 'a', and legitimately so. We fudge by - pretending that 'a' is bound to (Any :: *). - -* Coercion variables. On the LHS of a RULE for a local binder - we might have - RULE forall (c :: a~b). f (x |> c) = e - Now, if that binding is inlined, so that a=b=Int, we'd get - RULE forall (c :: Int~Int). f (x |> c) = e - and now when we simplify the LHS (Simplify.simplRule) we - optCoercion (look at the CoVarCo case) will turn that 'c' into Refl: - RULE forall (c :: Int~Int). f (x |> <Int>) = e - and then perhaps drop it altogether. Now 'c' is unbound. - - It's tricky to be sure this never happens, so instead I - say it's OK to have an unbound coercion binder in a RULE - provided its type is (c :: t~t). Then, when the RULE - fires we can substitute <t> for c. - - This actually happened (in a RULE for a local function) - in #13410, and also in test T10602. - -Note [Cloning the template binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following match (example 1): - Template: forall x. f x - Target: f (x+1) -This should succeed, because the template variable 'x' has nothing to -do with the 'x' in the target. - -Likewise this one (example 2): - Template: forall x. f (\x.x) - Target: f (\y.y) - -We achieve this simply by using rnBndrL to clone the template -binders if they are already in scope. - ------- Historical note ------- -At one point I tried simply adding the template binders to the -in-scope set /without/ cloning them, but that failed in a horribly -obscure way in #14777. Problem was that during matching we look -up target-term variables in the in-scope set (see Note [Lookup -in-scope]). If a target-term variable happens to name-clash with a -template variable, that lookup will find the template variable, which -is /utterly/ bogus. In #14777, this transformed a term variable -into a type variable, and then crashed when we wanted its idInfo. ------- End of historical note ------- - - -************************************************************************ -* * - The main matcher -* * -********************************************************************* -} - -data RuleMatchEnv - = RV { rv_lcl :: RnEnv2 -- Renamings for *local bindings* - -- (lambda/case) - , rv_tmpls :: VarSet -- Template variables - -- (after applying envL of rv_lcl) - , rv_fltR :: Subst -- Renamings for floated let-bindings - -- (domain disjoint from envR of rv_lcl) - -- See Note [Matching lets] - -- N.B. The InScopeSet of rv_fltR is always ignored; - -- see (4) in Note [Matching lets]. - , rv_unf :: IdUnfoldingFun - } - -{- Note [rv_lcl in RuleMatchEnv] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider matching - Template: \x->f - Target: \f->f - -where 'f' is free in the template. When we meet the lambdas we must -remember to rename f :-> f' in the target, as well as x :-> f -in the template. The rv_lcl::RnEnv2 does that. - -Similarly, consider matching - Template: {a} \b->b - Target: \a->3 -We must rename the \a. Otherwise when we meet the lambdas we might -substitute [b :-> a] in the template, and then erroneously succeed in -matching what looks like the template variable 'a' against 3. - -So we must add the template vars to the in-scope set before starting; -see `init_menv` in `matchN`. --} - -rvInScopeEnv :: RuleMatchEnv -> InScopeEnv -rvInScopeEnv renv = (rnInScopeSet (rv_lcl renv), rv_unf renv) - --- * The domain of the TvSubstEnv and IdSubstEnv are the template --- variables passed into the match. --- --- * The BindWrapper in a RuleSubst are the bindings floated out --- from nested matches; see the Let case of match, below --- -data RuleSubst = RS { rs_tv_subst :: TvSubstEnv -- Range is the - , rs_id_subst :: IdSubstEnv -- template variables - , rs_binds :: BindWrapper -- Floated bindings - , rs_bndrs :: [Var] -- Variables bound by floated lets - } - -type BindWrapper = CoreExpr -> CoreExpr - -- See Notes [Matching lets] and [Matching cases] - -- we represent the floated bindings as a core-to-core function - -emptyRuleSubst :: RuleSubst -emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv - , rs_binds = \e -> e, rs_bndrs = [] } - - -{- Note [Casts in the target] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As far as possible we don't want casts in the target to get in the way of -matching. E.g. -* (let bind in e) |> co -* (case e of alts) |> co -* (\ a b. f a b) |> co - -In the first two cases we want to float the cast inwards so we can match on -the let/case. This is not important in practice because the Simplifier does -this anyway. - -But the third case /is/ important: we don't want the cast to get in the way -of eta-reduction. See Note [Cancel reflexive casts] for a real life example. - -The most convenient thing is to make 'match' take an MCoercion argument, thus: - -* The main matching function - match env subst template target mco - matches template ~ (target |> mco) - -* Invariant: typeof( subst(template) ) = typeof( target |> mco ) - -Note that for applications - (e1 e2) ~ (d1 d2) |> co -where 'co' is non-reflexive, we simply fail. You might wonder about - (e1 e2) ~ ((d1 |> co1) d2) |> co2 -but the Simplifer pushes the casts in an application to to the -right, if it can, so this doesn't really arise. - -Note [Coercion arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~ -What if we have (f co) in the template, where the 'co' is a coercion -argument to f? Right now we have nothing in place to ensure that a -coercion /argument/ in the template is a variable. We really should, -perhaps by abstracting over that variable. - -C.f. the treatment of dictionaries in GHC.HsToCore.Binds.decompseRuleLhs. - -For now, though, we simply behave badly, by failing in match_co. -We really should never rely on matching the structure of a coercion -(which is just a proof). - -Note [Casts in the template] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the definition - f x = e, -and SpecConstr on call pattern - f ((e1,e2) |> co) - -We'll make a RULE - RULE forall a,b,g. f ((a,b)|> g) = $sf a b g - $sf a b g = e[ ((a,b)|> g) / x ] - -So here is the invariant: - - In the template, in a cast (e |> co), - the cast `co` is always a /variable/. - -Matching should bind that variable to an actual coercion, so that we -can use it in $sf. So a Cast on the LHS (the template) calls -match_co, which succeeds when the template cast is a variable -- which -it always is. That is why match_co has so few cases. - -See also -* Note [Coercion arguments] -* Note [Matching coercion variables] in GHC.Core.Unify. -* Note [Cast swizzling on rule LHSs] in GHC.Core.Opt.Simplify.Utils: - sm_cast_swizzle is switched off in the template of a RULE --} - ----------------------- -match :: RuleMatchEnv - -> RuleSubst -- Substitution applies to template only - -> CoreExpr -- Template - -> CoreExpr -- Target - -> MCoercion - -> Maybe RuleSubst - --- Postcondition (TypeInv): if matching succeeds, then --- typeof( subst(template) ) = typeof( target |> mco ) --- But this is /not/ a pre-condition! The types of template and target --- may differ, see the (App e1 e2) case --- --- Invariant (CoInv): if mco :: ty ~ ty, then it is MRefl, not MCo co --- See Note [Cancel reflexive casts] --- --- See the notes with Unify.match, which matches types --- Everything is very similar for terms - - ------------------------- Ticks --------------------- --- We look through certain ticks. See Note [Tick annotations in RULE matching] -match renv subst e1 (Tick t e2) mco - | tickishFloatable t - = match renv subst' e1 e2 mco - | otherwise - = Nothing - where - subst' = subst { rs_binds = rs_binds subst . mkTick t } - -match renv subst e@(Tick t e1) e2 mco - | tickishFloatable t -- Ignore floatable ticks in rule template. - = match renv subst e1 e2 mco - | otherwise - = pprPanic "Tick in rule" (ppr e) - ------------------------- Types --------------------- -match renv subst (Type ty1) (Type ty2) _mco - = match_ty renv subst ty1 ty2 - ------------------------- Coercions --------------------- --- See Note [Coercion arguments] for why this isn't really right -match renv subst (Coercion co1) (Coercion co2) MRefl - = match_co renv subst co1 co2 - -- The MCo case corresponds to matching co ~ (co2 |> co3) - -- and I have no idea what to do there -- or even if it can occur - -- Failing seems the simplest thing to do; it's certainly safe. - ------------------------- Casts --------------------- --- See Note [Casts in the template] --- Note [Casts in the target] --- Note [Cancel reflexive casts] - -match renv subst e1 (Cast e2 co2) mco - = match renv subst e1 e2 (checkReflexiveMCo (mkTransMCoR co2 mco)) - -- checkReflexiveMCo: cancel casts if possible - -- This is important: see Note [Cancel reflexive casts] - -match renv subst (Cast e1 co1) e2 mco - = -- See Note [Casts in the template] - do { let co2 = case mco of - MRefl -> mkRepReflCo (exprType e2) - MCo co2 -> co2 - ; subst1 <- match_co renv subst co1 co2 - -- If match_co succeeds, then (exprType e1) = (exprType e2) - -- Hence the MRefl in the next line - ; match renv subst1 e1 e2 MRefl } - ------------------------- Literals --------------------- -match _ subst (Lit lit1) (Lit lit2) mco - | lit1 == lit2 - = assertPpr (isReflMCo mco) (ppr mco) $ - Just subst - ------------------------- Variables --------------------- --- The Var case follows closely what happens in GHC.Core.Unify.match -match renv subst (Var v1) e2 mco - = match_var renv subst v1 (mkCastMCo e2 mco) - -match renv subst e1 (Var v2) mco -- Note [Expanding variables] - | not (inRnEnvR rn_env v2) -- Note [Do not expand locally-bound variables] - , Just e2' <- expandUnfolding_maybe (rv_unf renv v2') - = match (renv { rv_lcl = nukeRnEnvR rn_env }) subst e1 e2' mco - where - v2' = lookupRnInScope rn_env v2 - rn_env = rv_lcl renv - -- Notice that we look up v2 in the in-scope set - -- See Note [Lookup in-scope] - -- No need to apply any renaming first (hence no rnOccR) - -- because of the not-inRnEnvR - ------------------------- Applications --------------------- --- Note the match on MRefl! We fail if there is a cast in the target --- (e1 e2) ~ (d1 d2) |> co --- See Note [Cancel reflexive casts]: in the Cast equations for 'match' --- we aggressively ensure that if MCo is reflective, it really is MRefl. -match renv subst (App f1 a1) (App f2 a2) MRefl - = do { subst' <- match renv subst f1 f2 MRefl - ; match renv subst' a1 a2 MRefl } - ------------------------- Float lets --------------------- -match renv subst e1 (Let bind e2) mco - | -- pprTrace "match:Let" (vcat [ppr bind, ppr $ okToFloat (rv_lcl renv) (bindFreeVars bind)]) $ - not (isJoinBind bind) -- can't float join point out of argument position - , okToFloat (rv_lcl renv) (bindFreeVars bind) -- See Note [Matching lets] - = match (renv { rv_fltR = flt_subst' - , rv_lcl = rv_lcl renv `extendRnInScopeSetList` new_bndrs }) - -- We are floating the let-binding out, as if it had enclosed - -- the entire target from Day 1. So we must add its binders to - -- the in-scope set (#20200) - (subst { rs_binds = rs_binds subst . Let bind' - , rs_bndrs = new_bndrs ++ rs_bndrs subst }) - e1 e2 mco - | otherwise - = Nothing - where - in_scope = rnInScopeSet (rv_lcl renv) `extendInScopeSetList` rs_bndrs subst - -- in_scope: see (4) in Note [Matching lets] - flt_subst = rv_fltR renv `setInScope` in_scope - (flt_subst', bind') = substBind flt_subst bind - new_bndrs = bindersOf bind' - ------------------------- Lambdas --------------------- -match renv subst (Lam x1 e1) e2 mco - | Just (x2, e2', ts) <- exprIsLambda_maybe (rvInScopeEnv renv) (mkCastMCo e2 mco) - -- See Note [Lambdas in the template] - = let renv' = rnMatchBndr2 renv x1 x2 - subst' = subst { rs_binds = rs_binds subst . flip (foldr mkTick) ts } - in match renv' subst' e1 e2' MRefl - -match renv subst e1 e2@(Lam {}) mco - | Just (renv', e2') <- eta_reduce renv e2 -- See Note [Eta reduction in the target] - = match renv' subst e1 e2' mco - -{- Note [Lambdas in the template] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we match - Template: (\x. blah_template) - Target: (\y. blah_target) -then we want to match inside the lambdas, using rv_lcl to match up -x and y. - -But what about this? - Template (\x. (blah1 |> cv)) - Target (\y. blah2) |> co - -This happens quite readily, because the Simplifier generally moves -casts outside lambdas: see Note [Casts and lambdas] in -GHC.Core.Opt.Simplify.Utils. So, tiresomely, we want to push `co` -back inside, which is what `exprIsLambda_maybe` does. But we've -stripped off that cast, so now we need to put it back, hence mkCastMCo. - -Unlike the target, where we attempt eta-reduction, we do not attempt -to eta-reduce the template, and may therefore fail on - Template: \x. f True x - Target f True - -It's not especially easy to deal with eta reducing the template, -and never happens, because no one write eta-expanded left-hand-sides. --} - ------------------------- Case expression --------------------- -{- Disabled: see Note [Matching cases] below -match renv (tv_subst, id_subst, binds) e1 - (Case scrut case_bndr ty [(con, alt_bndrs, rhs)]) - | exprOkForSpeculation scrut -- See Note [Matching cases] - , okToFloat rn_env bndrs (exprFreeVars scrut) - = match (renv { me_env = rn_env' }) - (tv_subst, id_subst, binds . case_wrap) - e1 rhs - where - rn_env = me_env renv - rn_env' = extendRnInScopeList rn_env bndrs - bndrs = case_bndr : alt_bndrs - case_wrap rhs' = Case scrut case_bndr ty [(con, alt_bndrs, rhs')] --} - -match renv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2) mco - = do { subst1 <- match_ty renv subst ty1 ty2 - ; subst2 <- match renv subst1 e1 e2 MRefl - ; let renv' = rnMatchBndr2 renv x1 x2 - ; match_alts renv' subst2 alts1 alts2 mco -- Alts are both sorted - } - --- Everything else fails -match _ _ _e1 _e2 _mco = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $ - Nothing - -------------- -eta_reduce :: RuleMatchEnv -> CoreExpr -> Maybe (RuleMatchEnv, CoreExpr) --- See Note [Eta reduction in the target] -eta_reduce renv e@(Lam {}) - = go renv id [] e - where - go :: RuleMatchEnv -> BindWrapper -> [Var] -> CoreExpr - -> Maybe (RuleMatchEnv, CoreExpr) - go renv bw vs (Let b e) = go renv (bw . Let b) vs e - - go renv bw vs (Lam v e) = go renv' bw (v':vs) e - where - (rn_env', v') = rnBndrR (rv_lcl renv) v - renv' = renv { rv_lcl = rn_env' } - - go renv bw (v:vs) (App f arg) - | Var a <- arg, v == rnOccR (rv_lcl renv) a - = go renv bw vs f - - | Type ty <- arg, Just tv <- getTyVar_maybe ty - , v == rnOccR (rv_lcl renv) tv - = go renv bw vs f - - go renv bw [] e = Just (renv, bw e) - go _ _ (_:_) _ = Nothing - -eta_reduce _ _ = Nothing - -{- Note [Eta reduction in the target] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we are faced with this (#19790) - Template {x} f x - Target (\a b c. let blah in f x a b c) - -You might wonder why we have an eta-expanded target (see first subtle -point below), but regardless of how it came about, we'd like -eta-expansion not to impede matching. - -So eta_reduce does on-the-fly eta-reduction of the target expression. -Given (\a b c. let blah in e a b c), it returns (let blah in e). - -Subtle points: -* Consider a target: \x. f <expensive> x - In the main eta-reducer we do not eta-reduce this, because doing so - might reduce the arity of the expression (from 1 to zero, because of - <expensive>). But for rule-matching we /do/ want to match template - (f a) against target (\x. f <expensive> x), with a := <expensive> - - This is a compelling reason for not relying on the Simplifier's - eta-reducer. - -* The Lam case of eta_reduce renames as it goes. Consider - (\x. \x. f x x). We should not eta-reduce this. As we go we rename - the first x to x1, and the second to x2; then both argument x's are x2. - -* eta_reduce does /not/ need to check that the bindings 'blah' - and expression 'e' don't mention a b c; but it /does/ extend the - rv_lcl RnEnv2 (see rn_bndr in eta_reduce). - * If 'blah' mentions the binders, the let-float rule won't - fire; and - * if 'e' mentions the binders we we'll also fail to match - e.g. because of the exprFreeVars test in match_tmpl_var. - - Example: Template: {x} f a -- Some top-level 'a' - Target: (\a b. f a a b) -- The \a shadows top level 'a' - Then eta_reduce will /succeed/, with - (rnEnvR = [a :-> a'], f a) - The returned RnEnv will map [a :-> a'], where a' is fresh. (There is - no need to rename 'b' because (in this example) it is not in scope. - So it's as if we'd returned (f a') from eta_reduce; the renaming applied - to the target is simply deferred. - -Note [Cancel reflexive casts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here is an example (from #19790) which we want to catch - (f x) ~ (\a b. (f x |> co) a b) |> sym co -where - f :: Int -> Stream - co :: Stream ~ T1 -> T2 -> T3 - -when we eta-reduce (\a b. blah a b) to 'blah', we'll get - (f x) ~ (f x) |> co |> sym co - -and we really want to spot that the co/sym-co cancels out. -Hence - * We keep an invariant that the MCoercion is always MRefl - if the MCoercion is reflexive - * We maintain this invariant via the call to checkReflexiveMCo - in the Cast case of 'match'. --} - -------------- -match_co :: RuleMatchEnv - -> RuleSubst - -> Coercion - -> Coercion - -> Maybe RuleSubst --- We only match if the template is a coercion variable or Refl: --- see Note [Casts in the template] --- Like 'match' it is /not/ guaranteed that --- coercionKind template = coercionKind target --- But if match_co succeeds, it /is/ guaranteed that --- coercionKind (subst template) = coercionKind target - -match_co renv subst co1 co2 - | Just cv <- getCoVar_maybe co1 - = match_var renv subst cv (Coercion co2) - - | Just (ty1, r1) <- isReflCo_maybe co1 - = do { (ty2, r2) <- isReflCo_maybe co2 - ; guard (r1 == r2) - ; match_ty renv subst ty1 ty2 } - - | debugIsOn - = pprTrace "match_co: needs more cases" (ppr co1 $$ ppr co2) Nothing - -- Currently just deals with CoVarCo and Refl - - | otherwise - = Nothing - -------------- -rnMatchBndr2 :: RuleMatchEnv -> Var -> Var -> RuleMatchEnv -rnMatchBndr2 renv x1 x2 - = renv { rv_lcl = rnBndr2 (rv_lcl renv) x1 x2 - , rv_fltR = delBndr (rv_fltR renv) x2 } - - ------------------------------------------- -match_alts :: RuleMatchEnv - -> RuleSubst - -> [CoreAlt] -- Template - -> [CoreAlt] -> MCoercion -- Target - -> Maybe RuleSubst -match_alts _ subst [] [] _ - = return subst -match_alts renv subst (Alt c1 vs1 r1:alts1) (Alt c2 vs2 r2:alts2) mco - | c1 == c2 - = do { subst1 <- match renv' subst r1 r2 mco - ; match_alts renv subst1 alts1 alts2 mco } - where - renv' = foldl' mb renv (vs1 `zip` vs2) - mb renv (v1,v2) = rnMatchBndr2 renv v1 v2 - -match_alts _ _ _ _ _ - = Nothing - ------------------------------------------- -okToFloat :: RnEnv2 -> VarSet -> Bool -okToFloat rn_env bind_fvs - = allVarSet not_captured bind_fvs - where - not_captured fv = not (inRnEnvR rn_env fv) - ------------------------------------------- -match_var :: RuleMatchEnv - -> RuleSubst - -> Var -- Template - -> CoreExpr -- Target - -> Maybe RuleSubst -match_var renv@(RV { rv_tmpls = tmpls, rv_lcl = rn_env, rv_fltR = flt_env }) - subst v1 e2 - | v1' `elemVarSet` tmpls - = match_tmpl_var renv subst v1' e2 - - | otherwise -- v1' is not a template variable; check for an exact match with e2 - = case e2 of -- Remember, envR of rn_env is disjoint from rv_fltR - Var v2 | Just v2' <- rnOccR_maybe rn_env v2 - -> -- v2 was bound by a nested lambda or case - if v1' == v2' then Just subst - else Nothing - - -- v2 is not bound nestedly; it is free - -- in the whole expression being matched - -- So it will be in the InScopeSet for flt_env (#20200) - | Var v2' <- lookupIdSubst flt_env v2 - , v1' == v2' - -> Just subst - | otherwise - -> Nothing - - _ -> Nothing - - where - v1' = rnOccL rn_env v1 - -- If the template is - -- forall x. f x (\x -> x) = ... - -- Then the x inside the lambda isn't the - -- template x, so we must rename first! - ------------------------------------------- -match_tmpl_var :: RuleMatchEnv - -> RuleSubst - -> Var -- Template - -> CoreExpr -- Target - -> Maybe RuleSubst - -match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env }) - subst@(RS { rs_id_subst = id_subst, rs_bndrs = let_bndrs }) - v1' e2 - -- anyInRnEnvR is lazy in the 2nd arg which allows us to avoid computing fvs - -- if the right side of the env is empty. - | anyInRnEnvR rn_env (exprFreeVars e2) - = Nothing -- Skolem-escape failure - -- e.g. match forall a. (\x-> a x) against (\y. y y) - - | Just e1' <- lookupVarEnv id_subst v1' - = if eqCoreExpr e1' e2' - then Just subst - else Nothing - - | otherwise -- See Note [Matching variable types] - = do { subst' <- match_ty renv subst (idType v1') (exprType e2) - ; return (subst' { rs_id_subst = id_subst' }) } - where - -- e2' is the result of applying flt_env to e2 - e2' | null let_bndrs = e2 - | otherwise = substExpr flt_env e2 - - id_subst' = extendVarEnv (rs_id_subst subst) v1' e2' - -- No further renaming to do on e2', - -- because no free var of e2' is in the rnEnvR of the envt - ------------------------------------------- -match_ty :: RuleMatchEnv - -> RuleSubst - -> Type -- Template - -> Type -- Target - -> Maybe RuleSubst --- Matching Core types: use the matcher in GHC.Tc.Utils.TcType. --- Notice that we treat newtypes as opaque. For example, suppose --- we have a specialised version of a function at a newtype, say --- newtype T = MkT Int --- We only want to replace (f T) with f', not (f Int). - -match_ty renv subst ty1 ty2 - = do { tv_subst' - <- Unify.ruleMatchTyKiX (rv_tmpls renv) (rv_lcl renv) tv_subst ty1 ty2 - ; return (subst { rs_tv_subst = tv_subst' }) } - where - tv_subst = rs_tv_subst subst - -{- Note [Matching variable types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When matching x ~ e, where 'x' is a template variable, we must check that -x's type matches e's type, to establish (TypeInv). For example - forall (c::Char->Int) (x::Char). - f (c x) = "RULE FIRED" -We must not match on, say (f (pred (3::Int))). - -It's actually quite difficult to come up with an example that shows -you need type matching, esp since matching is left-to-right, so type -args get matched first. But it's possible (e.g. simplrun008) and this -is the Right Thing to do. - -An alternative would be to make (TypeInf) into a /pre-condition/. It -is threatened only by the App rule. So when matching an application -(e1 e2) ~ (d1 d2) would be to collect args of the application chain, -match the types of the head, then match arg-by-arg. - -However that alternative seems a bit more complicated. And by -matching types at variables we do one match_ty for each template -variable, rather than one for each application chain. Usually there are -fewer template variables, although for simple rules it could be the other -way around. - -Note [Expanding variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here is another Very Important rule: if the term being matched is a -variable, we expand it so long as its unfolding is "expandable". (Its -occurrence information is not necessarily up to date, so we don't use -it.) By "expandable" we mean a WHNF or a "constructor-like" application. -This is the key reason for "constructor-like" Ids. If we have - {-# NOINLINE [1] CONLIKE g #-} - {-# RULE f (g x) = h x #-} -then in the term - let v = g 3 in ....(f v).... -we want to make the rule fire, to replace (f v) with (h 3). - -Note [Do not expand locally-bound variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Do *not* expand locally-bound variables, else there's a worry that the -unfolding might mention variables that are themselves renamed. -Example - case x of y { (p,q) -> ...y... } -Don't expand 'y' to (p,q) because p,q might themselves have been -renamed. Essentially we only expand unfoldings that are "outside" -the entire match. - -Hence, (a) the guard (not (isLocallyBoundR v2)) - (b) when we expand we nuke the renaming envt (nukeRnEnvR). - -Note [Tick annotations in RULE matching] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We used to unconditionally look through ticks in both template and -expression being matched. This is actually illegal for counting or -cost-centre-scoped ticks, because we have no place to put them without -changing entry counts and/or costs. So now we just fail the match in -these cases. - -On the other hand, where we are allowed to insert new cost into the -tick scope, we can float them upwards to the rule application site. - -Moreover, we may encounter ticks in the template of a rule. There are a few -ways in which these may be introduced (e.g. #18162, #17619). Such ticks are -ignored by the matcher. See Note [Simplifying rules] in -GHC.Core.Opt.Simplify.Utils for details. - -cf Note [Tick annotations in call patterns] in GHC.Core.Opt.SpecConstr - - -Note [Matching lets] -~~~~~~~~~~~~~~~~~~~~ -Matching a let-expression. Consider - RULE forall x. f (g x) = <rhs> -and target expression - f (let { w=R } in g E)) -Then we'd like the rule to match, to generate - let { w=R } in (\x. <rhs>) E -In effect, we want to float the let-binding outward, to enable -the match to happen. This is the WHOLE REASON for accumulating -bindings in the RuleSubst - -We can only do this if the free variables of R are not bound by the -part of the target expression outside the let binding; e.g. - f (\v. let w = v+1 in g E) -Here we obviously cannot float the let-binding for w. Hence the -use of okToFloat. - -There are a couple of tricky points: - (a) What if floating the binding captures a variable that is - free in the entire expression? - f (let v = x+1 in v) v - --> NOT! - let v = x+1 in f (x+1) v - - (b) What if the let shadows a local binding? - f (\v -> (v, let v = x+1 in (v,v)) - --> NOT! - let v = x+1 in f (\v -> (v, (v,v))) - - (c) What if two non-nested let bindings bind the same variable? - f (let v = e1 in b1) (let v = e2 in b2) - --> NOT! - let v = e1 in let v = e2 in (f b2 b2) - See testsuite test `T4814`. - -Our cunning plan is this: - (1) Along with the growing substitution for template variables - we maintain a growing set of floated let-bindings (rs_binds) - plus the set of variables thus bound (rs_bndrs). - - (2) The RnEnv2 in the MatchEnv binds only the local binders - in the term (lambdas, case), not the floated let-bndrs. - - (3) When we encounter a `let` in the term to be matched, in the Let - case of `match`, we use `okToFloat` to check that it does not mention any - locally bound (lambda, case) variables. If so we fail. - - (4) In the Let case of `match`, we use GHC.Core.Subst.substBind to - freshen the binding (which, remember (3), mentions no locally - bound variables), in a lexically-scoped way (via rv_fltR in - MatchEnv). - - The subtle point is that we want an in-scope set for this - substitution that includes /two/ sets: - * The in-scope variables at this point, so that we avoid using - those local names for the floated binding; points (a) and (b) above. - * All "earlier" floated bindings, so that we avoid using the - same name for two different floated bindings; point (c) above. - - Because we have to compute the in-scope set here, the in-scope set - stored in `rv_fltR` is always ignored; we leave it only because it's - convenient to have `rv_fltR :: Subst` (with an always-ignored `InScopeSet`) - rather than storing three separate substitutions. - - (5) We apply that freshening substitution, in a lexically-scoped - way to the term, although lazily; this is the rv_fltR field. - -See #4814, which is an issue resulting from getting this wrong. - -Note [Matching cases] -~~~~~~~~~~~~~~~~~~~~~ -{- NOTE: This idea is currently disabled. It really only works if - the primops involved are OkForSpeculation, and, since - they have side effects readIntOfAddr and touch are not. - Maybe we'll get back to this later . -} - -Consider - f (case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) -> - case touch# fp s# of { _ -> - I# n# } } ) -This happened in a tight loop generated by stream fusion that -Roman encountered. We'd like to treat this just like the let -case, because the primops concerned are ok-for-speculation. -That is, we'd like to behave as if it had been - case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) -> - case touch# fp s# of { _ -> - f (I# n# } } ) - -Note [Lookup in-scope] -~~~~~~~~~~~~~~~~~~~~~~ -Consider this example - foo :: Int -> Maybe Int -> Int - foo 0 (Just n) = n - foo m (Just n) = foo (m-n) (Just n) - -SpecConstr sees this fragment: - - case w_smT of wild_Xf [Just A] { - Data.Maybe.Nothing -> lvl_smf; - Data.Maybe.Just n_acT [Just S(L)] -> - case n_acT of wild1_ams [Just A] { GHC.Base.I# y_amr [Just L] -> - $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf - }}; - -and correctly generates the rule - - RULES: "SC:$wfoo1" [0] __forall {y_amr [Just L] :: GHC.Prim.Int# - sc_snn :: GHC.Prim.Int#} - $wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr)) - = $s$wfoo_sno y_amr sc_snn ;] - -BUT we must ensure that this rule matches in the original function! -Note that the call to $wfoo is - $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf - -During matching we expand wild_Xf to (Just n_acT). But then we must also -expand n_acT to (I# y_amr). And we can only do that if we look up n_acT -in the in-scope set, because in wild_Xf's unfolding it won't have an unfolding -at all. - -That is why the 'lookupRnInScope' call in the (Var v2) case of 'match' -is so important. - - -************************************************************************ -* * - Rule-check the program -* * -************************************************************************ - - We want to know what sites have rules that could have fired but didn't. - This pass runs over the tree (without changing it) and reports such. --} - --- | Report partial matches for rules beginning with the specified --- string for the purposes of error reporting -ruleCheckProgram :: RuleOpts -- ^ Rule options - -> CompilerPhase -- ^ Rule activation test - -> String -- ^ Rule pattern - -> (Id -> [CoreRule]) -- ^ Rules for an Id - -> CoreProgram -- ^ Bindings to check in - -> SDoc -- ^ Resulting check message -ruleCheckProgram ropts phase rule_pat rules binds - | isEmptyBag results - = text "Rule check results: no rule application sites" - | otherwise - = vcat [text "Rule check results:", - line, - vcat [ p $$ line | p <- bagToList results ] - ] - where - env = RuleCheckEnv { rc_is_active = isActive phase - , rc_id_unf = idUnfolding -- Not quite right - -- Should use activeUnfolding - , rc_pattern = rule_pat - , rc_rules = rules - , rc_ropts = ropts - } - results = unionManyBags (map (ruleCheckBind env) binds) - line = text (replicate 20 '-') - -data RuleCheckEnv = RuleCheckEnv { - rc_is_active :: Activation -> Bool, - rc_id_unf :: IdUnfoldingFun, - rc_pattern :: String, - rc_rules :: Id -> [CoreRule], - rc_ropts :: RuleOpts -} - -ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc - -- The Bag returned has one SDoc for each call site found -ruleCheckBind env (NonRec _ r) = ruleCheck env r -ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (_,r) <- prs] - -ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc -ruleCheck _ (Var _) = emptyBag -ruleCheck _ (Lit _) = emptyBag -ruleCheck _ (Type _) = emptyBag -ruleCheck _ (Coercion _) = emptyBag -ruleCheck env (App f a) = ruleCheckApp env (App f a) [] -ruleCheck env (Tick _ e) = ruleCheck env e -ruleCheck env (Cast e _) = ruleCheck env e -ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e -ruleCheck env (Lam _ e) = ruleCheck env e -ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags` - unionManyBags [ruleCheck env r | Alt _ _ r <- as] - -ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc -ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as) -ruleCheckApp env (Var f) as = ruleCheckFun env f as -ruleCheckApp env other _ = ruleCheck env other - -ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc --- Produce a report for all rules matching the predicate --- saying why it doesn't match the specified application - -ruleCheckFun env fn args - | null name_match_rules = emptyBag - | otherwise = unitBag (ruleAppCheck_help env fn args name_match_rules) - where - name_match_rules = filter match (rc_rules env fn) - match rule = rc_pattern env `isPrefixOf` unpackFS (ruleName rule) - -ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc -ruleAppCheck_help env fn args rules - = -- The rules match the pattern, so we want to print something - vcat [text "Expression:" <+> ppr (mkApps (Var fn) args), - vcat (map check_rule rules)] - where - n_args = length args - i_args = args `zip` [1::Int ..] - rough_args = map roughTopName args - - check_rule rule = rule_herald rule <> colon <+> rule_info (rc_ropts env) rule - - rule_herald (BuiltinRule { ru_name = name }) - = text "Builtin rule" <+> doubleQuotes (ftext name) - rule_herald (Rule { ru_name = name }) - = text "Rule" <+> doubleQuotes (ftext name) - - rule_info opts rule - | Just _ <- matchRule opts (emptyInScopeSet, rc_id_unf env) - noBlackList fn args rough_args rule - = text "matches (which is very peculiar!)" - - rule_info _ (BuiltinRule {}) = text "does not match" - - rule_info _ (Rule { ru_act = act, - ru_bndrs = rule_bndrs, ru_args = rule_args}) - | not (rc_is_active env act) = text "active only in later phase" - | n_args < n_rule_args = text "too few arguments" - | n_mismatches == n_rule_args = text "no arguments match" - | n_mismatches == 0 = text "all arguments match (considered individually), but rule as a whole does not" - | otherwise = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)" - where - n_rule_args = length rule_args - n_mismatches = length mismatches - mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args, - not (isJust (match_fn rule_arg arg))] - - lhs_fvs = exprsFreeVars rule_args -- Includes template tyvars - match_fn rule_arg arg = match renv emptyRuleSubst rule_arg arg MRefl - where - in_scope = mkInScopeSet (lhs_fvs `unionVarSet` exprFreeVars arg) - renv = RV { rv_lcl = mkRnEnv2 in_scope - , rv_tmpls = mkVarSet rule_bndrs - , rv_fltR = mkEmptySubst in_scope - , rv_unf = rc_id_unf env } +-- | A 'CoreRule' is: +-- +-- * \"Local\" if the function it is a rule for is defined in the +-- same module as the rule itself. +-- +-- * \"Orphan\" if nothing on the LHS is defined in the same module +-- as the rule itself +data CoreRule + = Rule { + ru_name :: RuleName, -- ^ Name of the rule, for communication with the user + ru_act :: Activation, -- ^ When the rule is active + + -- Rough-matching stuff + -- see comments with InstEnv.ClsInst( is_cls, is_rough ) + ru_fn :: !Name, -- ^ Name of the 'GHC.Types.Id.Id' at the head of this rule + ru_rough :: [Maybe Name], -- ^ Name at the head of each argument to the left hand side + + -- Proper-matching stuff + -- see comments with InstEnv.ClsInst( is_tvs, is_tys ) + ru_bndrs :: [CoreBndr], -- ^ Variables quantified over + ru_args :: [CoreExpr], -- ^ Left hand side arguments + + -- And the right-hand side + ru_rhs :: CoreExpr, -- ^ Right hand side of the rule + -- Occurrence info is guaranteed correct + -- See Note [OccInfo in unfoldings and rules] + + -- Locality + ru_auto :: Bool, -- ^ @True@ <=> this rule is auto-generated + -- (notably by Specialise or SpecConstr) + -- @False@ <=> generated at the user's behest + -- See Note [Trimming auto-rules] in "GHC.Iface.Tidy" + -- for the sole purpose of this field. + + ru_origin :: !Module, -- ^ 'Module' the rule was defined in, used + -- to test if we should see an orphan rule. + + ru_orphan :: !IsOrphan, -- ^ Whether or not the rule is an orphan. + + ru_local :: Bool -- ^ @True@ iff the fn at the head of the rule is + -- defined in the same module as the rule + -- and is not an implicit 'Id' (like a record selector, + -- class operation, or data constructor). This + -- is different from 'ru_orphan', where a rule + -- can avoid being an orphan if *any* Name in + -- LHS of the rule was defined in the same + -- module as the rule. + } + + -- | Built-in rules are used for constant folding + -- and suchlike. They have no free variables. + -- A built-in rule is always visible (there is no such thing as + -- an orphan built-in rule.) + | BuiltinRule { + ru_name :: RuleName, -- ^ As above + ru_fn :: Name, -- ^ As above + ru_nargs :: Int, -- ^ Number of arguments that 'ru_try' consumes, + -- if it fires, including type arguments + ru_try :: RuleFun + -- ^ This function does the rewrite. It given too many + -- arguments, it simply discards them; the returned 'CoreExpr' + -- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args + } + -- See Note [Extra args in the target] in GHC.Core.Rules + +-- | The 'InScopeSet' in the 'InScopeEnv' is a /superset/ of variables that are +-- currently in scope. See Note [The InScopeSet invariant]. +type RuleFun = RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr +type InScopeEnv = (InScopeSet, IdUnfoldingFun) + +type IdUnfoldingFun = Id -> Unfolding +-- A function that embodies how to unfold an Id if you need +-- to do that in the Rule. The reason we need to pass this info in +-- is that whether an Id is unfoldable depends on the simplifier phase + +isBuiltinRule :: CoreRule -> Bool +isBuiltinRule (BuiltinRule {}) = True +isBuiltinRule _ = False + +isAutoRule :: CoreRule -> Bool +isAutoRule (BuiltinRule {}) = False +isAutoRule (Rule { ru_auto = is_auto }) = is_auto + +-- | The number of arguments the 'ru_fn' must be applied +-- to before the rule can match on it +ruleArity :: CoreRule -> Int +ruleArity (BuiltinRule {ru_nargs = n}) = n +ruleArity (Rule {ru_args = args}) = length args + +ruleName :: CoreRule -> RuleName +ruleName = ru_name + +ruleModule :: CoreRule -> Maybe Module +ruleModule Rule { ru_origin } = Just ru_origin +ruleModule BuiltinRule {} = Nothing + +ruleActivation :: CoreRule -> Activation +ruleActivation (BuiltinRule { }) = AlwaysActive +ruleActivation (Rule { ru_act = act }) = act + +-- | The 'Name' of the 'GHC.Types.Id.Id' at the head of the rule left hand side +ruleIdName :: CoreRule -> Name +ruleIdName = ru_fn + +isLocalRule :: CoreRule -> Bool +isLocalRule = ru_local + +-- | Set the 'Name' of the 'GHC.Types.Id.Id' at the head of the rule left hand side +setRuleIdName :: Name -> CoreRule -> CoreRule +setRuleIdName nm ru = ru { ru_fn = nm } diff --git a/compiler/GHC/Core/Rules/Apply.hs b/compiler/GHC/Core/Rules/Apply.hs new file mode 100644 index 0000000000..e2fff2b22e --- /dev/null +++ b/compiler/GHC/Core/Rules/Apply.hs @@ -0,0 +1,1718 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[CoreRules]{Rewrite rules} +-} + + +-- | Functions for collecting together and applying rewrite rules to a module. +-- The 'CoreRule' datatype itself is declared elsewhere. +module GHC.Core.Rules.Apply ( + -- ** Looking up rules + lookupRule, + + -- ** RuleBase, RuleEnv + RuleBase, RuleEnv(..), mkRuleEnv, emptyRuleEnv, + updExternalPackageRules, addLocalRules, updLocalRules, + emptyRuleBase, mkRuleBase, extendRuleBaseList, + pprRuleBase, + + -- ** Checking rule applications + ruleCheckProgram, + + -- ** Manipulating 'RuleInfo' rules + extendRuleInfo, addRuleInfo, + addIdSpecialisations, + + -- ** RuleBase and RuleEnv + + -- * Misc. CoreRule helpers + rulesOfBinds, getRules, pprRulesForUser, + + -- * Making rules + mkRule, mkSpecRule, roughTopNames + + ) where + +import GHC.Prelude + +import GHC.Unit.Module ( Module ) +import GHC.Unit.Module.Env +import GHC.Unit.Module.ModGuts( ModGuts(..) ) +import GHC.Unit.Module.Deps( Dependencies(..) ) + +import GHC.Driver.Session( DynFlags ) +import GHC.Driver.Ppr( showSDoc ) + +import GHC.Core -- All of it +import GHC.Core.Orphans +import GHC.Core.Rules +import GHC.Core.Unfoldings +import GHC.Core.Subst +import GHC.Core.SimpleOpt ( exprIsLambda_maybe ) +import GHC.Core.FVs ( exprFreeVars, exprsFreeVars, bindFreeVars + , rulesFreeVarsDSet, exprsOrphNames ) +import GHC.Core.Utils ( exprType, mkTick, mkTicks + , stripTicksTopT, stripTicksTopE + , isJoinBind, mkCastMCo ) +import GHC.Core.Ppr ( pprRules ) +import GHC.Core.Unify as Unify ( ruleMatchTyKiX ) +import GHC.Core.Type as Type + ( Type, extendTvSubst, extendCvSubst + , substTy, getTyVar_maybe ) +import GHC.Core.TyCo.Ppr( pprParendType ) +import GHC.Core.Coercion as Coercion +import GHC.Core.Tidy ( tidyRules ) +import GHC.Core.Map.Expr ( eqCoreExpr ) +import GHC.Core.Opt.Arity( etaExpandToJoinPointRule ) + +import GHC.Tc.Utils.TcType ( tcSplitTyConApp_maybe ) +import GHC.Builtin.Types ( anyTypeOfKind ) + +import GHC.Types.Id +import GHC.Types.Id.Info ( RuleInfo( RuleInfo ) ) +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Name ( Name, NamedThing(..), nameIsLocalOrFrom ) +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Types.Name.Occurrence( occNameFS ) +import GHC.Types.Unique.FM +import GHC.Types.Tickish +import GHC.Types.Basic + +import GHC.Data.FastString +import GHC.Data.Maybe +import GHC.Data.Bag + +import GHC.Utils.Misc as Utils +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Constants (debugIsOn) + +import Data.List (sortBy, mapAccumL, isPrefixOf) +import Data.Function ( on ) +import Control.Monad ( guard ) + +{- +Note [Overall plumbing for rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* After the desugarer: + - The ModGuts initially contains mg_rules :: [CoreRule] of + locally-declared rules for imported Ids. + - Locally-declared rules for locally-declared Ids are attached to + the IdInfo for that Id. See Note [Attach rules to local ids] in + GHC.HsToCore.Binds + +* GHC.Iface.Tidy strips off all the rules from local Ids and adds them to + mg_rules, so that the ModGuts has *all* the locally-declared rules. + +* The HomePackageTable contains a ModDetails for each home package + module. Each contains md_rules :: [CoreRule] of rules declared in + that module. The HomePackageTable grows as ghc --make does its + up-sweep. In batch mode (ghc -c), the HPT is empty; all imported modules + are treated by the "external" route, discussed next, regardless of + which package they come from. + +* The ExternalPackageState has a single eps_rule_base :: RuleBase for + Ids in other packages. This RuleBase simply grow monotonically, as + ghc --make compiles one module after another. + + During simplification, interface files may get demand-loaded, + as the simplifier explores the unfoldings for Ids it has in + its hand. (Via an unsafePerformIO; the EPS is really a cache.) + That in turn may make the EPS rule-base grow. In contrast, the + HPT never grows in this way. + +* The result of all this is that during Core-to-Core optimisation + there are four sources of rules: + + (a) Rules in the IdInfo of the Id they are a rule for. These are + easy: fast to look up, and if you apply a substitution then + it'll be applied to the IdInfo as a matter of course. + + (b) Rules declared in this module for imported Ids, kept in the + ModGuts. If you do a substitution, you'd better apply the + substitution to these. There are seldom many of these. + + (c) Rules declared in the HomePackageTable. These never change. + + (d) Rules in the ExternalPackageTable. These can grow in response + to lazy demand-loading of interfaces. + +* At the moment (c) is carried in a reader-monad way by the GHC.Core.Opt.Monad. + The HomePackageTable doesn't have a single RuleBase because technically + we should only be able to "see" rules "below" this module; so we + generate a RuleBase for (c) by combining rules from all the modules + "below" us. That's why we can't just select the home-package RuleBase + from HscEnv. + + [NB: we are inconsistent here. We should do the same for external + packages, but we don't. Same for type-class instances.] + +* So in the outer simplifier loop (simplifyPgmIO), we combine (b & c) into a single + RuleBase, reading + (b) from the ModGuts, + (c) from the GHC.Core.Opt.Monad, and + just before doing rule matching we read + (d) from its mutable variable + and combine it with the results from (b & c). + + In a single simplifier run new rules can be added into the EPS so it matters + to keep an up-to-date view of which rules have been loaded. For examples of + where this went wrong and caused cryptic performance regressions + see T19790 and !6735. + + +************************************************************************ +* * +\subsection[specialisation-IdInfo]{Specialisation info about an @Id@} +* * +************************************************************************ + +A CoreRule holds details of one rule for an Id, which +includes its specialisations. + +For example, if a rule for f is + RULE "f" forall @a @b d. f @(List a) @b d = f' a b + +then when we find an application of f to matching types, we simply replace +it by the matching RHS: + f (List Int) Bool dict ===> f' Int Bool +All the stuff about how many dictionaries to discard, and what types +to apply the specialised function to, are handled by the fact that the +Rule contains a template for the result of the specialisation. +-} + +mkRule :: Module -> Bool -> Bool -> RuleName -> Activation + -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule +-- ^ Used to make 'CoreRule' for an 'Id' defined in the module being +-- compiled. See also 'GHC.Core.CoreRule' +mkRule this_mod is_auto is_local name act fn bndrs args rhs + = Rule { ru_name = name, ru_fn = fn, ru_act = act, + ru_bndrs = bndrs, ru_args = args, + ru_rhs = rhs, + ru_rough = roughTopNames args, + ru_origin = this_mod, + ru_orphan = orph, + ru_auto = is_auto, ru_local = is_local } + where + -- Compute orphanhood. See Note [Orphans] in GHC.Core.InstEnv + -- A rule is an orphan only if none of the variables + -- mentioned on its left-hand side are locally defined + lhs_names = extendNameSet (exprsOrphNames args) fn + + -- Since rules get eventually attached to one of the free names + -- from the definition when compiling the ABI hash, we should make + -- it deterministic. This chooses the one with minimal OccName + -- as opposed to uniq value. + local_lhs_names = filterNameSet (nameIsLocalOrFrom this_mod) lhs_names + orph = chooseOrphanAnchor local_lhs_names + +-------------- +mkSpecRule :: DynFlags -> Module -> Bool -> Activation -> SDoc + -> Id -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule +-- Make a specialisation rule, for Specialise or SpecConstr +mkSpecRule dflags this_mod is_auto inl_act herald fn bndrs args rhs + = case isJoinId_maybe fn of + Just join_arity -> etaExpandToJoinPointRule join_arity rule + Nothing -> rule + where + rule = mkRule this_mod is_auto is_local + rule_name + inl_act -- Note [Auto-specialisation and RULES] + (idName fn) + bndrs args rhs + + is_local = isLocalId fn + rule_name = mkSpecRuleName dflags herald fn args + +mkSpecRuleName :: DynFlags -> SDoc -> Id -> [CoreExpr] -> FastString +mkSpecRuleName dflags herald fn args + = mkFastString $ showSDoc dflags $ + herald <+> ftext (occNameFS (getOccName fn)) + -- This name ends up in interface files, so use occNameFS. + -- Otherwise uniques end up there, making builds + -- less deterministic (See #4012 comment:61 ff) + <+> hsep (mapMaybe ppr_call_key_ty args) + where + ppr_call_key_ty :: CoreExpr -> Maybe SDoc + ppr_call_key_ty (Type ty) = case getTyVar_maybe ty of + Just {} -> Just (text "@_") + Nothing -> Just $ char '@' <> pprParendType ty + ppr_call_key_ty _ = Nothing + + +-------------- +roughTopNames :: [CoreExpr] -> [Maybe Name] +-- ^ Find the \"top\" free names of several expressions. +-- Such names are either: +-- +-- 1. The function finally being applied to in an application chain +-- (if that name is a GlobalId: see "GHC.Types.Var#globalvslocal"), or +-- +-- 2. The 'TyCon' if the expression is a 'Type' +-- +-- This is used for the fast-match-check for rules; +-- if the top names don't match, the rest can't +roughTopNames args = map roughTopName args + +roughTopName :: CoreExpr -> Maybe Name +roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of + Just (tc,_) -> Just (getName tc) + Nothing -> Nothing +roughTopName (Coercion _) = Nothing +roughTopName (App f _) = roughTopName f +roughTopName (Var f) | isGlobalId f -- Note [Care with roughTopName] + , isDataConWorkId f || idArity f > 0 + = Just (idName f) +roughTopName (Tick t e) | tickishFloatable t + = roughTopName e +roughTopName _ = Nothing + +ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool +-- ^ @ruleCantMatch tpl actual@ returns True only if @actual@ +-- definitely can't match @tpl@ by instantiating @tpl@. +-- It's only a one-way match; unlike instance matching we +-- don't consider unification. +-- +-- Notice that [_$_] +-- @ruleCantMatch [Nothing] [Just n2] = False@ +-- Reason: a template variable can be instantiated by a constant +-- Also: +-- @ruleCantMatch [Just n1] [Nothing] = False@ +-- Reason: a local variable @v@ in the actuals might [_$_] + +ruleCantMatch (Just n1 : ts) (Just n2 : as) = n1 /= n2 || ruleCantMatch ts as +ruleCantMatch (_ : ts) (_ : as) = ruleCantMatch ts as +ruleCantMatch _ _ = False + +{- +Note [Care with roughTopName] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + module M where { x = a:b } + module N where { ...f x... + RULE f (p:q) = ... } +You'd expect the rule to match, because the matcher can +look through the unfolding of 'x'. So we must avoid roughTopName +returning 'M.x' for the call (f x), or else it'll say "can't match" +and we won't even try!! + +However, suppose we have + RULE g (M.h x) = ... + foo = ...(g (M.k v)).... +where k is a *function* exported by M. We never really match +functions (lambdas) except by name, so in this case it seems like +a good idea to treat 'M.k' as a roughTopName of the call. +-} + +pprRulesForUser :: [CoreRule] -> SDoc +-- (a) tidy the rules +-- (b) sort them into order based on the rule name +-- (c) suppress uniques (unless -dppr-debug is on) +-- This combination makes the output stable so we can use in testing +-- It's here rather than in GHC.Core.Ppr because it calls tidyRules +pprRulesForUser rules + = withPprStyle defaultUserStyle $ + pprRules $ + sortBy (lexicalCompareFS `on` ruleName) $ + tidyRules emptyTidyEnv rules + +{- +************************************************************************ +* * + RuleInfo: the rules in an IdInfo +* * +************************************************************************ +-} + +extendRuleInfo :: RuleInfo -> [CoreRule] -> RuleInfo +extendRuleInfo (RuleInfo rs1 fvs1) rs2 + = RuleInfo (rs2 ++ rs1) (rulesFreeVarsDSet rs2 `unionDVarSet` fvs1) + +addRuleInfo :: RuleInfo -> RuleInfo -> RuleInfo +addRuleInfo (RuleInfo rs1 fvs1) (RuleInfo rs2 fvs2) + = RuleInfo (rs1 ++ rs2) (fvs1 `unionDVarSet` fvs2) + +addIdSpecialisations :: Id -> [CoreRule] -> Id +addIdSpecialisations id rules + | null rules + = id + | otherwise + = setIdSpecialisation id $ + extendRuleInfo (idSpecialisation id) rules + +-- | Gather all the rules for locally bound identifiers from the supplied bindings +rulesOfBinds :: [CoreBind] -> [CoreRule] +rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds + + +{- +************************************************************************ +* * + RuleBase +* * +************************************************************************ +-} + +-- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules +type RuleBase = NameEnv [CoreRule] + -- The rules are unordered; + -- we sort out any overlaps on lookup + +emptyRuleBase :: RuleBase +emptyRuleBase = emptyNameEnv + +mkRuleBase :: [CoreRule] -> RuleBase +mkRuleBase rules = extendRuleBaseList emptyRuleBase rules + +extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase +extendRuleBaseList rule_base new_guys + = foldl' extendRuleBase rule_base new_guys + +extendRuleBase :: RuleBase -> CoreRule -> RuleBase +extendRuleBase rule_base rule + = extendNameEnv_Acc (:) Utils.singleton rule_base (ruleIdName rule) rule + +pprRuleBase :: RuleBase -> SDoc +pprRuleBase rules = pprUFM rules $ \rss -> + vcat [ pprRules (tidyRules emptyTidyEnv rs) + | rs <- rss ] + +-- | A full rule environment which we can apply rules from. Like a 'RuleBase', +-- but it also includes the set of visible orphans we use to filter out orphan +-- rules which are not visible (even though we can see them...) +-- See Note [Orphans] in GHC.Core +data RuleEnv + = RuleEnv { re_local_rules :: !RuleBase -- Rules from this module + , re_home_rules :: !RuleBase -- Rule from the home package + -- (excl this module) + , re_eps_rules :: !RuleBase -- Rules from other packages + -- see Note [External package rules] + , re_visible_orphs :: !ModuleSet + } + +mkRuleEnv :: ModGuts -> RuleBase -> RuleBase -> RuleEnv +mkRuleEnv (ModGuts { mg_module = this_mod + , mg_deps = deps + , mg_rules = local_rules }) + eps_rules hpt_rules + = RuleEnv { re_local_rules = mkRuleBase local_rules + , re_home_rules = hpt_rules + , re_eps_rules = eps_rules + , re_visible_orphs = mkModuleSet vis_orphs } + where + vis_orphs = this_mod : dep_orphs deps + +updExternalPackageRules :: RuleEnv -> RuleBase -> RuleEnv +-- Completely over-ride the external rules in RuleEnv +updExternalPackageRules rule_env eps_rules + = rule_env { re_eps_rules = eps_rules } + +updLocalRules :: RuleEnv -> [CoreRule] -> RuleEnv +-- Completely over-ride the local rules in RuleEnv +updLocalRules rule_env local_rules + = rule_env { re_local_rules = mkRuleBase local_rules } + +addLocalRules :: RuleEnv -> [CoreRule] -> RuleEnv +-- Add new local rules +addLocalRules rule_env rules + = rule_env { re_local_rules = extendRuleBaseList (re_local_rules rule_env) rules } + +emptyRuleEnv :: RuleEnv +emptyRuleEnv = RuleEnv { re_local_rules = emptyNameEnv + , re_home_rules = emptyNameEnv + , re_eps_rules = emptyNameEnv + , re_visible_orphs = emptyModuleSet } + +getRules :: RuleEnv -> Id -> [CoreRule] +-- Given a RuleEnv and an Id, find the visible rules for that Id +-- See Note [Where rules are found] +getRules (RuleEnv { re_local_rules = local_rules + , re_home_rules = home_rules + , re_eps_rules = eps_rules + , re_visible_orphs = orphs }) fn + + | Just {} <- isDataConId_maybe fn -- Short cut for data constructor workers + = [] -- and wrappers, which never have any rules + + | otherwise + = idCoreRules fn ++ + get local_rules ++ + find_visible home_rules ++ + find_visible eps_rules + + where + fn_name = idName fn + find_visible rb = filter (ruleIsVisible orphs) (get rb) + get rb = lookupNameEnv rb fn_name `orElse` [] + +ruleIsVisible :: ModuleSet -> CoreRule -> Bool +ruleIsVisible _ BuiltinRule{} = True +ruleIsVisible vis_orphs Rule { ru_orphan = orph, ru_origin = origin } + = notOrphan orph || origin `elemModuleSet` vis_orphs + +{- Note [Where rules are found] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The rules for an Id come from two places: + (a) the ones it is born with, stored inside the Id itself (idCoreRules fn), + (b) rules added in other modules, stored in the global RuleBase (imp_rules) + +It's tempting to think that + - LocalIds have only (a) + - non-LocalIds have only (b) + +but that isn't quite right: + + - PrimOps and ClassOps are born with a bunch of rules inside the Id, + even when they are imported + + - The rules in GHC.Core.Opt.ConstantFold.builtinRules should be active even + in the module defining the Id (when it's a LocalId), but + the rules are kept in the global RuleBase + + Note [External package rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Note [Overall plumbing for rules], it is explained that the final +RuleBase which we must consider is combined from 4 different sources. + +During simplifier runs, the fourth source of rules is constantly being updated +as new interfaces are loaded into the EPS. Therefore just before we check to see +if any rules match we get the EPS RuleBase and combine it with the existing RuleBase +and then perform exactly 1 lookup into the new map. + +It is more efficient to avoid combining the environments and store the uncombined +environments as we can instead perform 1 lookup into each environment and then combine +the results. + +Essentially we use the identity: + +> lookupNameEnv n (plusNameEnv_C (++) rb1 rb2) +> = lookupNameEnv n rb1 ++ lookupNameEnv n rb2 + +The latter being more efficient as we don't construct an intermediate +map. +-} + +{- +************************************************************************ +* * + Matching +* * +************************************************************************ +-} + +-- | The main rule matching function. Attempts to apply all (active) +-- supplied rules to this instance of an application in a given +-- context, returning the rule applied and the resulting expression if +-- successful. +lookupRule :: RuleOpts -> InScopeEnv + -> (Activation -> Bool) -- When rule is active + -> Id -- Function head + -> [CoreExpr] -- Args + -> [CoreRule] -- Rules + -> Maybe (CoreRule, CoreExpr) + +-- See Note [Extra args in the target] +-- See comments on matchRule +lookupRule opts rule_env@(in_scope,_) is_active fn args rules + = -- pprTrace "lookupRule" (ppr fn <+> ppr args $$ ppr rules $$ ppr in_scope) $ + case go [] rules of + [] -> Nothing + (m:ms) -> Just (findBest in_scope (fn,args') m ms) + where + rough_args = map roughTopName args + + -- Strip ticks from arguments, see Note [Tick annotations in RULE + -- matching]. We only collect ticks if a rule actually matches - + -- this matters for performance tests. + args' = map (stripTicksTopE tickishFloatable) args + ticks = concatMap (stripTicksTopT tickishFloatable) args + + go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)] + go ms [] = ms + go ms (r:rs) + | Just e <- matchRule opts rule_env is_active fn args' rough_args r + = go ((r,mkTicks ticks e):ms) rs + | otherwise + = -- pprTrace "match failed" (ppr r $$ ppr args $$ + -- ppr [ (arg_id, unfoldingTemplate unf) + -- | Var arg_id <- args + -- , let unf = idUnfolding arg_id + -- , isCheapUnfolding unf] ) + go ms rs + +findBest :: InScopeSet -> (Id, [CoreExpr]) + -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr) +-- All these pairs matched the expression +-- Return the pair the most specific rule +-- The (fn,args) is just for overlap reporting + +findBest _ _ (rule,ans) [] = (rule,ans) +findBest in_scope target (rule1,ans1) ((rule2,ans2):prs) + | isMoreSpecific in_scope rule1 rule2 = findBest in_scope target (rule1,ans1) prs + | isMoreSpecific in_scope rule2 rule1 = findBest in_scope target (rule2,ans2) prs + | debugIsOn = let pp_rule rule + = ifPprDebug (ppr rule) + (doubleQuotes (ftext (ruleName rule))) + in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)" + (vcat [ whenPprDebug $ + text "Expression to match:" <+> ppr fn + <+> sep (map ppr args) + , text "Rule 1:" <+> pp_rule rule1 + , text "Rule 2:" <+> pp_rule rule2]) $ + findBest in_scope target (rule1,ans1) prs + | otherwise = findBest in_scope target (rule1,ans1) prs + where + (fn,args) = target + +isMoreSpecific :: InScopeSet -> CoreRule -> CoreRule -> Bool +-- The call (rule1 `isMoreSpecific` rule2) +-- sees if rule2 can be instantiated to look like rule1 +-- See Note [isMoreSpecific] +isMoreSpecific _ (BuiltinRule {}) _ = False +isMoreSpecific _ (Rule {}) (BuiltinRule {}) = True +isMoreSpecific in_scope (Rule { ru_bndrs = bndrs1, ru_args = args1 }) + (Rule { ru_bndrs = bndrs2, ru_args = args2 + , ru_name = rule_name2, ru_rhs = rhs2 }) + = isJust (matchN (full_in_scope, id_unfolding_fun) + rule_name2 bndrs2 args2 args1 rhs2) + where + id_unfolding_fun _ = NoUnfolding -- Don't expand in templates + full_in_scope = in_scope `extendInScopeSetList` bndrs1 + +noBlackList :: Activation -> Bool +noBlackList _ = False -- Nothing is black listed + +{- Note [isMoreSpecific] +~~~~~~~~~~~~~~~~~~~~~~~~ +The call (rule1 `isMoreSpecific` rule2) +sees if rule2 can be instantiated to look like rule1. + +Wrinkle: + +* We take the view that a BuiltinRule is less specific than + anything else, because we want user-defined rules to "win" + In particular, class ops have a built-in rule, but we + prefer any user-specific rules to win: + eg (#4397) + truncate :: (RealFrac a, Integral b) => a -> b + {-# RULES "truncate/Double->Int" truncate = double2Int #-} + double2Int :: Double -> Int + We want the specific RULE to beat the built-in class-op rule + +Note [Extra args in the target] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we find a matching rule, we return (Just (rule, rhs)), +/but/ the rule firing has only consumed as many of the input args +as the ruleArity says. The unused arguments are handled by the code in +GHC.Core.Opt.Simplify.tryRules, using the arity of the returned rule. + +E.g. Rule "foo": forall a b. f p1 p2 = rhs + Target: f e1 e2 e3 + +Then lookupRule returns Just (Rule "foo", rhs), where Rule "foo" +has ruleArity 2. The real rewrite is + f e1 e2 e3 ==> rhs e3 + +You might think it'd be cleaner for lookupRule to deal with the +leftover arguments, by applying 'rhs' to them, but the main call +in the Simplifier works better as it is. Reason: the 'args' passed +to lookupRule are the result of a lazy substitution + +Historical note: + +At one stage I tried to match even if there are more args in the +/template/ than the target. I now think this is probably a bad idea. +Should the template (map f xs) match (map g)? I think not. For a +start, in general eta expansion wastes work. SLPJ July 99 +-} + +------------------------------------ +matchRule :: RuleOpts -> InScopeEnv -> (Activation -> Bool) + -> Id -> [CoreExpr] -> [Maybe Name] + -> CoreRule -> Maybe CoreExpr + +-- If (matchRule rule args) returns Just (name,rhs) +-- then (f args) matches the rule, and the corresponding +-- rewritten RHS is rhs +-- +-- The returned expression is occurrence-analysed +-- +-- Example +-- +-- The rule +-- forall f g x. map f (map g x) ==> map (f . g) x +-- is stored +-- CoreRule "map/map" +-- [f,g,x] -- tpl_vars +-- [f,map g x] -- tpl_args +-- map (f.g) x) -- rhs +-- +-- Then the expression +-- map e1 (map e2 e3) e4 +-- results in a call to +-- matchRule the_rule [e1,map e2 e3,e4] +-- = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3) +-- +-- NB: The 'surplus' argument e4 in the input is simply dropped. +-- See Note [Extra args in the target] + +matchRule opts rule_env _is_active fn args _rough_args + (BuiltinRule { ru_try = match_fn }) +-- Built-in rules can't be switched off, it seems + = case match_fn opts rule_env fn args of + Nothing -> Nothing + Just expr -> Just expr + +matchRule _ rule_env is_active _ args rough_args + (Rule { ru_name = rule_name, ru_act = act, ru_rough = tpl_tops + , ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs }) + | not (is_active act) = Nothing + | ruleCantMatch tpl_tops rough_args = Nothing + | otherwise = matchN rule_env rule_name tpl_vars tpl_args args rhs + + +--------------------------------------- +matchN :: InScopeEnv + -> RuleName -> [Var] -> [CoreExpr] + -> [CoreExpr] -> CoreExpr -- ^ Target; can have more elements than the template + -> Maybe CoreExpr +-- For a given match template and context, find bindings to wrap around +-- the entire result and what should be substituted for each template variable. +-- +-- Fail if there are too few actual arguments from the target to match the template +-- +-- See Note [Extra args in the target] +-- If there are too /many/ actual arguments, we simply ignore the +-- trailing ones, returning the result of applying the rule to a prefix +-- of the actual arguments. + +matchN (in_scope, id_unf) rule_name tmpl_vars tmpl_es target_es rhs + = do { rule_subst <- match_exprs init_menv emptyRuleSubst tmpl_es target_es + ; let (_, matched_es) = mapAccumL (lookup_tmpl rule_subst) + (mkEmptySubst in_scope) $ + tmpl_vars `zip` tmpl_vars1 + bind_wrapper = rs_binds rule_subst + -- Floated bindings; see Note [Matching lets] + ; return (bind_wrapper $ + mkLams tmpl_vars rhs `mkApps` matched_es) } + where + (init_rn_env, tmpl_vars1) = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars + -- See Note [Cloning the template binders] + + init_menv = RV { rv_tmpls = mkVarSet tmpl_vars1 + , rv_lcl = init_rn_env + , rv_fltR = mkEmptySubst (rnInScopeSet init_rn_env) + , rv_unf = id_unf } + + lookup_tmpl :: RuleSubst -> Subst -> (InVar,OutVar) -> (Subst, CoreExpr) + -- Need to return a RuleSubst solely for the benefit of mk_fake_ty + lookup_tmpl (RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst }) + tcv_subst (tmpl_var, tmpl_var1) + | isId tmpl_var1 + = case lookupVarEnv id_subst tmpl_var1 of + Just e | Coercion co <- e + -> (Type.extendCvSubst tcv_subst tmpl_var1 co, Coercion co) + | otherwise + -> (tcv_subst, e) + Nothing | Just refl_co <- isReflCoVar_maybe tmpl_var1 + , let co = Coercion.substCo tcv_subst refl_co + -> -- See Note [Unbound RULE binders] + (Type.extendCvSubst tcv_subst tmpl_var1 co, Coercion co) + | otherwise + -> unbound tmpl_var + + | otherwise + = (Type.extendTvSubst tcv_subst tmpl_var1 ty', Type ty') + where + ty' = case lookupVarEnv tv_subst tmpl_var1 of + Just ty -> ty + Nothing -> fake_ty -- See Note [Unbound RULE binders] + fake_ty = anyTypeOfKind (Type.substTy tcv_subst (tyVarKind tmpl_var1)) + -- This substitution is the sole reason we accumulate + -- TCvSubst in lookup_tmpl + + unbound tmpl_var + = pprPanic "Template variable unbound in rewrite rule" $ + vcat [ text "Variable:" <+> ppr tmpl_var <+> dcolon <+> ppr (varType tmpl_var) + , text "Rule" <+> pprRuleName rule_name + , text "Rule bndrs:" <+> ppr tmpl_vars + , text "LHS args:" <+> ppr tmpl_es + , text "Actual args:" <+> ppr target_es ] + +---------------------- +match_exprs :: RuleMatchEnv -> RuleSubst + -> [CoreExpr] -- Templates + -> [CoreExpr] -- Targets + -> Maybe RuleSubst +-- If the targets are longer than templates, succeed, simply ignoring +-- the leftover targets. This matters in the call in matchN. +-- +-- Precondition: corresponding elements of es1 and es2 have the same +-- type, assuming earlier elements match. +-- Example: f :: forall v. v -> blah +-- match_exprs [Type a, y::a] [Type Int, 3] +-- Then, after matching Type a against Type Int, +-- the type of (y::a) matches that of (3::Int) +match_exprs _ subst [] _ + = Just subst +match_exprs renv subst (e1:es1) (e2:es2) + = do { subst' <- match renv subst e1 e2 MRefl + ; match_exprs renv subst' es1 es2 } +match_exprs _ _ _ _ = Nothing + + +{- Note [Unbound RULE binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It can be the case that the binder in a rule is not actually +bound on the LHS: + +* Type variables. Type synonyms with phantom args can give rise to + unbound template type variables. Consider this (#10689, + simplCore/should_compile/T10689): + + type Foo a b = b + + f :: Eq a => a -> Bool + f x = x==x + + {-# RULES "foo" forall (x :: Foo a Char). f x = True #-} + finkle = f 'c' + + The rule looks like + forall (a::*) (d::Eq Char) (x :: Foo a Char). + f (Foo a Char) d x = True + + Matching the rule won't bind 'a', and legitimately so. We fudge by + pretending that 'a' is bound to (Any :: *). + +* Coercion variables. On the LHS of a RULE for a local binder + we might have + RULE forall (c :: a~b). f (x |> c) = e + Now, if that binding is inlined, so that a=b=Int, we'd get + RULE forall (c :: Int~Int). f (x |> c) = e + and now when we simplify the LHS (Simplify.simplRule) we + optCoercion (look at the CoVarCo case) will turn that 'c' into Refl: + RULE forall (c :: Int~Int). f (x |> <Int>) = e + and then perhaps drop it altogether. Now 'c' is unbound. + + It's tricky to be sure this never happens, so instead I + say it's OK to have an unbound coercion binder in a RULE + provided its type is (c :: t~t). Then, when the RULE + fires we can substitute <t> for c. + + This actually happened (in a RULE for a local function) + in #13410, and also in test T10602. + +Note [Cloning the template binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following match (example 1): + Template: forall x. f x + Target: f (x+1) +This should succeed, because the template variable 'x' has nothing to +do with the 'x' in the target. + +Likewise this one (example 2): + Template: forall x. f (\x.x) + Target: f (\y.y) + +We achieve this simply by using rnBndrL to clone the template +binders if they are already in scope. + +------ Historical note ------- +At one point I tried simply adding the template binders to the +in-scope set /without/ cloning them, but that failed in a horribly +obscure way in #14777. Problem was that during matching we look +up target-term variables in the in-scope set (see Note [Lookup +in-scope]). If a target-term variable happens to name-clash with a +template variable, that lookup will find the template variable, which +is /utterly/ bogus. In #14777, this transformed a term variable +into a type variable, and then crashed when we wanted its idInfo. +------ End of historical note ------- + + +************************************************************************ +* * + The main matcher +* * +********************************************************************* -} + +data RuleMatchEnv + = RV { rv_lcl :: RnEnv2 -- Renamings for *local bindings* + -- (lambda/case) + , rv_tmpls :: VarSet -- Template variables + -- (after applying envL of rv_lcl) + , rv_fltR :: Subst -- Renamings for floated let-bindings + -- (domain disjoint from envR of rv_lcl) + -- See Note [Matching lets] + -- N.B. The InScopeSet of rv_fltR is always ignored; + -- see (4) in Note [Matching lets]. + , rv_unf :: IdUnfoldingFun + } + +{- Note [rv_lcl in RuleMatchEnv] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider matching + Template: \x->f + Target: \f->f + +where 'f' is free in the template. When we meet the lambdas we must +remember to rename f :-> f' in the target, as well as x :-> f +in the template. The rv_lcl::RnEnv2 does that. + +Similarly, consider matching + Template: {a} \b->b + Target: \a->3 +We must rename the \a. Otherwise when we meet the lambdas we might +substitute [b :-> a] in the template, and then erroneously succeed in +matching what looks like the template variable 'a' against 3. + +So we must add the template vars to the in-scope set before starting; +see `init_menv` in `matchN`. +-} + +rvInScopeEnv :: RuleMatchEnv -> InScopeEnv +rvInScopeEnv renv = (rnInScopeSet (rv_lcl renv), rv_unf renv) + +-- * The domain of the TvSubstEnv and IdSubstEnv are the template +-- variables passed into the match. +-- +-- * The BindWrapper in a RuleSubst are the bindings floated out +-- from nested matches; see the Let case of match, below +-- +data RuleSubst = RS { rs_tv_subst :: TvSubstEnv -- Range is the + , rs_id_subst :: IdSubstEnv -- template variables + , rs_binds :: BindWrapper -- Floated bindings + , rs_bndrs :: [Var] -- Variables bound by floated lets + } + +type BindWrapper = CoreExpr -> CoreExpr + -- See Notes [Matching lets] and [Matching cases] + -- we represent the floated bindings as a core-to-core function + +emptyRuleSubst :: RuleSubst +emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv + , rs_binds = \e -> e, rs_bndrs = [] } + + +{- Note [Casts in the target] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As far as possible we don't want casts in the target to get in the way of +matching. E.g. +* (let bind in e) |> co +* (case e of alts) |> co +* (\ a b. f a b) |> co + +In the first two cases we want to float the cast inwards so we can match on +the let/case. This is not important in practice because the Simplifier does +this anyway. + +But the third case /is/ important: we don't want the cast to get in the way +of eta-reduction. See Note [Cancel reflexive casts] for a real life example. + +The most convenient thing is to make 'match' take an MCoercion argument, thus: + +* The main matching function + match env subst template target mco + matches template ~ (target |> mco) + +* Invariant: typeof( subst(template) ) = typeof( target |> mco ) + +Note that for applications + (e1 e2) ~ (d1 d2) |> co +where 'co' is non-reflexive, we simply fail. You might wonder about + (e1 e2) ~ ((d1 |> co1) d2) |> co2 +but the Simplifer pushes the casts in an application to to the +right, if it can, so this doesn't really arise. + +Note [Coercion arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~ +What if we have (f co) in the template, where the 'co' is a coercion +argument to f? Right now we have nothing in place to ensure that a +coercion /argument/ in the template is a variable. We really should, +perhaps by abstracting over that variable. + +C.f. the treatment of dictionaries in GHC.HsToCore.Binds.decompseRuleLhs. + +For now, though, we simply behave badly, by failing in match_co. +We really should never rely on matching the structure of a coercion +(which is just a proof). + +Note [Casts in the template] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the definition + f x = e, +and SpecConstr on call pattern + f ((e1,e2) |> co) + +We'll make a RULE + RULE forall a,b,g. f ((a,b)|> g) = $sf a b g + $sf a b g = e[ ((a,b)|> g) / x ] + +So here is the invariant: + + In the template, in a cast (e |> co), + the cast `co` is always a /variable/. + +Matching should bind that variable to an actual coercion, so that we +can use it in $sf. So a Cast on the LHS (the template) calls +match_co, which succeeds when the template cast is a variable -- which +it always is. That is why match_co has so few cases. + +See also +* Note [Coercion arguments] +* Note [Matching coercion variables] in GHC.Core.Unify. +* Note [Cast swizzling on rule LHSs] in GHC.Core.Opt.Simplify.Utils: + sm_cast_swizzle is switched off in the template of a RULE +-} + +---------------------- +match :: RuleMatchEnv + -> RuleSubst -- Substitution applies to template only + -> CoreExpr -- Template + -> CoreExpr -- Target + -> MCoercion + -> Maybe RuleSubst + +-- Postcondition (TypeInv): if matching succeeds, then +-- typeof( subst(template) ) = typeof( target |> mco ) +-- But this is /not/ a pre-condition! The types of template and target +-- may differ, see the (App e1 e2) case +-- +-- Invariant (CoInv): if mco :: ty ~ ty, then it is MRefl, not MCo co +-- See Note [Cancel reflexive casts] +-- +-- See the notes with Unify.match, which matches types +-- Everything is very similar for terms + + +------------------------ Ticks --------------------- +-- We look through certain ticks. See Note [Tick annotations in RULE matching] +match renv subst e1 (Tick t e2) mco + | tickishFloatable t + = match renv subst' e1 e2 mco + | otherwise + = Nothing + where + subst' = subst { rs_binds = rs_binds subst . mkTick t } + +match renv subst e@(Tick t e1) e2 mco + | tickishFloatable t -- Ignore floatable ticks in rule template. + = match renv subst e1 e2 mco + | otherwise + = pprPanic "Tick in rule" (ppr e) + +------------------------ Types --------------------- +match renv subst (Type ty1) (Type ty2) _mco + = match_ty renv subst ty1 ty2 + +------------------------ Coercions --------------------- +-- See Note [Coercion arguments] for why this isn't really right +match renv subst (Coercion co1) (Coercion co2) MRefl + = match_co renv subst co1 co2 + -- The MCo case corresponds to matching co ~ (co2 |> co3) + -- and I have no idea what to do there -- or even if it can occur + -- Failing seems the simplest thing to do; it's certainly safe. + +------------------------ Casts --------------------- +-- See Note [Casts in the template] +-- Note [Casts in the target] +-- Note [Cancel reflexive casts] + +match renv subst e1 (Cast e2 co2) mco + = match renv subst e1 e2 (checkReflexiveMCo (mkTransMCoR co2 mco)) + -- checkReflexiveMCo: cancel casts if possible + -- This is important: see Note [Cancel reflexive casts] + +match renv subst (Cast e1 co1) e2 mco + = -- See Note [Casts in the template] + do { let co2 = case mco of + MRefl -> mkRepReflCo (exprType e2) + MCo co2 -> co2 + ; subst1 <- match_co renv subst co1 co2 + -- If match_co succeeds, then (exprType e1) = (exprType e2) + -- Hence the MRefl in the next line + ; match renv subst1 e1 e2 MRefl } + +------------------------ Literals --------------------- +match _ subst (Lit lit1) (Lit lit2) mco + | lit1 == lit2 + = assertPpr (isReflMCo mco) (ppr mco) $ + Just subst + +------------------------ Variables --------------------- +-- The Var case follows closely what happens in GHC.Core.Unify.match +match renv subst (Var v1) e2 mco + = match_var renv subst v1 (mkCastMCo e2 mco) + +match renv subst e1 (Var v2) mco -- Note [Expanding variables] + | not (inRnEnvR rn_env v2) -- Note [Do not expand locally-bound variables] + , Just e2' <- expandUnfolding_maybe (rv_unf renv v2') + = match (renv { rv_lcl = nukeRnEnvR rn_env }) subst e1 e2' mco + where + v2' = lookupRnInScope rn_env v2 + rn_env = rv_lcl renv + -- Notice that we look up v2 in the in-scope set + -- See Note [Lookup in-scope] + -- No need to apply any renaming first (hence no rnOccR) + -- because of the not-inRnEnvR + +------------------------ Applications --------------------- +-- Note the match on MRefl! We fail if there is a cast in the target +-- (e1 e2) ~ (d1 d2) |> co +-- See Note [Cancel reflexive casts]: in the Cast equations for 'match' +-- we aggressively ensure that if MCo is reflective, it really is MRefl. +match renv subst (App f1 a1) (App f2 a2) MRefl + = do { subst' <- match renv subst f1 f2 MRefl + ; match renv subst' a1 a2 MRefl } + +------------------------ Float lets --------------------- +match renv subst e1 (Let bind e2) mco + | -- pprTrace "match:Let" (vcat [ppr bind, ppr $ okToFloat (rv_lcl renv) (bindFreeVars bind)]) $ + not (isJoinBind bind) -- can't float join point out of argument position + , okToFloat (rv_lcl renv) (bindFreeVars bind) -- See Note [Matching lets] + = match (renv { rv_fltR = flt_subst' + , rv_lcl = rv_lcl renv `extendRnInScopeSetList` new_bndrs }) + -- We are floating the let-binding out, as if it had enclosed + -- the entire target from Day 1. So we must add its binders to + -- the in-scope set (#20200) + (subst { rs_binds = rs_binds subst . Let bind' + , rs_bndrs = new_bndrs ++ rs_bndrs subst }) + e1 e2 mco + | otherwise + = Nothing + where + in_scope = rnInScopeSet (rv_lcl renv) `extendInScopeSetList` rs_bndrs subst + -- in_scope: see (4) in Note [Matching lets] + flt_subst = rv_fltR renv `setInScope` in_scope + (flt_subst', bind') = substBind flt_subst bind + new_bndrs = bindersOf bind' + +------------------------ Lambdas --------------------- +match renv subst (Lam x1 e1) e2 mco + | Just (x2, e2', ts) <- exprIsLambda_maybe (rvInScopeEnv renv) (mkCastMCo e2 mco) + -- See Note [Lambdas in the template] + = let renv' = rnMatchBndr2 renv x1 x2 + subst' = subst { rs_binds = rs_binds subst . flip (foldr mkTick) ts } + in match renv' subst' e1 e2' MRefl + +match renv subst e1 e2@(Lam {}) mco + | Just (renv', e2') <- eta_reduce renv e2 -- See Note [Eta reduction in the target] + = match renv' subst e1 e2' mco + +{- Note [Lambdas in the template] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we match + Template: (\x. blah_template) + Target: (\y. blah_target) +then we want to match inside the lambdas, using rv_lcl to match up +x and y. + +But what about this? + Template (\x. (blah1 |> cv)) + Target (\y. blah2) |> co + +This happens quite readily, because the Simplifier generally moves +casts outside lambdas: see Note [Casts and lambdas] in +GHC.Core.Opt.Simplify.Utils. So, tiresomely, we want to push `co` +back inside, which is what `exprIsLambda_maybe` does. But we've +stripped off that cast, so now we need to put it back, hence mkCastMCo. + +Unlike the target, where we attempt eta-reduction, we do not attempt +to eta-reduce the template, and may therefore fail on + Template: \x. f True x + Target f True + +It's not especially easy to deal with eta reducing the template, +and never happens, because no one write eta-expanded left-hand-sides. +-} + +------------------------ Case expression --------------------- +{- Disabled: see Note [Matching cases] below +match renv (tv_subst, id_subst, binds) e1 + (Case scrut case_bndr ty [(con, alt_bndrs, rhs)]) + | exprOkForSpeculation scrut -- See Note [Matching cases] + , okToFloat rn_env bndrs (exprFreeVars scrut) + = match (renv { me_env = rn_env' }) + (tv_subst, id_subst, binds . case_wrap) + e1 rhs + where + rn_env = me_env renv + rn_env' = extendRnInScopeList rn_env bndrs + bndrs = case_bndr : alt_bndrs + case_wrap rhs' = Case scrut case_bndr ty [(con, alt_bndrs, rhs')] +-} + +match renv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2) mco + = do { subst1 <- match_ty renv subst ty1 ty2 + ; subst2 <- match renv subst1 e1 e2 MRefl + ; let renv' = rnMatchBndr2 renv x1 x2 + ; match_alts renv' subst2 alts1 alts2 mco -- Alts are both sorted + } + +-- Everything else fails +match _ _ _e1 _e2 _mco = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $ + Nothing + +------------- +eta_reduce :: RuleMatchEnv -> CoreExpr -> Maybe (RuleMatchEnv, CoreExpr) +-- See Note [Eta reduction in the target] +eta_reduce renv e@(Lam {}) + = go renv id [] e + where + go :: RuleMatchEnv -> BindWrapper -> [Var] -> CoreExpr + -> Maybe (RuleMatchEnv, CoreExpr) + go renv bw vs (Let b e) = go renv (bw . Let b) vs e + + go renv bw vs (Lam v e) = go renv' bw (v':vs) e + where + (rn_env', v') = rnBndrR (rv_lcl renv) v + renv' = renv { rv_lcl = rn_env' } + + go renv bw (v:vs) (App f arg) + | Var a <- arg, v == rnOccR (rv_lcl renv) a + = go renv bw vs f + + | Type ty <- arg, Just tv <- getTyVar_maybe ty + , v == rnOccR (rv_lcl renv) tv + = go renv bw vs f + + go renv bw [] e = Just (renv, bw e) + go _ _ (_:_) _ = Nothing + +eta_reduce _ _ = Nothing + +{- Note [Eta reduction in the target] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are faced with this (#19790) + Template {x} f x + Target (\a b c. let blah in f x a b c) + +You might wonder why we have an eta-expanded target (see first subtle +point below), but regardless of how it came about, we'd like +eta-expansion not to impede matching. + +So eta_reduce does on-the-fly eta-reduction of the target expression. +Given (\a b c. let blah in e a b c), it returns (let blah in e). + +Subtle points: +* Consider a target: \x. f <expensive> x + In the main eta-reducer we do not eta-reduce this, because doing so + might reduce the arity of the expression (from 1 to zero, because of + <expensive>). But for rule-matching we /do/ want to match template + (f a) against target (\x. f <expensive> x), with a := <expensive> + + This is a compelling reason for not relying on the Simplifier's + eta-reducer. + +* The Lam case of eta_reduce renames as it goes. Consider + (\x. \x. f x x). We should not eta-reduce this. As we go we rename + the first x to x1, and the second to x2; then both argument x's are x2. + +* eta_reduce does /not/ need to check that the bindings 'blah' + and expression 'e' don't mention a b c; but it /does/ extend the + rv_lcl RnEnv2 (see rn_bndr in eta_reduce). + * If 'blah' mentions the binders, the let-float rule won't + fire; and + * if 'e' mentions the binders we we'll also fail to match + e.g. because of the exprFreeVars test in match_tmpl_var. + + Example: Template: {x} f a -- Some top-level 'a' + Target: (\a b. f a a b) -- The \a shadows top level 'a' + Then eta_reduce will /succeed/, with + (rnEnvR = [a :-> a'], f a) + The returned RnEnv will map [a :-> a'], where a' is fresh. (There is + no need to rename 'b' because (in this example) it is not in scope. + So it's as if we'd returned (f a') from eta_reduce; the renaming applied + to the target is simply deferred. + +Note [Cancel reflexive casts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is an example (from #19790) which we want to catch + (f x) ~ (\a b. (f x |> co) a b) |> sym co +where + f :: Int -> Stream + co :: Stream ~ T1 -> T2 -> T3 + +when we eta-reduce (\a b. blah a b) to 'blah', we'll get + (f x) ~ (f x) |> co |> sym co + +and we really want to spot that the co/sym-co cancels out. +Hence + * We keep an invariant that the MCoercion is always MRefl + if the MCoercion is reflexive + * We maintain this invariant via the call to checkReflexiveMCo + in the Cast case of 'match'. +-} + +------------- +match_co :: RuleMatchEnv + -> RuleSubst + -> Coercion + -> Coercion + -> Maybe RuleSubst +-- We only match if the template is a coercion variable or Refl: +-- see Note [Casts in the template] +-- Like 'match' it is /not/ guaranteed that +-- coercionKind template = coercionKind target +-- But if match_co succeeds, it /is/ guaranteed that +-- coercionKind (subst template) = coercionKind target + +match_co renv subst co1 co2 + | Just cv <- getCoVar_maybe co1 + = match_var renv subst cv (Coercion co2) + + | Just (ty1, r1) <- isReflCo_maybe co1 + = do { (ty2, r2) <- isReflCo_maybe co2 + ; guard (r1 == r2) + ; match_ty renv subst ty1 ty2 } + + | debugIsOn + = pprTrace "match_co: needs more cases" (ppr co1 $$ ppr co2) Nothing + -- Currently just deals with CoVarCo and Refl + + | otherwise + = Nothing + +------------- +rnMatchBndr2 :: RuleMatchEnv -> Var -> Var -> RuleMatchEnv +rnMatchBndr2 renv x1 x2 + = renv { rv_lcl = rnBndr2 (rv_lcl renv) x1 x2 + , rv_fltR = delBndr (rv_fltR renv) x2 } + + +------------------------------------------ +match_alts :: RuleMatchEnv + -> RuleSubst + -> [CoreAlt] -- Template + -> [CoreAlt] -> MCoercion -- Target + -> Maybe RuleSubst +match_alts _ subst [] [] _ + = return subst +match_alts renv subst (Alt c1 vs1 r1:alts1) (Alt c2 vs2 r2:alts2) mco + | c1 == c2 + = do { subst1 <- match renv' subst r1 r2 mco + ; match_alts renv subst1 alts1 alts2 mco } + where + renv' = foldl' mb renv (vs1 `zip` vs2) + mb renv (v1,v2) = rnMatchBndr2 renv v1 v2 + +match_alts _ _ _ _ _ + = Nothing + +------------------------------------------ +okToFloat :: RnEnv2 -> VarSet -> Bool +okToFloat rn_env bind_fvs + = allVarSet not_captured bind_fvs + where + not_captured fv = not (inRnEnvR rn_env fv) + +------------------------------------------ +match_var :: RuleMatchEnv + -> RuleSubst + -> Var -- Template + -> CoreExpr -- Target + -> Maybe RuleSubst +match_var renv@(RV { rv_tmpls = tmpls, rv_lcl = rn_env, rv_fltR = flt_env }) + subst v1 e2 + | v1' `elemVarSet` tmpls + = match_tmpl_var renv subst v1' e2 + + | otherwise -- v1' is not a template variable; check for an exact match with e2 + = case e2 of -- Remember, envR of rn_env is disjoint from rv_fltR + Var v2 | Just v2' <- rnOccR_maybe rn_env v2 + -> -- v2 was bound by a nested lambda or case + if v1' == v2' then Just subst + else Nothing + + -- v2 is not bound nestedly; it is free + -- in the whole expression being matched + -- So it will be in the InScopeSet for flt_env (#20200) + | Var v2' <- lookupIdSubst flt_env v2 + , v1' == v2' + -> Just subst + | otherwise + -> Nothing + + _ -> Nothing + + where + v1' = rnOccL rn_env v1 + -- If the template is + -- forall x. f x (\x -> x) = ... + -- Then the x inside the lambda isn't the + -- template x, so we must rename first! + +------------------------------------------ +match_tmpl_var :: RuleMatchEnv + -> RuleSubst + -> Var -- Template + -> CoreExpr -- Target + -> Maybe RuleSubst + +match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env }) + subst@(RS { rs_id_subst = id_subst, rs_bndrs = let_bndrs }) + v1' e2 + -- anyInRnEnvR is lazy in the 2nd arg which allows us to avoid computing fvs + -- if the right side of the env is empty. + | anyInRnEnvR rn_env (exprFreeVars e2) + = Nothing -- Skolem-escape failure + -- e.g. match forall a. (\x-> a x) against (\y. y y) + + | Just e1' <- lookupVarEnv id_subst v1' + = if eqCoreExpr e1' e2' + then Just subst + else Nothing + + | otherwise -- See Note [Matching variable types] + = do { subst' <- match_ty renv subst (idType v1') (exprType e2) + ; return (subst' { rs_id_subst = id_subst' }) } + where + -- e2' is the result of applying flt_env to e2 + e2' | null let_bndrs = e2 + | otherwise = substExpr flt_env e2 + + id_subst' = extendVarEnv (rs_id_subst subst) v1' e2' + -- No further renaming to do on e2', + -- because no free var of e2' is in the rnEnvR of the envt + +------------------------------------------ +match_ty :: RuleMatchEnv + -> RuleSubst + -> Type -- Template + -> Type -- Target + -> Maybe RuleSubst +-- Matching Core types: use the matcher in GHC.Tc.Utils.TcType. +-- Notice that we treat newtypes as opaque. For example, suppose +-- we have a specialised version of a function at a newtype, say +-- newtype T = MkT Int +-- We only want to replace (f T) with f', not (f Int). + +match_ty renv subst ty1 ty2 + = do { tv_subst' + <- Unify.ruleMatchTyKiX (rv_tmpls renv) (rv_lcl renv) tv_subst ty1 ty2 + ; return (subst { rs_tv_subst = tv_subst' }) } + where + tv_subst = rs_tv_subst subst + +{- Note [Matching variable types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When matching x ~ e, where 'x' is a template variable, we must check that +x's type matches e's type, to establish (TypeInv). For example + forall (c::Char->Int) (x::Char). + f (c x) = "RULE FIRED" +We must not match on, say (f (pred (3::Int))). + +It's actually quite difficult to come up with an example that shows +you need type matching, esp since matching is left-to-right, so type +args get matched first. But it's possible (e.g. simplrun008) and this +is the Right Thing to do. + +An alternative would be to make (TypeInf) into a /pre-condition/. It +is threatened only by the App rule. So when matching an application +(e1 e2) ~ (d1 d2) would be to collect args of the application chain, +match the types of the head, then match arg-by-arg. + +However that alternative seems a bit more complicated. And by +matching types at variables we do one match_ty for each template +variable, rather than one for each application chain. Usually there are +fewer template variables, although for simple rules it could be the other +way around. + +Note [Expanding variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is another Very Important rule: if the term being matched is a +variable, we expand it so long as its unfolding is "expandable". (Its +occurrence information is not necessarily up to date, so we don't use +it.) By "expandable" we mean a WHNF or a "constructor-like" application. +This is the key reason for "constructor-like" Ids. If we have + {-# NOINLINE [1] CONLIKE g #-} + {-# RULE f (g x) = h x #-} +then in the term + let v = g 3 in ....(f v).... +we want to make the rule fire, to replace (f v) with (h 3). + +Note [Do not expand locally-bound variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do *not* expand locally-bound variables, else there's a worry that the +unfolding might mention variables that are themselves renamed. +Example + case x of y { (p,q) -> ...y... } +Don't expand 'y' to (p,q) because p,q might themselves have been +renamed. Essentially we only expand unfoldings that are "outside" +the entire match. + +Hence, (a) the guard (not (isLocallyBoundR v2)) + (b) when we expand we nuke the renaming envt (nukeRnEnvR). + +Note [Tick annotations in RULE matching] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to unconditionally look through ticks in both template and +expression being matched. This is actually illegal for counting or +cost-centre-scoped ticks, because we have no place to put them without +changing entry counts and/or costs. So now we just fail the match in +these cases. + +On the other hand, where we are allowed to insert new cost into the +tick scope, we can float them upwards to the rule application site. + +Moreover, we may encounter ticks in the template of a rule. There are a few +ways in which these may be introduced (e.g. #18162, #17619). Such ticks are +ignored by the matcher. See Note [Simplifying rules] in +GHC.Core.Opt.Simplify.Utils for details. + +cf Note [Tick annotations in call patterns] in GHC.Core.Opt.SpecConstr + + +Note [Matching lets] +~~~~~~~~~~~~~~~~~~~~ +Matching a let-expression. Consider + RULE forall x. f (g x) = <rhs> +and target expression + f (let { w=R } in g E)) +Then we'd like the rule to match, to generate + let { w=R } in (\x. <rhs>) E +In effect, we want to float the let-binding outward, to enable +the match to happen. This is the WHOLE REASON for accumulating +bindings in the RuleSubst + +We can only do this if the free variables of R are not bound by the +part of the target expression outside the let binding; e.g. + f (\v. let w = v+1 in g E) +Here we obviously cannot float the let-binding for w. Hence the +use of okToFloat. + +There are a couple of tricky points: + (a) What if floating the binding captures a variable that is + free in the entire expression? + f (let v = x+1 in v) v + --> NOT! + let v = x+1 in f (x+1) v + + (b) What if the let shadows a local binding? + f (\v -> (v, let v = x+1 in (v,v)) + --> NOT! + let v = x+1 in f (\v -> (v, (v,v))) + + (c) What if two non-nested let bindings bind the same variable? + f (let v = e1 in b1) (let v = e2 in b2) + --> NOT! + let v = e1 in let v = e2 in (f b2 b2) + See testsuite test `T4814`. + +Our cunning plan is this: + (1) Along with the growing substitution for template variables + we maintain a growing set of floated let-bindings (rs_binds) + plus the set of variables thus bound (rs_bndrs). + + (2) The RnEnv2 in the MatchEnv binds only the local binders + in the term (lambdas, case), not the floated let-bndrs. + + (3) When we encounter a `let` in the term to be matched, in the Let + case of `match`, we use `okToFloat` to check that it does not mention any + locally bound (lambda, case) variables. If so we fail. + + (4) In the Let case of `match`, we use GHC.Core.Subst.substBind to + freshen the binding (which, remember (3), mentions no locally + bound variables), in a lexically-scoped way (via rv_fltR in + MatchEnv). + + The subtle point is that we want an in-scope set for this + substitution that includes /two/ sets: + * The in-scope variables at this point, so that we avoid using + those local names for the floated binding; points (a) and (b) above. + * All "earlier" floated bindings, so that we avoid using the + same name for two different floated bindings; point (c) above. + + Because we have to compute the in-scope set here, the in-scope set + stored in `rv_fltR` is always ignored; we leave it only because it's + convenient to have `rv_fltR :: Subst` (with an always-ignored `InScopeSet`) + rather than storing three separate substitutions. + + (5) We apply that freshening substitution, in a lexically-scoped + way to the term, although lazily; this is the rv_fltR field. + +See #4814, which is an issue resulting from getting this wrong. + +Note [Matching cases] +~~~~~~~~~~~~~~~~~~~~~ +{- NOTE: This idea is currently disabled. It really only works if + the primops involved are OkForSpeculation, and, since + they have side effects readIntOfAddr and touch are not. + Maybe we'll get back to this later . -} + +Consider + f (case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) -> + case touch# fp s# of { _ -> + I# n# } } ) +This happened in a tight loop generated by stream fusion that +Roman encountered. We'd like to treat this just like the let +case, because the primops concerned are ok-for-speculation. +That is, we'd like to behave as if it had been + case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) -> + case touch# fp s# of { _ -> + f (I# n# } } ) + +Note [Lookup in-scope] +~~~~~~~~~~~~~~~~~~~~~~ +Consider this example + foo :: Int -> Maybe Int -> Int + foo 0 (Just n) = n + foo m (Just n) = foo (m-n) (Just n) + +SpecConstr sees this fragment: + + case w_smT of wild_Xf [Just A] { + Data.Maybe.Nothing -> lvl_smf; + Data.Maybe.Just n_acT [Just S(L)] -> + case n_acT of wild1_ams [Just A] { GHC.Base.I# y_amr [Just L] -> + $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf + }}; + +and correctly generates the rule + + RULES: "SC:$wfoo1" [0] __forall {y_amr [Just L] :: GHC.Prim.Int# + sc_snn :: GHC.Prim.Int#} + $wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr)) + = $s$wfoo_sno y_amr sc_snn ;] + +BUT we must ensure that this rule matches in the original function! +Note that the call to $wfoo is + $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf + +During matching we expand wild_Xf to (Just n_acT). But then we must also +expand n_acT to (I# y_amr). And we can only do that if we look up n_acT +in the in-scope set, because in wild_Xf's unfolding it won't have an unfolding +at all. + +That is why the 'lookupRnInScope' call in the (Var v2) case of 'match' +is so important. + + +************************************************************************ +* * + Rule-check the program +* * +************************************************************************ + + We want to know what sites have rules that could have fired but didn't. + This pass runs over the tree (without changing it) and reports such. +-} + +-- | Report partial matches for rules beginning with the specified +-- string for the purposes of error reporting +ruleCheckProgram :: RuleOpts -- ^ Rule options + -> CompilerPhase -- ^ Rule activation test + -> String -- ^ Rule pattern + -> (Id -> [CoreRule]) -- ^ Rules for an Id + -> CoreProgram -- ^ Bindings to check in + -> SDoc -- ^ Resulting check message +ruleCheckProgram ropts phase rule_pat rules binds + | isEmptyBag results + = text "Rule check results: no rule application sites" + | otherwise + = vcat [text "Rule check results:", + line, + vcat [ p $$ line | p <- bagToList results ] + ] + where + env = RuleCheckEnv { rc_is_active = isActive phase + , rc_id_unf = idUnfolding -- Not quite right + -- Should use activeUnfolding + , rc_pattern = rule_pat + , rc_rules = rules + , rc_ropts = ropts + } + results = unionManyBags (map (ruleCheckBind env) binds) + line = text (replicate 20 '-') + +data RuleCheckEnv = RuleCheckEnv { + rc_is_active :: Activation -> Bool, + rc_id_unf :: IdUnfoldingFun, + rc_pattern :: String, + rc_rules :: Id -> [CoreRule], + rc_ropts :: RuleOpts +} + +ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc + -- The Bag returned has one SDoc for each call site found +ruleCheckBind env (NonRec _ r) = ruleCheck env r +ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (_,r) <- prs] + +ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc +ruleCheck _ (Var _) = emptyBag +ruleCheck _ (Lit _) = emptyBag +ruleCheck _ (Type _) = emptyBag +ruleCheck _ (Coercion _) = emptyBag +ruleCheck env (App f a) = ruleCheckApp env (App f a) [] +ruleCheck env (Tick _ e) = ruleCheck env e +ruleCheck env (Cast e _) = ruleCheck env e +ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e +ruleCheck env (Lam _ e) = ruleCheck env e +ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags` + unionManyBags [ruleCheck env r | Alt _ _ r <- as] + +ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc +ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as) +ruleCheckApp env (Var f) as = ruleCheckFun env f as +ruleCheckApp env other _ = ruleCheck env other + +ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc +-- Produce a report for all rules matching the predicate +-- saying why it doesn't match the specified application + +ruleCheckFun env fn args + | null name_match_rules = emptyBag + | otherwise = unitBag (ruleAppCheck_help env fn args name_match_rules) + where + name_match_rules = filter match (rc_rules env fn) + match rule = rc_pattern env `isPrefixOf` unpackFS (ruleName rule) + +ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc +ruleAppCheck_help env fn args rules + = -- The rules match the pattern, so we want to print something + vcat [text "Expression:" <+> ppr (mkApps (Var fn) args), + vcat (map check_rule rules)] + where + n_args = length args + i_args = args `zip` [1::Int ..] + rough_args = map roughTopName args + + check_rule rule = rule_herald rule <> colon <+> rule_info (rc_ropts env) rule + + rule_herald (BuiltinRule { ru_name = name }) + = text "Builtin rule" <+> doubleQuotes (ftext name) + rule_herald (Rule { ru_name = name }) + = text "Rule" <+> doubleQuotes (ftext name) + + rule_info opts rule + | Just _ <- matchRule opts (emptyInScopeSet, rc_id_unf env) + noBlackList fn args rough_args rule + = text "matches (which is very peculiar!)" + + rule_info _ (BuiltinRule {}) = text "does not match" + + rule_info _ (Rule { ru_act = act, + ru_bndrs = rule_bndrs, ru_args = rule_args}) + | not (rc_is_active env act) = text "active only in later phase" + | n_args < n_rule_args = text "too few arguments" + | n_mismatches == n_rule_args = text "no arguments match" + | n_mismatches == 0 = text "all arguments match (considered individually), but rule as a whole does not" + | otherwise = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)" + where + n_rule_args = length rule_args + n_mismatches = length mismatches + mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args, + not (isJust (match_fn rule_arg arg))] + + lhs_fvs = exprsFreeVars rule_args -- Includes template tyvars + match_fn rule_arg arg = match renv emptyRuleSubst rule_arg arg MRefl + where + in_scope = mkInScopeSet (lhs_fvs `unionVarSet` exprFreeVars arg) + renv = RV { rv_lcl = mkRnEnv2 in_scope + , rv_tmpls = mkVarSet rule_bndrs + , rv_fltR = mkEmptySubst in_scope + , rv_unf = rc_id_unf env } diff --git a/compiler/GHC/Core/Seq.hs b/compiler/GHC/Core/Seq.hs index 2f72fc4c9f..3c4fd7cbf2 100644 --- a/compiler/GHC/Core/Seq.hs +++ b/compiler/GHC/Core/Seq.hs @@ -13,6 +13,8 @@ module GHC.Core.Seq ( import GHC.Prelude import GHC.Core +import GHC.Core.Rules +import GHC.Core.Unfoldings import GHC.Types.Id.Info import GHC.Types.Demand( seqDemand, seqDmdSig ) import GHC.Types.Cpr( seqCprSig ) diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs index ba95baec64..aff96cf4e7 100644 --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -21,12 +21,14 @@ module GHC.Core.SimpleOpt ( import GHC.Prelude import GHC.Core +import GHC.Core.Rules import GHC.Core.Opt.Arity import GHC.Core.Subst import GHC.Core.Utils import GHC.Core.FVs import GHC.Core.Unfold import GHC.Core.Unfold.Make +import GHC.Core.Unfoldings import GHC.Core.Make ( FloatBind(..), mkWildValBinder ) import GHC.Core.Opt.OccurAnal( occurAnalyseExpr, occurAnalysePgm, zapLambdaBndrs ) import GHC.Types.Literal @@ -1416,7 +1418,7 @@ exprIsLambda_maybe will, given an expression `e`, try to turn it into the form casts (using the Push rule), and it unfolds function calls if the unfolding has a greater arity than arguments are present. -Currently, it is used in GHC.Core.Rules.match, and is required to make +Currently, it is used in GHC.Core.Rules.Apply.match, and is required to make "map coerce = coerce" match. -} diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs index f0ad737fb6..9411f1b5e7 100644 --- a/compiler/GHC/Core/Subst.hs +++ b/compiler/GHC/Core/Subst.hs @@ -37,6 +37,8 @@ module GHC.Core.Subst ( import GHC.Prelude import GHC.Core +import GHC.Core.Rules +import GHC.Core.Unfoldings import GHC.Core.FVs import GHC.Core.Seq import GHC.Core.Utils diff --git a/compiler/GHC/Core/Tidy.hs b/compiler/GHC/Core/Tidy.hs index 5326346ead..921ecbbdb7 100644 --- a/compiler/GHC/Core/Tidy.hs +++ b/compiler/GHC/Core/Tidy.hs @@ -15,6 +15,8 @@ module GHC.Core.Tidy ( import GHC.Prelude import GHC.Core +import GHC.Core.Rules +import GHC.Core.Unfoldings import GHC.Core.Type import GHC.Core.Seq ( seqUnfolding ) diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs index 48a7e5e82f..b8e4f467b3 100644 --- a/compiler/GHC/Core/Unfold.hs +++ b/compiler/GHC/Core/Unfold.hs @@ -38,6 +38,7 @@ module GHC.Core.Unfold ( import GHC.Prelude import GHC.Core +import GHC.Core.Unfoldings import GHC.Core.Utils import GHC.Types.Id import GHC.Core.DataCon diff --git a/compiler/GHC/Core/Unfold/Make.hs b/compiler/GHC/Core/Unfold/Make.hs index 479187005b..1c72fc2974 100644 --- a/compiler/GHC/Core/Unfold/Make.hs +++ b/compiler/GHC/Core/Unfold/Make.hs @@ -23,6 +23,7 @@ where import GHC.Prelude import GHC.Core import GHC.Core.Unfold +import GHC.Core.Unfoldings import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) import GHC.Core.Opt.Arity ( manifestArity ) import GHC.Core.DataCon diff --git a/compiler/GHC/Core/Unfoldings.hs b/compiler/GHC/Core/Unfoldings.hs new file mode 100644 index 0000000000..6ba48e8b6e --- /dev/null +++ b/compiler/GHC/Core/Unfoldings.hs @@ -0,0 +1,433 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE BangPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | GHC.Core holds all the main data types for use by for the Glasgow Haskell Compiler midsection +module GHC.Core.Unfoldings ( + -- * Unfolding data types + Unfolding(..), UnfoldingCache(..), UnfoldingGuidance(..), UnfoldingSource(..), + + -- ** Constructing 'Unfolding's + noUnfolding, bootUnfolding, evaldUnfolding, mkOtherCon, + unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk, + + -- ** Predicates and deconstruction on 'Unfolding' + unfoldingTemplate, expandUnfolding_maybe, + maybeUnfoldingTemplate, otherCons, + isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, + isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding, + isStableUnfolding, isStableUserUnfolding, isStableSystemUnfolding, + isInlineUnfolding, isBootUnfolding, + hasCoreUnfolding, hasSomeUnfolding, + canUnfold, neverUnfoldGuidance, isStableSource, + ) where + +import GHC.Prelude + +import GHC.Types.Var +import GHC.Core +import GHC.Core.DataCon +import GHC.Types.Basic + +{- +The @Unfolding@ type is declared here to avoid numerous loops + +Note [Never put `OtherCon` unfoldings on lambda binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Based on #21496 we never attach unfoldings of any kind to lambda binders. +It's just too easy for the call site to change and invalidate the unfolding. +E.g. the caller of the lambda drops a seq (e.g. because the lambda is strict in it's binder) +which in turn makes the OtherCon[] unfolding a lie. +So unfoldings on lambda binders can never really be trusted when on lambda binders if there +is the chance of the call site to change. So it's easiest to just never attach any +to lambda binders to begin with, as well as stripping them off if we e.g. float out +and expression while abstracting over some arguments. +-} + +-- | Records the /unfolding/ of an identifier, which is approximately the form the +-- identifier would have if we substituted its definition in for the identifier. +-- This type should be treated as abstract everywhere except in "GHC.Core.Unfold" +data Unfolding + = NoUnfolding -- ^ We have no information about the unfolding. + + | BootUnfolding -- ^ We have no information about the unfolding, because + -- this 'Id' came from an @hi-boot@ file. + -- See Note [Inlining and hs-boot files] in "GHC.CoreToIface" + -- for what this is used for. + + | OtherCon [AltCon] -- ^ It ain't one of these constructors. + -- @OtherCon xs@ also indicates that something has been evaluated + -- and hence there's no point in re-evaluating it. + -- @OtherCon []@ is used even for non-data-type values + -- to indicated evaluated-ness. Notably: + -- + -- > data C = C !(Int -> Int) + -- > case x of { C f -> ... } + -- + -- Here, @f@ gets an @OtherCon []@ unfolding. + + | DFunUnfolding { -- The Unfolding of a DFunId + -- See Note [DFun unfoldings] + -- df = /\a1..am. \d1..dn. MkD t1 .. tk + -- (op1 a1..am d1..dn) + -- (op2 a1..am d1..dn) + df_bndrs :: [Var], -- The bound variables [a1..m],[d1..dn] + df_con :: DataCon, -- The dictionary data constructor (never a newtype datacon) + df_args :: [CoreExpr] -- Args of the data con: types, superclasses and methods, + } -- in positional order + + | CoreUnfolding { -- An unfolding for an Id with no pragma, + -- or perhaps a NOINLINE pragma + -- (For NOINLINE, the phase, if any, is in the + -- InlinePragInfo for this Id.) + uf_tmpl :: CoreExpr, -- Template; occurrence info is correct + uf_src :: UnfoldingSource, -- Where the unfolding came from + uf_is_top :: Bool, -- True <=> top level binding + uf_cache :: UnfoldingCache, -- Cache of flags computable from the expr + -- See Note [Tying the 'CoreUnfolding' knot] + uf_guidance :: UnfoldingGuidance -- Tells about the *size* of the template. + } + -- ^ An unfolding with redundant cached information. Parameters: + -- + -- uf_tmpl: Template used to perform unfolding; + -- NB: Occurrence info is guaranteed correct: + -- see Note [OccInfo in unfoldings and rules] + -- + -- uf_is_top: Is this a top level binding? + -- + -- uf_is_value: 'exprIsHNF' template (cached); it is ok to discard a 'seq' on + -- this variable + -- + -- uf_is_work_free: Does this waste only a little work if we expand it inside an inlining? + -- Basically this is a cached version of 'exprIsWorkFree' + -- + -- uf_guidance: Tells us about the /size/ of the unfolding template + + +-- | Properties of a 'CoreUnfolding' that could be computed on-demand from its template. +-- See Note [UnfoldingCache] +data UnfoldingCache + = UnfoldingCache { + uf_is_value :: !Bool, -- exprIsHNF template (cached); it is ok to discard + -- a `seq` on this variable + uf_is_conlike :: !Bool, -- True <=> applicn of constructor or CONLIKE function + -- Cached version of exprIsConLike + uf_is_work_free :: !Bool, -- True <=> doesn't waste (much) work to expand + -- inside an inlining + -- Cached version of exprIsCheap + uf_expandable :: !Bool -- True <=> can expand in RULE matching + -- Cached version of exprIsExpandable + } + deriving (Eq) + +-- | 'UnfoldingGuidance' says when unfolding should take place +data UnfoldingGuidance + = UnfWhen { -- Inline without thinking about the *size* of the uf_tmpl + -- Used (a) for small *and* cheap unfoldings + -- (b) for INLINE functions + -- See Note [INLINE for small functions] in GHC.Core.Unfold + ug_arity :: Arity, -- Number of value arguments expected + + ug_unsat_ok :: Bool, -- True <=> ok to inline even if unsaturated + ug_boring_ok :: Bool -- True <=> ok to inline even if the context is boring + -- So True,True means "always" + } + + | UnfIfGoodArgs { -- Arose from a normal Id; the info here is the + -- result of a simple analysis of the RHS + + ug_args :: [Int], -- Discount if the argument is evaluated. + -- (i.e., a simplification will definitely + -- be possible). One elt of the list per *value* arg. + + ug_size :: Int, -- The "size" of the unfolding. + + ug_res :: Int -- Scrutinee discount: the discount to subtract if the thing is in + } -- a context (case (thing args) of ...), + -- (where there are the right number of arguments.) + + | UnfNever -- The RHS is big, so don't inline it + deriving (Eq) + +{- Note [UnfoldingCache] +~~~~~~~~~~~~~~~~~~~~~~~~ +The UnfoldingCache field of an Unfolding holds four (strict) booleans, +all derived from the uf_tmpl field of the unfolding. + +* We serialise the UnfoldingCache to and from interface files, for + reasons described in Note [Tying the 'CoreUnfolding' knot] in + GHC.IfaceToCore + +* Because it is a strict data type, we must be careful not to + pattern-match on it until we actually want its values. E.g + GHC.Core.Unfold.callSiteInline/tryUnfolding are careful not to force + it unnecessarily. Just saves a bit of work. + +* When `seq`ing Core to eliminate space leaks, to suffices to `seq` on + the cache, but not its fields, because it is strict in all fields. + +Note [Historical note: unfoldings for wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to have a nice clever scheme in interface files for +wrappers. A wrapper's unfolding can be reconstructed from its worker's +id and its strictness. This decreased .hi file size (sometimes +significantly, for modules like GHC.Classes with many high-arity w/w +splits) and had a slight corresponding effect on compile times. + +However, when we added the second demand analysis, this scheme lead to +some Core lint errors. The second analysis could change the strictness +signatures, which sometimes resulted in a wrapper's regenerated +unfolding applying the wrapper to too many arguments. + +Instead of repairing the clever .hi scheme, we abandoned it in favor +of simplicity. The .hi sizes are usually insignificant (excluding the ++1M for base libraries), and compile time barely increases (~+1% for +nofib). The nicer upshot is that the UnfoldingSource no longer mentions +an Id, so, eg, substitutions need not traverse them. + + +Note [DFun unfoldings] +~~~~~~~~~~~~~~~~~~~~~~ +The Arity in a DFunUnfolding is total number of args (type and value) +that the DFun needs to produce a dictionary. That's not necessarily +related to the ordinary arity of the dfun Id, esp if the class has +one method, so the dictionary is represented by a newtype. Example + + class C a where { op :: a -> Int } + instance C a -> C [a] where op xs = op (head xs) + +The instance translates to + + $dfCList :: forall a. C a => C [a] -- Arity 2! + $dfCList = /\a.\d. $copList {a} d |> co + + $copList :: forall a. C a => [a] -> Int -- Arity 2! + $copList = /\a.\d.\xs. op {a} d (head xs) + +Now we might encounter (op (dfCList {ty} d) a1 a2) +and we want the (op (dfList {ty} d)) rule to fire, because $dfCList +has all its arguments, even though its (value) arity is 2. That's +why we record the number of expected arguments in the DFunUnfolding. + +Note that although it's an Arity, it's most convenient for it to give +the *total* number of arguments, both type and value. See the use +site in exprIsConApp_maybe. +-} + +-- Constants for the UnfWhen constructor +needSaturated, unSaturatedOk :: Bool +needSaturated = False +unSaturatedOk = True + +boringCxtNotOk, boringCxtOk :: Bool +boringCxtOk = True +boringCxtNotOk = False + +------------------------------------------------ +noUnfolding :: Unfolding +-- ^ There is no known 'Unfolding' +evaldUnfolding :: Unfolding +-- ^ This unfolding marks the associated thing as being evaluated + +noUnfolding = NoUnfolding +evaldUnfolding = OtherCon [] + +-- | There is no known 'Unfolding', because this came from an +-- hi-boot file. +bootUnfolding :: Unfolding +bootUnfolding = BootUnfolding + +mkOtherCon :: [AltCon] -> Unfolding +mkOtherCon = OtherCon + +-- | Retrieves the template of an unfolding: panics if none is known +unfoldingTemplate :: Unfolding -> CoreExpr +unfoldingTemplate = uf_tmpl + +-- | Retrieves the template of an unfolding if possible +-- maybeUnfoldingTemplate is used mainly when specialising, and we do +-- want to specialise DFuns, so it's important to return a template +-- for DFunUnfoldings +maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr +maybeUnfoldingTemplate (CoreUnfolding { uf_tmpl = expr }) + = Just expr +maybeUnfoldingTemplate (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }) + = Just (mkLams bndrs (mkApps (Var (dataConWorkId con)) args)) +maybeUnfoldingTemplate _ + = Nothing + +-- | The constructors that the unfolding could never be: +-- returns @[]@ if no information is available +otherCons :: Unfolding -> [AltCon] +otherCons (OtherCon cons) = cons +otherCons _ = [] + +-- | Determines if it is certainly the case that the unfolding will +-- yield a value (something in HNF): returns @False@ if unsure +isValueUnfolding :: Unfolding -> Bool + -- Returns False for OtherCon +isValueUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_value cache +isValueUnfolding (DFunUnfolding {}) = True +isValueUnfolding _ = False + +-- | Determines if it possibly the case that the unfolding will +-- yield a value. Unlike 'isValueUnfolding' it returns @True@ +-- for 'OtherCon' +isEvaldUnfolding :: Unfolding -> Bool + -- Returns True for OtherCon +isEvaldUnfolding (OtherCon _) = True +isEvaldUnfolding (DFunUnfolding {}) = True +isEvaldUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_value cache +isEvaldUnfolding _ = False + +-- | @True@ if the unfolding is a constructor application, the application +-- of a CONLIKE function or 'OtherCon' +isConLikeUnfolding :: Unfolding -> Bool +isConLikeUnfolding (OtherCon _) = True +isConLikeUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_conlike cache +isConLikeUnfolding _ = False + +-- | Is the thing we will unfold into certainly cheap? +isCheapUnfolding :: Unfolding -> Bool +isCheapUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_work_free cache +isCheapUnfolding _ = False + +isExpandableUnfolding :: Unfolding -> Bool +isExpandableUnfolding (CoreUnfolding { uf_cache = cache }) = uf_expandable cache +isExpandableUnfolding _ = False + +expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr +-- Expand an expandable unfolding; this is used in rule matching +-- See Note [Expanding variables] in GHC.Core.Rules +-- The key point here is that CONLIKE things can be expanded +expandUnfolding_maybe (CoreUnfolding { uf_cache = cache, uf_tmpl = rhs }) + | uf_expandable cache + = Just rhs +expandUnfolding_maybe _ = Nothing + +isCompulsoryUnfolding :: Unfolding -> Bool +isCompulsoryUnfolding (CoreUnfolding { uf_src = src }) = isCompulsorySource src +isCompulsoryUnfolding _ = False + +isStableUnfolding :: Unfolding -> Bool +-- True of unfoldings that should not be overwritten +-- by a CoreUnfolding for the RHS of a let-binding +isStableUnfolding (CoreUnfolding { uf_src = src }) = isStableSource src +isStableUnfolding (DFunUnfolding {}) = True +isStableUnfolding _ = False + +isStableUserUnfolding :: Unfolding -> Bool +-- True of unfoldings that arise from an INLINE or INLINEABLE pragma +isStableUserUnfolding (CoreUnfolding { uf_src = src }) = isStableUserSource src +isStableUserUnfolding _ = False + +isStableSystemUnfolding :: Unfolding -> Bool +-- True of unfoldings that arise from an INLINE or INLINEABLE pragma +isStableSystemUnfolding (CoreUnfolding { uf_src = src }) = isStableSystemSource src +isStableSystemUnfolding _ = False + +isInlineUnfolding :: Unfolding -> Bool +-- ^ True of a /stable/ unfolding that is +-- (a) always inlined; that is, with an `UnfWhen` guidance, or +-- (b) a DFunUnfolding which never needs to be inlined +isInlineUnfolding (CoreUnfolding { uf_src = src, uf_guidance = guidance }) + | isStableSource src + , UnfWhen {} <- guidance + = True + +isInlineUnfolding (DFunUnfolding {}) + = True + +-- Default case +isInlineUnfolding _ = False + + +-- | Only returns False if there is no unfolding information available at all +hasSomeUnfolding :: Unfolding -> Bool +hasSomeUnfolding NoUnfolding = False +hasSomeUnfolding BootUnfolding = False +hasSomeUnfolding _ = True + +isBootUnfolding :: Unfolding -> Bool +isBootUnfolding BootUnfolding = True +isBootUnfolding _ = False + +neverUnfoldGuidance :: UnfoldingGuidance -> Bool +neverUnfoldGuidance UnfNever = True +neverUnfoldGuidance _ = False + +hasCoreUnfolding :: Unfolding -> Bool +-- An unfolding "has Core" if it contains a Core expression, which +-- may mention free variables. See Note [Fragile unfoldings] +hasCoreUnfolding (CoreUnfolding {}) = True +hasCoreUnfolding (DFunUnfolding {}) = True +hasCoreUnfolding _ = False + -- NoUnfolding, BootUnfolding, OtherCon have no Core + +canUnfold :: Unfolding -> Bool +canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g) +canUnfold _ = False + +{- Note [Fragile unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An unfolding is "fragile" if it mentions free variables (and hence would +need substitution) or might be affected by optimisation. The non-fragile +ones are + + NoUnfolding, BootUnfolding + + OtherCon {} If we know this binder (say a lambda binder) will be + bound to an evaluated thing, we want to retain that + info in simpleOptExpr; see #13077. + +We consider even a StableUnfolding as fragile, because it needs substitution. + +Note [Stable unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~ +When you say + {-# INLINE f #-} + f x = <rhs> +you intend that calls (f e) are replaced by <rhs>[e/x] So we +should capture (\x.<rhs>) in the Unfolding of 'f', and never meddle +with it. Meanwhile, we can optimise <rhs> to our heart's content, +leaving the original unfolding intact in Unfolding of 'f'. For example + all xs = foldr (&&) True xs + any p = all . map p {-# INLINE any #-} +We optimise any's RHS fully, but leave the stable unfolding for `any` +saying "all . map p", which deforests well at the call site. + +So INLINE pragma gives rise to a stable unfolding, which captures the +original RHS. + +Moreover, it's only used when 'f' is applied to the +specified number of arguments; that is, the number of argument on +the LHS of the '=' sign in the original source definition. +For example, (.) is now defined in the libraries like this + {-# INLINE (.) #-} + (.) f g = \x -> f (g x) +so that it'll inline when applied to two arguments. If 'x' appeared +on the left, thus + (.) f g x = f (g x) +it'd only inline when applied to three arguments. This slightly-experimental +change was requested by Roman, but it seems to make sense. + +Note [OccInfo in unfoldings and rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In unfoldings and rules, we guarantee that the template is occ-analysed, +so that the occurrence info on the binders is correct. This is important, +because the Simplifier does not re-analyse the template when using it. If +the occurrence info is wrong + - We may get more simplifier iterations than necessary, because + once-occ info isn't there + - More seriously, we may get an infinite loop if there's a Rec + without a loop breaker marked + +-} diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs index a0d3bc9c44..96cb00d0eb 100644 --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -69,6 +69,7 @@ import GHC.Prelude import GHC.Platform import GHC.Core +import GHC.Core.Unfoldings import GHC.Core.Ppr import GHC.Core.DataCon import GHC.Core.Type as Type diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs index 98595f0403..e6c4803756 100644 --- a/compiler/GHC/CoreToIface.hs +++ b/compiler/GHC/CoreToIface.hs @@ -50,6 +50,7 @@ import GHC.Prelude import GHC.StgToCmm.Types import GHC.Core +import GHC.Core.Unfoldings import GHC.Core.TyCon hiding ( pprPromotionQuote ) import GHC.Core.Coercion.Axiom import GHC.Core.DataCon diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index 78ce8e16f1..0166de53f1 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -41,6 +41,7 @@ import GHC.Core.TyCon import GHC.Core.DataCon import GHC.Core.Opt.OccurAnal import GHC.Core.TyCo.Rep( UnivCoProvenance(..) ) +import GHC.Core.Unfoldings import GHC.Data.Maybe import GHC.Data.OrdList diff --git a/compiler/GHC/Driver/Config/Core/Lint.hs b/compiler/GHC/Driver/Config/Core/Lint.hs index 533f029c7b..81835a5619 100644 --- a/compiler/GHC/Driver/Config/Core/Lint.hs +++ b/compiler/GHC/Driver/Config/Core/Lint.hs @@ -16,6 +16,7 @@ import GHC.Driver.Session import GHC.Driver.Config.Diagnostic import GHC.Core +import GHC.Core.Rules import GHC.Core.Lint import GHC.Core.Lint.Interactive import GHC.Core.Opt.Pipeline.Types diff --git a/compiler/GHC/Driver/Config/Core/Opt/Simplify.hs b/compiler/GHC/Driver/Config/Core/Opt/Simplify.hs index 75ae439df3..47a9c5a39a 100644 --- a/compiler/GHC/Driver/Config/Core/Opt/Simplify.hs +++ b/compiler/GHC/Driver/Config/Core/Opt/Simplify.hs @@ -6,7 +6,7 @@ module GHC.Driver.Config.Core.Opt.Simplify import GHC.Prelude -import GHC.Core.Rules ( RuleBase ) +import GHC.Core.Rules.Apply ( RuleBase ) import GHC.Core.Opt.Pipeline.Types ( CoreToDo(..) ) import GHC.Core.Opt.Simplify ( SimplifyExprOpts(..), SimplifyOpts(..) ) import GHC.Core.Opt.Simplify.Env ( FloatEnable(..), SimplMode(..) ) diff --git a/compiler/GHC/Driver/Env.hs b/compiler/GHC/Driver/Env.hs index 492adc82cc..f3630d36a4 100644 --- a/compiler/GHC/Driver/Env.hs +++ b/compiler/GHC/Driver/Env.hs @@ -60,7 +60,7 @@ import GHC.Unit.Home.ModInfo import GHC.Unit.Env import GHC.Unit.External -import GHC.Core ( CoreRule ) +import GHC.Core.Rules ( CoreRule ) import GHC.Core.FamInstEnv import GHC.Core.InstEnv diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 255ffaf035..fb7b27081c 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -179,7 +179,7 @@ import GHC.Core.Opt.Pipeline.Types ( CoreToDo (..)) import GHC.Core.TyCon import GHC.Core.InstEnv import GHC.Core.FamInstEnv -import GHC.Core.Rules +import GHC.Core.Rules.Apply import GHC.Core.Stats import GHC.Core.LateCC (addLateCostCentresPgm) diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index 3c6ec71079..b493491efe 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -48,14 +48,16 @@ import GHC.Core.Type import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.TyCon ( tyConDataCons ) import GHC.Core +import GHC.Core.Rules import GHC.Core.FVs ( exprsSomeFreeVarsList, exprFreeVars ) import GHC.Core.SimpleOpt ( simpleOptPgm, simpleOptExpr ) import GHC.Core.Utils import GHC.Core.Unfold.Make +import GHC.Core.Unfoldings import GHC.Core.Coercion import GHC.Core.DataCon ( dataConWrapId ) import GHC.Core.Make -import GHC.Core.Rules +import GHC.Core.Rules.Apply import GHC.Core.Opt.Pipeline.Types ( CoreToDo(..) ) import GHC.Core.Ppr diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs index 4d594e833f..263ef8632d 100644 --- a/compiler/GHC/HsToCore/Binds.hs +++ b/compiler/GHC/HsToCore/Binds.hs @@ -39,6 +39,9 @@ import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs ) import GHC.Hs -- lots of things import GHC.Core -- lots of things +import GHC.Core.Rules +import GHC.Core.Orphans +import GHC.Core.Unfoldings import GHC.Core.SimpleOpt ( simpleOptExpr ) import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) import GHC.Core.Make @@ -51,7 +54,7 @@ import GHC.Core.TyCon import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.Multiplicity -import GHC.Core.Rules +import GHC.Core.Rules.Apply import GHC.Core.TyCo.Compare( eqType ) import GHC.Builtin.Names diff --git a/compiler/GHC/HsToCore/Errors/Types.hs b/compiler/GHC/HsToCore/Errors/Types.hs index 8f6586fb45..5f7723e937 100644 --- a/compiler/GHC/HsToCore/Errors/Types.hs +++ b/compiler/GHC/HsToCore/Errors/Types.hs @@ -6,7 +6,8 @@ module GHC.HsToCore.Errors.Types where import GHC.Prelude -import GHC.Core (CoreRule, CoreExpr, RuleName) +import GHC.Core (CoreExpr) +import GHC.Core.Rules (CoreRule, RuleName) import GHC.Core.DataCon import GHC.Core.Type import GHC.Driver.Session diff --git a/compiler/GHC/HsToCore/Pmc/Solver.hs b/compiler/GHC/HsToCore/Pmc/Solver.hs index b70c868c2f..0c520cdd24 100644 --- a/compiler/GHC/HsToCore/Pmc/Solver.hs +++ b/compiler/GHC/HsToCore/Pmc/Solver.hs @@ -59,6 +59,7 @@ import GHC.Types.Var.Set import GHC.Types.Unique.Supply import GHC.Core +import GHC.Core.Unfoldings import GHC.Core.FVs (exprFreeVars) import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.Map.Expr diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index bf7ae8e005..bf426875ee 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -75,7 +75,7 @@ import GHC.Builtin.Names import GHC.Builtin.Utils import GHC.Builtin.PrimOps ( allThePrimOps, primOpFixity, primOpOcc ) -import GHC.Core.Rules +import GHC.Core.Rules.Apply import GHC.Core.TyCon import GHC.Core.InstEnv import GHC.Core.FamInstEnv diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs index ac55220cbf..98b6107a09 100644 --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -37,6 +37,8 @@ import GHC.CoreToIface import qualified GHC.LanguageExtensions as LangExt import GHC.Core +import GHC.Core.Orphans +import GHC.Core.Rules import GHC.Core.Class import GHC.Core.TyCon import GHC.Core.Coercion.Axiom diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs index 886bc12192..997726bdfc 100644 --- a/compiler/GHC/Iface/Recomp.hs +++ b/compiler/GHC/Iface/Recomp.hs @@ -34,7 +34,7 @@ import GHC.Iface.Load import GHC.Iface.Recomp.Flags import GHC.Iface.Env -import GHC.Core +import GHC.Core.Orphans import GHC.Tc.Utils.Monad import GHC.Hs diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs index 4ff4ab7eee..b29552353b 100644 --- a/compiler/GHC/Iface/Syntax.hs +++ b/compiler/GHC/Iface/Syntax.hs @@ -49,7 +49,8 @@ import GHC.Builtin.Names ( unrestrictedFunTyConKey, liftedTypeKindTyConKey, import GHC.Types.Unique ( hasKey ) import GHC.Iface.Type import GHC.Iface.Recomp.Binary -import GHC.Core( IsOrphan, isOrphan, UnfoldingCache(..) ) +import GHC.Core.Orphans ( IsOrphan, isOrphan ) +import GHC.Core.Unfoldings ( UnfoldingCache(..) ) import GHC.Types.Demand import GHC.Types.Cpr import GHC.Core.Class diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index 327bb28412..0d298dca0f 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -23,8 +23,10 @@ import GHC.Tc.Types import GHC.Tc.Utils.Env import GHC.Core +import GHC.Core.Rules import GHC.Core.Unfold -- import GHC.Core.Unfold.Make +import GHC.Core.Unfoldings import GHC.Core.FVs import GHC.Core.Tidy import GHC.Core.Seq ( seqBinds ) diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index a69cc34a73..4fc787e89b 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -57,10 +57,12 @@ import GHC.Core.TyCo.Subst ( substTyCoVars ) import GHC.Core.InstEnv import GHC.Core.FamInstEnv import GHC.Core +import GHC.Core.Rules import GHC.Core.RoughMap( RoughMatchTc(..) ) import GHC.Core.Utils import GHC.Core.Unfold( calcUnfoldingGuidance ) import GHC.Core.Unfold.Make +import GHC.Core.Unfoldings import GHC.Core.Lint import GHC.Core.Make import GHC.Core.Class diff --git a/compiler/GHC/IfaceToCore.hs-boot b/compiler/GHC/IfaceToCore.hs-boot index 97124237c7..adc5a89f28 100644 --- a/compiler/GHC/IfaceToCore.hs-boot +++ b/compiler/GHC/IfaceToCore.hs-boot @@ -7,7 +7,7 @@ import GHC.Types.TyThing ( TyThing ) import GHC.Tc.Types ( IfL ) import GHC.Core.InstEnv ( ClsInst ) import GHC.Core.FamInstEnv ( FamInst ) -import GHC.Core ( CoreRule ) +import GHC.Core.Rules ( CoreRule ) import GHC.Types.CompleteMatch import GHC.Types.Annotations ( Annotation ) import GHC.Types.Name diff --git a/compiler/GHC/Plugins.hs b/compiler/GHC/Plugins.hs index 12ec3fead2..a07b7e7733 100644 --- a/compiler/GHC/Plugins.hs +++ b/compiler/GHC/Plugins.hs @@ -26,7 +26,7 @@ module GHC.Plugins , module GHC.Core.Make , module GHC.Core.FVs , module GHC.Core.Subst - , module GHC.Core.Rules + , module GHC.Core.Rules.Apply , module GHC.Types.Annotations , module GHC.Driver.Session , module GHC.Driver.Ppr @@ -96,7 +96,7 @@ import GHC.Core.FVs import GHC.Core.Subst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst, extendSubstInScopeSet ) -- These names are also exported by Type -import GHC.Core.Rules +import GHC.Core.Rules.Apply import GHC.Types.Annotations import GHC.Types.Meta diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs index 77d61941fc..948d67ccf5 100644 --- a/compiler/GHC/Tc/Gen/Sig.hs +++ b/compiler/GHC/Tc/Gen/Sig.hs @@ -49,7 +49,7 @@ import GHC.Tc.Utils.Instantiate( topInstantiate, tcInstTypeBndrs ) import GHC.Tc.Utils.Env( tcLookupId ) import GHC.Tc.Types.Evidence( HsWrapper, (<.>) ) -import GHC.Core( hasSomeUnfolding ) +import GHC.Core.Unfoldings ( hasSomeUnfolding ) import GHC.Core.Type ( mkTyVarBinders ) import GHC.Core.Multiplicity import GHC.Core.TyCo.Rep( mkNakedFunTy ) diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs index b8249bc363..53fca21c0a 100644 --- a/compiler/GHC/Tc/Utils/Instantiate.hs +++ b/compiler/GHC/Tc/Utils/Instantiate.hs @@ -51,7 +51,8 @@ import GHC.Hs.Syn.Type ( hsLitType ) import GHC.Core.InstEnv import GHC.Core.Predicate -import GHC.Core ( Expr(..), isOrphan ) -- For the Coercion constructor +import GHC.Core ( Expr(Coercion) ) +import GHC.Core.Orphans ( isOrphan ) import GHC.Core.Type import GHC.Core.TyCo.Ppr ( debugPprType ) import GHC.Core.Class( Class ) diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs index 1ad6b608fc..907071a526 100644 --- a/compiler/GHC/Types/Basic.hs +++ b/compiler/GHC/Types/Basic.hs @@ -1490,7 +1490,7 @@ The main effects of CONLIKE are: - A CoreUnfolding has a field that caches exprIsExpandable - The rule matcher consults this field. See - Note [Expanding variables] in GHC.Core.Rules. + Note [Expanding variables] in GHC.Core.Rules.Apply. Note [OPAQUE pragma] ~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs index 4744147dcf..6d68d8013e 100644 --- a/compiler/GHC/Types/Id.hs +++ b/compiler/GHC/Types/Id.hs @@ -126,8 +126,12 @@ module GHC.Types.Id ( import GHC.Prelude -import GHC.Core ( CoreRule, isStableUnfolding, evaldUnfolding, - isCompulsoryUnfolding, Unfolding( NoUnfolding ), isEvaldUnfolding, hasSomeUnfolding, noUnfolding ) +import GHC.Core.Unfoldings ( Unfolding( NoUnfolding ) + , isStableUnfolding, evaldUnfolding + , isCompulsoryUnfolding, isEvaldUnfolding + , hasSomeUnfolding, noUnfolding + ) +import GHC.Core.Rules( CoreRule) import GHC.Types.Id.Info import GHC.Types.Basic diff --git a/compiler/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs index edd1ba0da0..38558ef471 100644 --- a/compiler/GHC/Types/Id/Info.hs +++ b/compiler/GHC/Types/Id/Info.hs @@ -87,7 +87,8 @@ module GHC.Types.Id.Info ( import GHC.Prelude -import GHC.Core +import GHC.Core.Rules +import GHC.Core.Unfoldings import GHC.Core.Class import {-# SOURCE #-} GHC.Builtin.PrimOps (PrimOp) import GHC.Types.Name diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs index 4baa335db1..12fe5a9695 100644 --- a/compiler/GHC/Types/Id/Make.hs +++ b/compiler/GHC/Types/Id/Make.hs @@ -48,6 +48,8 @@ import GHC.Builtin.Names import GHC.Core import GHC.Core.Opt.Arity( typeOneShot ) +import GHC.Core.Rules +import GHC.Core.Unfoldings import GHC.Core.Type import GHC.Core.Multiplicity import GHC.Core.TyCo.Rep diff --git a/compiler/GHC/Unit/External.hs b/compiler/GHC/Unit/External.hs index ab5363749c..225bf5d6ba 100644 --- a/compiler/GHC/Unit/External.hs +++ b/compiler/GHC/Unit/External.hs @@ -24,7 +24,7 @@ import GHC.Unit.Module.ModIface import GHC.Core.FamInstEnv import GHC.Core.InstEnv ( InstEnv, emptyInstEnv ) import GHC.Core.Opt.ConstantFold -import GHC.Core.Rules ( RuleBase, mkRuleBase) +import GHC.Core.Rules.Apply ( RuleBase, mkRuleBase) import GHC.Types.Annotations ( AnnEnv, emptyAnnEnv ) import GHC.Types.CompleteMatch diff --git a/compiler/GHC/Unit/Module/ModDetails.hs b/compiler/GHC/Unit/Module/ModDetails.hs index 913f7e2087..47af59b712 100644 --- a/compiler/GHC/Unit/Module/ModDetails.hs +++ b/compiler/GHC/Unit/Module/ModDetails.hs @@ -4,7 +4,7 @@ module GHC.Unit.Module.ModDetails ) where -import GHC.Core ( CoreRule ) +import GHC.Core.Rules ( CoreRule ) import GHC.Core.FamInstEnv import GHC.Core.InstEnv ( InstEnv, emptyInstEnv ) diff --git a/compiler/GHC/Unit/Module/ModGuts.hs b/compiler/GHC/Unit/Module/ModGuts.hs index d54e836d71..f67ad8296c 100644 --- a/compiler/GHC/Unit/Module/ModGuts.hs +++ b/compiler/GHC/Unit/Module/ModGuts.hs @@ -18,7 +18,8 @@ import GHC.Unit.Module.Warnings import GHC.Core.InstEnv ( InstEnv, ClsInst ) import GHC.Core.FamInstEnv -import GHC.Core ( CoreProgram, CoreRule ) +import GHC.Core ( CoreProgram ) +import GHC.Core.Rules ( CoreRule ) import GHC.Core.TyCon import GHC.Core.PatSyn @@ -67,7 +68,7 @@ data ModGuts -- ^ Family instances declared in this module mg_patsyns :: ![PatSyn], -- ^ Pattern synonyms declared in this module mg_rules :: ![CoreRule], -- ^ Before the core pipeline starts, contains - -- See Note [Overall plumbing for rules] in "GHC.Core.Rules" + -- See Note [Overall plumbing for rules] in "GHC.Core.Rules.Apply" mg_binds :: !CoreProgram, -- ^ Bindings for this module mg_foreign :: !ForeignStubs, -- ^ Foreign exports declared in this module mg_foreign_files :: ![(ForeignSrcLang, FilePath)], diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 2bb41c0fc3..6f0ad32e12 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -291,6 +291,7 @@ Library GHC.Cmm.Type GHC.Cmm.Utils GHC.Core + GHC.Core.Annotated GHC.Core.Class GHC.Core.Coercion GHC.Core.Coercion.Axiom @@ -335,12 +336,14 @@ Library GHC.Core.Opt.Stats GHC.Core.Opt.WorkWrap GHC.Core.Opt.WorkWrap.Utils + GHC.Core.Orphans GHC.Core.PatSyn GHC.Core.Ppr GHC.Types.TyThing.Ppr GHC.Core.Predicate GHC.Core.Reduction GHC.Core.Rules + GHC.Core.Rules.Apply GHC.Core.Rules.Config GHC.Core.Seq GHC.Core.SimpleOpt @@ -364,6 +367,7 @@ Library GHC.Core.RoughMap GHC.Core.Unfold GHC.Core.Unfold.Make + GHC.Core.Unfoldings GHC.Core.Unify GHC.Core.UsageEnv GHC.Core.Utils diff --git a/testsuite/tests/count-deps/CountDepsAst.stdout b/testsuite/tests/count-deps/CountDepsAst.stdout index 384243cd93..05ab30f1be 100644 --- a/testsuite/tests/count-deps/CountDepsAst.stdout +++ b/testsuite/tests/count-deps/CountDepsAst.stdout @@ -56,6 +56,7 @@ GHC.Core.Predicate GHC.Core.Reduction GHC.Core.RoughMap GHC.Core.Rules +GHC.Core.Rules.Apply GHC.Core.Rules.Config GHC.Core.Seq GHC.Core.SimpleOpt diff --git a/testsuite/tests/count-deps/CountDepsParser.stdout b/testsuite/tests/count-deps/CountDepsParser.stdout index f00c74ce8d..c07bd598fc 100644 --- a/testsuite/tests/count-deps/CountDepsParser.stdout +++ b/testsuite/tests/count-deps/CountDepsParser.stdout @@ -56,6 +56,7 @@ GHC.Core.Predicate GHC.Core.Reduction GHC.Core.RoughMap GHC.Core.Rules +GHC.Core.Rules.Apply GHC.Core.Rules.Config GHC.Core.Seq GHC.Core.SimpleOpt |