module GHC.Core.Rules (
emptyRuleBase, mkRuleBase, extendRuleBaseList,
pprRuleBase, extendRuleEnv,
ruleCheckProgram,
extendRuleInfo, addRuleInfo,
addIdSpecialisations,
rulesOfBinds, getRules, pprRulesForUser,
lookupRule, mkRule, roughTopNames, initRuleOpts
) where
import GHC.Prelude
import GHC.Driver.Session ( DynFlags, gopt, targetPlatform, homeUnitId_ )
import GHC.Driver.Flags
import GHC.Unit.Types ( primUnitId, bignumUnitId )
import GHC.Unit.Module ( Module )
import GHC.Unit.Module.Env
import GHC.Core
import GHC.Core.Subst
import GHC.Core.SimpleOpt ( exprIsLambda_maybe )
import GHC.Core.FVs ( exprFreeVars, exprsFreeVars, bindFreeVars
, rulesFreeVarsDSet, exprsOrphNames, exprFreeVarsList )
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, TCvSubst, extendTvSubst, extendCvSubst
, mkEmptyTCvSubst, substTy, getTyVar_maybe )
import GHC.Core.Coercion as Coercion
import GHC.Core.Tidy ( tidyRules )
import GHC.Core.Map.Expr ( eqCoreExpr )
import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )
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.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.Trace
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 )
mkRule :: Module -> Bool -> Bool -> RuleName -> Activation
-> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule
mkRule :: Module
-> Bool
-> Bool
-> RuleName
-> Activation
-> Name
-> [Var]
-> [CoreExpr]
-> CoreExpr
-> CoreRule
mkRule Module
this_mod Bool
is_auto Bool
is_local RuleName
name Activation
act Name
fn [Var]
bndrs [CoreExpr]
args CoreExpr
rhs
= Rule { ru_name :: RuleName
ru_name = RuleName
name
, ru_act :: Activation
ru_act = Activation
act
, ru_fn :: Name
ru_fn = Name
fn
, ru_bndrs :: [Var]
ru_bndrs = [Var]
bndrs
, ru_args :: [CoreExpr]
ru_args = [CoreExpr]
args
, ru_rhs :: CoreExpr
ru_rhs = CoreExpr -> CoreExpr
occurAnalyseExpr CoreExpr
rhs
, ru_rough :: [Maybe Name]
ru_rough = [CoreExpr] -> [Maybe Name]
roughTopNames [CoreExpr]
args
, ru_origin :: Module
ru_origin = Module
this_mod
, ru_orphan :: IsOrphan
ru_orphan = IsOrphan
orph
, ru_auto :: Bool
ru_auto = Bool
is_auto
, ru_local :: Bool
ru_local = Bool
is_local }
where
lhs_names :: NameSet
lhs_names = NameSet -> Name -> NameSet
extendNameSet ([CoreExpr] -> NameSet
exprsOrphNames [CoreExpr]
args) Name
fn
local_lhs_names :: NameSet
local_lhs_names = (Name -> Bool) -> NameSet -> NameSet
filterNameSet (Module -> Name -> Bool
nameIsLocalOrFrom Module
this_mod) NameSet
lhs_names
orph :: IsOrphan
orph = NameSet -> IsOrphan
chooseOrphanAnchor NameSet
local_lhs_names
roughTopNames :: [CoreExpr] -> [Maybe Name]
roughTopNames :: [CoreExpr] -> [Maybe Name]
roughTopNames [CoreExpr]
args = (CoreExpr -> Maybe Name) -> [CoreExpr] -> [Maybe Name]
forall a b. (a -> b) -> [a] -> [b]
map CoreExpr -> Maybe Name
roughTopName [CoreExpr]
args
roughTopName :: CoreExpr -> Maybe Name
roughTopName :: CoreExpr -> Maybe Name
roughTopName (Type Kind
ty) = case HasCallStack => Kind -> Maybe (TyCon, [Kind])
Kind -> Maybe (TyCon, [Kind])
tcSplitTyConApp_maybe Kind
ty of
Just (TyCon
tc,[Kind]
_) -> Name -> Maybe Name
forall a. a -> Maybe a
Just (TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
tc)
Maybe (TyCon, [Kind])
Nothing -> Maybe Name
forall a. Maybe a
Nothing
roughTopName (Coercion Coercion
_) = Maybe Name
forall a. Maybe a
Nothing
roughTopName (App CoreExpr
f CoreExpr
_) = CoreExpr -> Maybe Name
roughTopName CoreExpr
f
roughTopName (Var Var
f) | Var -> Bool
isGlobalId Var
f
, Var -> Bool
isDataConWorkId Var
f Bool -> Bool -> Bool
|| Var -> Arity
idArity Var
f Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
> Arity
0
= Name -> Maybe Name
forall a. a -> Maybe a
Just (Var -> Name
idName Var
f)
roughTopName (Tick CoreTickish
t CoreExpr
e) | CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreTickish
t
= CoreExpr -> Maybe Name
roughTopName CoreExpr
e
roughTopName CoreExpr
_ = Maybe Name
forall a. Maybe a
Nothing
ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool
ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool
ruleCantMatch (Just Name
n1 : [Maybe Name]
ts) (Just Name
n2 : [Maybe Name]
as) = Name
n1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
n2 Bool -> Bool -> Bool
|| [Maybe Name] -> [Maybe Name] -> Bool
ruleCantMatch [Maybe Name]
ts [Maybe Name]
as
ruleCantMatch (Maybe Name
_ : [Maybe Name]
ts) (Maybe Name
_ : [Maybe Name]
as) = [Maybe Name] -> [Maybe Name] -> Bool
ruleCantMatch [Maybe Name]
ts [Maybe Name]
as
ruleCantMatch [Maybe Name]
_ [Maybe Name]
_ = Bool
False
pprRulesForUser :: [CoreRule] -> SDoc
pprRulesForUser :: [CoreRule] -> SDoc
pprRulesForUser [CoreRule]
rules
= PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultUserStyle (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
[CoreRule] -> SDoc
pprRules ([CoreRule] -> SDoc) -> [CoreRule] -> SDoc
forall a b. (a -> b) -> a -> b
$
(CoreRule -> CoreRule -> Ordering) -> [CoreRule] -> [CoreRule]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (RuleName -> RuleName -> Ordering
lexicalCompareFS (RuleName -> RuleName -> Ordering)
-> (CoreRule -> RuleName) -> CoreRule -> CoreRule -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` CoreRule -> RuleName
ruleName) ([CoreRule] -> [CoreRule]) -> [CoreRule] -> [CoreRule]
forall a b. (a -> b) -> a -> b
$
TidyEnv -> [CoreRule] -> [CoreRule]
tidyRules TidyEnv
emptyTidyEnv [CoreRule]
rules
extendRuleInfo :: RuleInfo -> [CoreRule] -> RuleInfo
extendRuleInfo :: RuleInfo -> [CoreRule] -> RuleInfo
extendRuleInfo (RuleInfo [CoreRule]
rs1 DVarSet
fvs1) [CoreRule]
rs2
= [CoreRule] -> DVarSet -> RuleInfo
RuleInfo ([CoreRule]
rs2 [CoreRule] -> [CoreRule] -> [CoreRule]
forall a. [a] -> [a] -> [a]
++ [CoreRule]
rs1) ([CoreRule] -> DVarSet
rulesFreeVarsDSet [CoreRule]
rs2 DVarSet -> DVarSet -> DVarSet
`unionDVarSet` DVarSet
fvs1)
addRuleInfo :: RuleInfo -> RuleInfo -> RuleInfo
addRuleInfo :: RuleInfo -> RuleInfo -> RuleInfo
addRuleInfo (RuleInfo [CoreRule]
rs1 DVarSet
fvs1) (RuleInfo [CoreRule]
rs2 DVarSet
fvs2)
= [CoreRule] -> DVarSet -> RuleInfo
RuleInfo ([CoreRule]
rs1 [CoreRule] -> [CoreRule] -> [CoreRule]
forall a. [a] -> [a] -> [a]
++ [CoreRule]
rs2) (DVarSet
fvs1 DVarSet -> DVarSet -> DVarSet
`unionDVarSet` DVarSet
fvs2)
addIdSpecialisations :: Id -> [CoreRule] -> Id
addIdSpecialisations :: Var -> [CoreRule] -> Var
addIdSpecialisations Var
id [CoreRule]
rules
| [CoreRule] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreRule]
rules
= Var
id
| Bool
otherwise
= Var -> RuleInfo -> Var
setIdSpecialisation Var
id (RuleInfo -> Var) -> RuleInfo -> Var
forall a b. (a -> b) -> a -> b
$
RuleInfo -> [CoreRule] -> RuleInfo
extendRuleInfo (Var -> RuleInfo
idSpecialisation Var
id) [CoreRule]
rules
rulesOfBinds :: [CoreBind] -> [CoreRule]
rulesOfBinds :: [CoreBind] -> [CoreRule]
rulesOfBinds [CoreBind]
binds = (CoreBind -> [CoreRule]) -> [CoreBind] -> [CoreRule]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Var -> [CoreRule]) -> [Var] -> [CoreRule]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Var -> [CoreRule]
idCoreRules ([Var] -> [CoreRule])
-> (CoreBind -> [Var]) -> CoreBind -> [CoreRule]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBind -> [Var]
forall b. Bind b -> [b]
bindersOf) [CoreBind]
binds
getRules :: RuleEnv -> Id -> [CoreRule]
getRules :: RuleEnv -> Var -> [CoreRule]
getRules (RuleEnv { re_base :: RuleEnv -> [RuleBase]
re_base = [RuleBase]
rule_base, re_visible_orphs :: RuleEnv -> ModuleSet
re_visible_orphs = ModuleSet
orphs }) Var
fn
= Var -> [CoreRule]
idCoreRules Var
fn [CoreRule] -> [CoreRule] -> [CoreRule]
forall a. [a] -> [a] -> [a]
++ (RuleBase -> [CoreRule]) -> [RuleBase] -> [CoreRule]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap RuleBase -> [CoreRule]
imp_rules [RuleBase]
rule_base
where
imp_rules :: RuleBase -> [CoreRule]
imp_rules RuleBase
rb = (CoreRule -> Bool) -> [CoreRule] -> [CoreRule]
forall a. (a -> Bool) -> [a] -> [a]
filter (ModuleSet -> CoreRule -> Bool
ruleIsVisible ModuleSet
orphs) (RuleBase -> Name -> Maybe [CoreRule]
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv RuleBase
rb (Var -> Name
idName Var
fn) Maybe [CoreRule] -> [CoreRule] -> [CoreRule]
forall a. Maybe a -> a -> a
`orElse` [])
ruleIsVisible :: ModuleSet -> CoreRule -> Bool
ruleIsVisible :: ModuleSet -> CoreRule -> Bool
ruleIsVisible ModuleSet
_ BuiltinRule{} = Bool
True
ruleIsVisible ModuleSet
vis_orphs Rule { ru_orphan :: CoreRule -> IsOrphan
ru_orphan = IsOrphan
orph, ru_origin :: CoreRule -> Module
ru_origin = Module
origin }
= IsOrphan -> Bool
notOrphan IsOrphan
orph Bool -> Bool -> Bool
|| Module
origin Module -> ModuleSet -> Bool
`elemModuleSet` ModuleSet
vis_orphs
emptyRuleBase :: RuleBase
emptyRuleBase :: RuleBase
emptyRuleBase = RuleBase
forall a. NameEnv a
emptyNameEnv
mkRuleBase :: [CoreRule] -> RuleBase
mkRuleBase :: [CoreRule] -> RuleBase
mkRuleBase [CoreRule]
rules = RuleBase -> [CoreRule] -> RuleBase
extendRuleBaseList RuleBase
emptyRuleBase [CoreRule]
rules
extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase
extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase
extendRuleBaseList RuleBase
rule_base [CoreRule]
new_guys
= (RuleBase -> CoreRule -> RuleBase)
-> RuleBase -> [CoreRule] -> RuleBase
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' RuleBase -> CoreRule -> RuleBase
extendRuleBase RuleBase
rule_base [CoreRule]
new_guys
extendRuleBase :: RuleBase -> CoreRule -> RuleBase
extendRuleBase :: RuleBase -> CoreRule -> RuleBase
extendRuleBase RuleBase
rule_base CoreRule
rule
= (CoreRule -> [CoreRule] -> [CoreRule])
-> (CoreRule -> [CoreRule])
-> RuleBase
-> Name
-> CoreRule
-> RuleBase
forall a b.
(a -> b -> b) -> (a -> b) -> NameEnv b -> Name -> a -> NameEnv b
extendNameEnv_Acc (:) CoreRule -> [CoreRule]
forall a. a -> [a]
Utils.singleton RuleBase
rule_base (CoreRule -> Name
ruleIdName CoreRule
rule) CoreRule
rule
extendRuleEnv :: RuleEnv -> RuleBase -> RuleEnv
extendRuleEnv :: RuleEnv -> RuleBase -> RuleEnv
extendRuleEnv (RuleEnv [RuleBase]
rules ModuleSet
orphs) RuleBase
rb = ([RuleBase] -> ModuleSet -> RuleEnv
RuleEnv (RuleBase
rbRuleBase -> [RuleBase] -> [RuleBase]
forall a. a -> [a] -> [a]
:[RuleBase]
rules) ModuleSet
orphs)
pprRuleBase :: RuleBase -> SDoc
pprRuleBase :: RuleBase -> SDoc
pprRuleBase RuleBase
rules = RuleBase -> ([[CoreRule]] -> SDoc) -> SDoc
forall key a. UniqFM key a -> ([a] -> SDoc) -> SDoc
pprUFM RuleBase
rules (([[CoreRule]] -> SDoc) -> SDoc) -> ([[CoreRule]] -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \[[CoreRule]]
rss ->
[SDoc] -> SDoc
vcat [ [CoreRule] -> SDoc
pprRules (TidyEnv -> [CoreRule] -> [CoreRule]
tidyRules TidyEnv
emptyTidyEnv [CoreRule]
rs)
| [CoreRule]
rs <- [[CoreRule]]
rss ]
lookupRule :: RuleOpts -> InScopeEnv
-> (Activation -> Bool)
-> Id
-> [CoreExpr]
-> [CoreRule]
-> Maybe (CoreRule, CoreExpr)
lookupRule :: RuleOpts
-> InScopeEnv
-> (Activation -> Bool)
-> Var
-> [CoreExpr]
-> [CoreRule]
-> Maybe (CoreRule, CoreExpr)
lookupRule RuleOpts
opts rule_env :: InScopeEnv
rule_env@(InScopeSet
in_scope,IdUnfoldingFun
_) Activation -> Bool
is_active Var
fn [CoreExpr]
args [CoreRule]
rules
=
case [(CoreRule, CoreExpr)] -> [CoreRule] -> [(CoreRule, CoreExpr)]
go [] [CoreRule]
rules of
[] -> Maybe (CoreRule, CoreExpr)
forall a. Maybe a
Nothing
((CoreRule, CoreExpr)
m:[(CoreRule, CoreExpr)]
ms) -> (CoreRule, CoreExpr) -> Maybe (CoreRule, CoreExpr)
forall a. a -> Maybe a
Just (InScopeSet
-> (Var, [CoreExpr])
-> (CoreRule, CoreExpr)
-> [(CoreRule, CoreExpr)]
-> (CoreRule, CoreExpr)
findBest InScopeSet
in_scope (Var
fn,[CoreExpr]
args') (CoreRule, CoreExpr)
m [(CoreRule, CoreExpr)]
ms)
where
rough_args :: [Maybe Name]
rough_args = (CoreExpr -> Maybe Name) -> [CoreExpr] -> [Maybe Name]
forall a b. (a -> b) -> [a] -> [b]
map CoreExpr -> Maybe Name
roughTopName [CoreExpr]
args
args' :: [CoreExpr]
args' = (CoreExpr -> CoreExpr) -> [CoreExpr] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map ((CoreTickish -> Bool) -> CoreExpr -> CoreExpr
forall b. (CoreTickish -> Bool) -> Expr b -> Expr b
stripTicksTopE CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable) [CoreExpr]
args
ticks :: [CoreTickish]
ticks = (CoreExpr -> [CoreTickish]) -> [CoreExpr] -> [CoreTickish]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((CoreTickish -> Bool) -> CoreExpr -> [CoreTickish]
forall b. (CoreTickish -> Bool) -> Expr b -> [CoreTickish]
stripTicksTopT CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable) [CoreExpr]
args
go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)]
go :: [(CoreRule, CoreExpr)] -> [CoreRule] -> [(CoreRule, CoreExpr)]
go [(CoreRule, CoreExpr)]
ms [] = [(CoreRule, CoreExpr)]
ms
go [(CoreRule, CoreExpr)]
ms (CoreRule
r:[CoreRule]
rs)
| Just CoreExpr
e <- RuleOpts
-> InScopeEnv
-> (Activation -> Bool)
-> Var
-> [CoreExpr]
-> [Maybe Name]
-> CoreRule
-> Maybe CoreExpr
matchRule RuleOpts
opts InScopeEnv
rule_env Activation -> Bool
is_active Var
fn [CoreExpr]
args' [Maybe Name]
rough_args CoreRule
r
= [(CoreRule, CoreExpr)] -> [CoreRule] -> [(CoreRule, CoreExpr)]
go ((CoreRule
r,[CoreTickish] -> CoreExpr -> CoreExpr
mkTicks [CoreTickish]
ticks CoreExpr
e)(CoreRule, CoreExpr)
-> [(CoreRule, CoreExpr)] -> [(CoreRule, CoreExpr)]
forall a. a -> [a] -> [a]
:[(CoreRule, CoreExpr)]
ms) [CoreRule]
rs
| Bool
otherwise
=
[(CoreRule, CoreExpr)] -> [CoreRule] -> [(CoreRule, CoreExpr)]
go [(CoreRule, CoreExpr)]
ms [CoreRule]
rs
findBest :: InScopeSet -> (Id, [CoreExpr])
-> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr)
findBest :: InScopeSet
-> (Var, [CoreExpr])
-> (CoreRule, CoreExpr)
-> [(CoreRule, CoreExpr)]
-> (CoreRule, CoreExpr)
findBest InScopeSet
_ (Var, [CoreExpr])
_ (CoreRule
rule,CoreExpr
ans) [] = (CoreRule
rule,CoreExpr
ans)
findBest InScopeSet
in_scope (Var, [CoreExpr])
target (CoreRule
rule1,CoreExpr
ans1) ((CoreRule
rule2,CoreExpr
ans2):[(CoreRule, CoreExpr)]
prs)
| InScopeSet -> CoreRule -> CoreRule -> Bool
isMoreSpecific InScopeSet
in_scope CoreRule
rule1 CoreRule
rule2 = InScopeSet
-> (Var, [CoreExpr])
-> (CoreRule, CoreExpr)
-> [(CoreRule, CoreExpr)]
-> (CoreRule, CoreExpr)
findBest InScopeSet
in_scope (Var, [CoreExpr])
target (CoreRule
rule1,CoreExpr
ans1) [(CoreRule, CoreExpr)]
prs
| InScopeSet -> CoreRule -> CoreRule -> Bool
isMoreSpecific InScopeSet
in_scope CoreRule
rule2 CoreRule
rule1 = InScopeSet
-> (Var, [CoreExpr])
-> (CoreRule, CoreExpr)
-> [(CoreRule, CoreExpr)]
-> (CoreRule, CoreExpr)
findBest InScopeSet
in_scope (Var, [CoreExpr])
target (CoreRule
rule2,CoreExpr
ans2) [(CoreRule, CoreExpr)]
prs
| Bool
debugIsOn = let pp_rule :: CoreRule -> SDoc
pp_rule CoreRule
rule
= SDoc -> SDoc -> SDoc
ifPprDebug (CoreRule -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreRule
rule)
(SDoc -> SDoc
doubleQuotes (RuleName -> SDoc
ftext (CoreRule -> RuleName
ruleName CoreRule
rule)))
in String -> SDoc -> (CoreRule, CoreExpr) -> (CoreRule, CoreExpr)
forall a. String -> SDoc -> a -> a
pprTrace String
"Rules.findBest: rule overlap (Rule 1 wins)"
([SDoc] -> SDoc
vcat [ SDoc -> SDoc
whenPprDebug (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Expression to match:" SDoc -> SDoc -> SDoc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
fn
SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
sep ((CoreExpr -> SDoc) -> [CoreExpr] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreExpr]
args)
, String -> SDoc
text String
"Rule 1:" SDoc -> SDoc -> SDoc
<+> CoreRule -> SDoc
pp_rule CoreRule
rule1
, String -> SDoc
text String
"Rule 2:" SDoc -> SDoc -> SDoc
<+> CoreRule -> SDoc
pp_rule CoreRule
rule2]) ((CoreRule, CoreExpr) -> (CoreRule, CoreExpr))
-> (CoreRule, CoreExpr) -> (CoreRule, CoreExpr)
forall a b. (a -> b) -> a -> b
$
InScopeSet
-> (Var, [CoreExpr])
-> (CoreRule, CoreExpr)
-> [(CoreRule, CoreExpr)]
-> (CoreRule, CoreExpr)
findBest InScopeSet
in_scope (Var, [CoreExpr])
target (CoreRule
rule1,CoreExpr
ans1) [(CoreRule, CoreExpr)]
prs
| Bool
otherwise = InScopeSet
-> (Var, [CoreExpr])
-> (CoreRule, CoreExpr)
-> [(CoreRule, CoreExpr)]
-> (CoreRule, CoreExpr)
findBest InScopeSet
in_scope (Var, [CoreExpr])
target (CoreRule
rule1,CoreExpr
ans1) [(CoreRule, CoreExpr)]
prs
where
(Var
fn,[CoreExpr]
args) = (Var, [CoreExpr])
target
isMoreSpecific :: InScopeSet -> CoreRule -> CoreRule -> Bool
isMoreSpecific :: InScopeSet -> CoreRule -> CoreRule -> Bool
isMoreSpecific InScopeSet
_ (BuiltinRule {}) CoreRule
_ = Bool
False
isMoreSpecific InScopeSet
_ (Rule {}) (BuiltinRule {}) = Bool
True
isMoreSpecific InScopeSet
in_scope (Rule { ru_bndrs :: CoreRule -> [Var]
ru_bndrs = [Var]
bndrs1, ru_args :: CoreRule -> [CoreExpr]
ru_args = [CoreExpr]
args1 })
(Rule { ru_bndrs :: CoreRule -> [Var]
ru_bndrs = [Var]
bndrs2, ru_args :: CoreRule -> [CoreExpr]
ru_args = [CoreExpr]
args2
, ru_name :: CoreRule -> RuleName
ru_name = RuleName
rule_name2, ru_rhs :: CoreRule -> CoreExpr
ru_rhs = CoreExpr
rhs2 })
= Maybe CoreExpr -> Bool
forall a. Maybe a -> Bool
isJust (InScopeEnv
-> RuleName
-> [Var]
-> [CoreExpr]
-> [CoreExpr]
-> CoreExpr
-> Maybe CoreExpr
matchN (InScopeSet
full_in_scope, IdUnfoldingFun
forall {p}. p -> Unfolding
id_unfolding_fun)
RuleName
rule_name2 [Var]
bndrs2 [CoreExpr]
args2 [CoreExpr]
args1 CoreExpr
rhs2)
where
id_unfolding_fun :: p -> Unfolding
id_unfolding_fun p
_ = Unfolding
NoUnfolding
full_in_scope :: InScopeSet
full_in_scope = InScopeSet
in_scope InScopeSet -> [Var] -> InScopeSet
`extendInScopeSetList` [Var]
bndrs1
noBlackList :: Activation -> Bool
noBlackList :: Activation -> Bool
noBlackList Activation
_ = Bool
False
matchRule :: RuleOpts -> InScopeEnv -> (Activation -> Bool)
-> Id -> [CoreExpr] -> [Maybe Name]
-> CoreRule -> Maybe CoreExpr
matchRule :: RuleOpts
-> InScopeEnv
-> (Activation -> Bool)
-> Var
-> [CoreExpr]
-> [Maybe Name]
-> CoreRule
-> Maybe CoreExpr
matchRule RuleOpts
opts InScopeEnv
rule_env Activation -> Bool
_is_active Var
fn [CoreExpr]
args [Maybe Name]
_rough_args
(BuiltinRule { ru_try :: CoreRule -> RuleFun
ru_try = RuleFun
match_fn })
= case RuleFun
match_fn RuleOpts
opts InScopeEnv
rule_env Var
fn [CoreExpr]
args of
Maybe CoreExpr
Nothing -> Maybe CoreExpr
forall a. Maybe a
Nothing
Just CoreExpr
expr -> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just CoreExpr
expr
matchRule RuleOpts
_ InScopeEnv
rule_env Activation -> Bool
is_active Var
_ [CoreExpr]
args [Maybe Name]
rough_args
(Rule { ru_name :: CoreRule -> RuleName
ru_name = RuleName
rule_name, ru_act :: CoreRule -> Activation
ru_act = Activation
act, ru_rough :: CoreRule -> [Maybe Name]
ru_rough = [Maybe Name]
tpl_tops
, ru_bndrs :: CoreRule -> [Var]
ru_bndrs = [Var]
tpl_vars, ru_args :: CoreRule -> [CoreExpr]
ru_args = [CoreExpr]
tpl_args, ru_rhs :: CoreRule -> CoreExpr
ru_rhs = CoreExpr
rhs })
| Bool -> Bool
not (Activation -> Bool
is_active Activation
act) = Maybe CoreExpr
forall a. Maybe a
Nothing
| [Maybe Name] -> [Maybe Name] -> Bool
ruleCantMatch [Maybe Name]
tpl_tops [Maybe Name]
rough_args = Maybe CoreExpr
forall a. Maybe a
Nothing
| Bool
otherwise = InScopeEnv
-> RuleName
-> [Var]
-> [CoreExpr]
-> [CoreExpr]
-> CoreExpr
-> Maybe CoreExpr
matchN InScopeEnv
rule_env RuleName
rule_name [Var]
tpl_vars [CoreExpr]
tpl_args [CoreExpr]
args CoreExpr
rhs
initRuleOpts :: DynFlags -> RuleOpts
initRuleOpts :: DynFlags -> RuleOpts
initRuleOpts DynFlags
dflags = RuleOpts
{ roPlatform :: Platform
roPlatform = DynFlags -> Platform
targetPlatform DynFlags
dflags
, roNumConstantFolding :: Bool
roNumConstantFolding = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_NumConstantFolding DynFlags
dflags
, roExcessRationalPrecision :: Bool
roExcessRationalPrecision = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExcessPrecision DynFlags
dflags
, roBignumRules :: Bool
roBignumRules = DynFlags -> UnitId
homeUnitId_ DynFlags
dflags UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
/= UnitId
primUnitId
Bool -> Bool -> Bool
&& DynFlags -> UnitId
homeUnitId_ DynFlags
dflags UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
/= UnitId
bignumUnitId
}
matchN :: InScopeEnv
-> RuleName -> [Var] -> [CoreExpr]
-> [CoreExpr] -> CoreExpr
-> Maybe CoreExpr
matchN :: InScopeEnv
-> RuleName
-> [Var]
-> [CoreExpr]
-> [CoreExpr]
-> CoreExpr
-> Maybe CoreExpr
matchN (InScopeSet
in_scope, IdUnfoldingFun
id_unf) RuleName
rule_name [Var]
tmpl_vars [CoreExpr]
tmpl_es [CoreExpr]
target_es CoreExpr
rhs
= do { RuleSubst
rule_subst <- RuleMatchEnv
-> RuleSubst -> [CoreExpr] -> [CoreExpr] -> Maybe RuleSubst
match_exprs RuleMatchEnv
init_menv RuleSubst
emptyRuleSubst [CoreExpr]
tmpl_es [CoreExpr]
target_es
; let (TCvSubst
_, [CoreExpr]
matched_es) = (TCvSubst -> (Var, Var) -> (TCvSubst, CoreExpr))
-> TCvSubst -> [(Var, Var)] -> (TCvSubst, [CoreExpr])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (RuleSubst -> TCvSubst -> (Var, Var) -> (TCvSubst, CoreExpr)
lookup_tmpl RuleSubst
rule_subst)
(InScopeSet -> TCvSubst
mkEmptyTCvSubst InScopeSet
in_scope) ([(Var, Var)] -> (TCvSubst, [CoreExpr]))
-> [(Var, Var)] -> (TCvSubst, [CoreExpr])
forall a b. (a -> b) -> a -> b
$
[Var]
tmpl_vars [Var] -> [Var] -> [(Var, Var)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Var]
tmpl_vars1
bind_wrapper :: CoreExpr -> CoreExpr
bind_wrapper = RuleSubst -> CoreExpr -> CoreExpr
rs_binds RuleSubst
rule_subst
; CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> CoreExpr
bind_wrapper (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
[Var] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Var]
tmpl_vars CoreExpr
rhs CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
`mkApps` [CoreExpr]
matched_es) }
where
(RnEnv2
init_rn_env, [Var]
tmpl_vars1) = (RnEnv2 -> Var -> (RnEnv2, Var))
-> RnEnv2 -> [Var] -> (RnEnv2, [Var])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL RnEnv2 -> Var -> (RnEnv2, Var)
rnBndrL (InScopeSet -> RnEnv2
mkRnEnv2 InScopeSet
in_scope) [Var]
tmpl_vars
init_menv :: RuleMatchEnv
init_menv = RV { rv_tmpls :: VarSet
rv_tmpls = [Var] -> VarSet
mkVarSet [Var]
tmpl_vars1
, rv_lcl :: RnEnv2
rv_lcl = RnEnv2
init_rn_env
, rv_fltR :: Subst
rv_fltR = InScopeSet -> Subst
mkEmptySubst (RnEnv2 -> InScopeSet
rnInScopeSet RnEnv2
init_rn_env)
, rv_unf :: IdUnfoldingFun
rv_unf = IdUnfoldingFun
id_unf }
lookup_tmpl :: RuleSubst -> TCvSubst -> (InVar,OutVar) -> (TCvSubst, CoreExpr)
lookup_tmpl :: RuleSubst -> TCvSubst -> (Var, Var) -> (TCvSubst, CoreExpr)
lookup_tmpl (RS { rs_tv_subst :: RuleSubst -> TvSubstEnv
rs_tv_subst = TvSubstEnv
tv_subst, rs_id_subst :: RuleSubst -> IdSubstEnv
rs_id_subst = IdSubstEnv
id_subst })
TCvSubst
tcv_subst (Var
tmpl_var, Var
tmpl_var1)
| Var -> Bool
isId Var
tmpl_var1
= case IdSubstEnv -> Var -> Maybe CoreExpr
forall a. VarEnv a -> Var -> Maybe a
lookupVarEnv IdSubstEnv
id_subst Var
tmpl_var1 of
Just CoreExpr
e | Coercion Coercion
co <- CoreExpr
e
-> (TCvSubst -> Var -> Coercion -> TCvSubst
Type.extendCvSubst TCvSubst
tcv_subst Var
tmpl_var1 Coercion
co, Coercion -> CoreExpr
forall b. Coercion -> Expr b
Coercion Coercion
co)
| Bool
otherwise
-> (TCvSubst
tcv_subst, CoreExpr
e)
Maybe CoreExpr
Nothing | Just Coercion
refl_co <- Var -> Maybe Coercion
isReflCoVar_maybe Var
tmpl_var1
, let co :: Coercion
co = (() :: Constraint) => TCvSubst -> Coercion -> Coercion
TCvSubst -> Coercion -> Coercion
Coercion.substCo TCvSubst
tcv_subst Coercion
refl_co
->
(TCvSubst -> Var -> Coercion -> TCvSubst
Type.extendCvSubst TCvSubst
tcv_subst Var
tmpl_var1 Coercion
co, Coercion -> CoreExpr
forall b. Coercion -> Expr b
Coercion Coercion
co)
| Bool
otherwise
-> Var -> (TCvSubst, CoreExpr)
unbound Var
tmpl_var
| Bool
otherwise
= (TCvSubst -> Var -> Kind -> TCvSubst
Type.extendTvSubst TCvSubst
tcv_subst Var
tmpl_var1 Kind
ty', Kind -> CoreExpr
forall b. Kind -> Expr b
Type Kind
ty')
where
ty' :: Kind
ty' = case TvSubstEnv -> Var -> Maybe Kind
forall a. VarEnv a -> Var -> Maybe a
lookupVarEnv TvSubstEnv
tv_subst Var
tmpl_var1 of
Just Kind
ty -> Kind
ty
Maybe Kind
Nothing -> Kind
fake_ty
fake_ty :: Kind
fake_ty = Kind -> Kind
anyTypeOfKind ((() :: Constraint) => TCvSubst -> Kind -> Kind
TCvSubst -> Kind -> Kind
Type.substTy TCvSubst
tcv_subst (Var -> Kind
tyVarKind Var
tmpl_var1))
unbound :: Var -> (TCvSubst, CoreExpr)
unbound Var
tmpl_var
= String -> SDoc -> (TCvSubst, CoreExpr)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Template variable unbound in rewrite rule" (SDoc -> (TCvSubst, CoreExpr)) -> SDoc -> (TCvSubst, CoreExpr)
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Variable:" SDoc -> SDoc -> SDoc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
tmpl_var SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> Kind
varType Var
tmpl_var)
, String -> SDoc
text String
"Rule" SDoc -> SDoc -> SDoc
<+> RuleName -> SDoc
pprRuleName RuleName
rule_name
, String -> SDoc
text String
"Rule bndrs:" SDoc -> SDoc -> SDoc
<+> [Var] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Var]
tmpl_vars
, String -> SDoc
text String
"LHS args:" SDoc -> SDoc -> SDoc
<+> [CoreExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreExpr]
tmpl_es
, String -> SDoc
text String
"Actual args:" SDoc -> SDoc -> SDoc
<+> [CoreExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreExpr]
target_es ]
data RuleMatchEnv
= RV { RuleMatchEnv -> RnEnv2
rv_lcl :: RnEnv2
, RuleMatchEnv -> VarSet
rv_tmpls :: VarSet
, RuleMatchEnv -> Subst
rv_fltR :: Subst
, RuleMatchEnv -> IdUnfoldingFun
rv_unf :: IdUnfoldingFun
}
rvInScopeEnv :: RuleMatchEnv -> InScopeEnv
rvInScopeEnv :: RuleMatchEnv -> InScopeEnv
rvInScopeEnv RuleMatchEnv
renv = (RnEnv2 -> InScopeSet
rnInScopeSet (RuleMatchEnv -> RnEnv2
rv_lcl RuleMatchEnv
renv), RuleMatchEnv -> IdUnfoldingFun
rv_unf RuleMatchEnv
renv)
data RuleSubst = RS { RuleSubst -> TvSubstEnv
rs_tv_subst :: TvSubstEnv
, RuleSubst -> IdSubstEnv
rs_id_subst :: IdSubstEnv
, RuleSubst -> CoreExpr -> CoreExpr
rs_binds :: BindWrapper
, RuleSubst -> [Var]
rs_bndrs :: [Var]
}
type BindWrapper = CoreExpr -> CoreExpr
emptyRuleSubst :: RuleSubst
emptyRuleSubst :: RuleSubst
emptyRuleSubst = RS { rs_tv_subst :: TvSubstEnv
rs_tv_subst = TvSubstEnv
forall a. VarEnv a
emptyVarEnv, rs_id_subst :: IdSubstEnv
rs_id_subst = IdSubstEnv
forall a. VarEnv a
emptyVarEnv
, rs_binds :: CoreExpr -> CoreExpr
rs_binds = \CoreExpr
e -> CoreExpr
e, rs_bndrs :: [Var]
rs_bndrs = [] }
match_exprs :: RuleMatchEnv -> RuleSubst
-> [CoreExpr]
-> [CoreExpr]
-> Maybe RuleSubst
match_exprs :: RuleMatchEnv
-> RuleSubst -> [CoreExpr] -> [CoreExpr] -> Maybe RuleSubst
match_exprs RuleMatchEnv
_ RuleSubst
subst [] [CoreExpr]
_
= RuleSubst -> Maybe RuleSubst
forall a. a -> Maybe a
Just RuleSubst
subst
match_exprs RuleMatchEnv
renv RuleSubst
subst (CoreExpr
e1:[CoreExpr]
es1) (CoreExpr
e2:[CoreExpr]
es2)
= do { RuleSubst
subst' <- RuleMatchEnv
-> RuleSubst
-> CoreExpr
-> CoreExpr
-> MCoercion
-> Maybe RuleSubst
match RuleMatchEnv
renv RuleSubst
subst CoreExpr
e1 CoreExpr
e2 MCoercion
MRefl
; RuleMatchEnv
-> RuleSubst -> [CoreExpr] -> [CoreExpr] -> Maybe RuleSubst
match_exprs RuleMatchEnv
renv RuleSubst
subst' [CoreExpr]
es1 [CoreExpr]
es2 }
match_exprs RuleMatchEnv
_ RuleSubst
_ [CoreExpr]
_ [CoreExpr]
_ = Maybe RuleSubst
forall a. Maybe a
Nothing
match :: RuleMatchEnv
-> RuleSubst
-> CoreExpr
-> CoreExpr
-> MCoercion
-> Maybe RuleSubst
match :: RuleMatchEnv
-> RuleSubst
-> CoreExpr
-> CoreExpr
-> MCoercion
-> Maybe RuleSubst
match RuleMatchEnv
renv RuleSubst
subst CoreExpr
e1 (Tick CoreTickish
t CoreExpr
e2) MCoercion
mco
| CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreTickish
t
= RuleMatchEnv
-> RuleSubst
-> CoreExpr
-> CoreExpr
-> MCoercion
-> Maybe RuleSubst
match RuleMatchEnv
renv RuleSubst
subst' CoreExpr
e1 CoreExpr
e2 MCoercion
mco
| Bool
otherwise
= Maybe RuleSubst
forall a. Maybe a
Nothing
where
subst' :: RuleSubst
subst' = RuleSubst
subst { rs_binds :: CoreExpr -> CoreExpr
rs_binds = RuleSubst -> CoreExpr -> CoreExpr
rs_binds RuleSubst
subst (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreTickish -> CoreExpr -> CoreExpr
mkTick CoreTickish
t }
match RuleMatchEnv
renv RuleSubst
subst e :: CoreExpr
e@(Tick CoreTickish
t CoreExpr
e1) CoreExpr
e2 MCoercion
mco
| CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreTickish
t
= RuleMatchEnv
-> RuleSubst
-> CoreExpr
-> CoreExpr
-> MCoercion
-> Maybe RuleSubst
match RuleMatchEnv
renv RuleSubst
subst CoreExpr
e1 CoreExpr
e2 MCoercion
mco
| Bool
otherwise
= String -> SDoc -> Maybe RuleSubst
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Tick in rule" (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e)
match RuleMatchEnv
renv RuleSubst
subst (Type Kind
ty1) (Type Kind
ty2) MCoercion
_mco
= RuleMatchEnv -> RuleSubst -> Kind -> Kind -> Maybe RuleSubst
match_ty RuleMatchEnv
renv RuleSubst
subst Kind
ty1 Kind
ty2
match RuleMatchEnv
renv RuleSubst
subst (Coercion Coercion
co1) (Coercion Coercion
co2) MCoercion
MRefl
= RuleMatchEnv
-> RuleSubst -> Coercion -> Coercion -> Maybe RuleSubst
match_co RuleMatchEnv
renv RuleSubst
subst Coercion
co1 Coercion
co2
match RuleMatchEnv
renv RuleSubst
subst CoreExpr
e1 (Cast CoreExpr
e2 Coercion
co2) MCoercion
mco
= RuleMatchEnv
-> RuleSubst
-> CoreExpr
-> CoreExpr
-> MCoercion
-> Maybe RuleSubst
match RuleMatchEnv
renv RuleSubst
subst CoreExpr
e1 CoreExpr
e2 (MCoercion -> MCoercion
checkReflexiveMCo (Coercion -> MCoercion -> MCoercion
mkTransMCoR Coercion
co2 MCoercion
mco))
match RuleMatchEnv
renv RuleSubst
subst (Cast CoreExpr
e1 Coercion
co1) CoreExpr
e2 MCoercion
mco
=
do { let co2 :: Coercion
co2 = case MCoercion
mco of
MCoercion
MRefl -> Kind -> Coercion
mkRepReflCo ((() :: Constraint) => CoreExpr -> Kind
CoreExpr -> Kind
exprType CoreExpr
e2)
MCo Coercion
co2 -> Coercion
co2
; RuleSubst
subst1 <- RuleMatchEnv
-> RuleSubst -> Coercion -> Coercion -> Maybe RuleSubst
match_co RuleMatchEnv
renv RuleSubst
subst Coercion
co1 Coercion
co2
; RuleMatchEnv
-> RuleSubst
-> CoreExpr
-> CoreExpr
-> MCoercion
-> Maybe RuleSubst
match RuleMatchEnv
renv RuleSubst
subst1 CoreExpr
e1 CoreExpr
e2 MCoercion
MRefl }
match RuleMatchEnv
_ RuleSubst
subst (Lit Literal
lit1) (Lit Literal
lit2) MCoercion
mco
| Literal
lit1 Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Literal
lit2
= Bool -> SDoc -> Maybe RuleSubst -> Maybe RuleSubst
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (MCoercion -> Bool
isReflMCo MCoercion
mco) (MCoercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr MCoercion
mco) (Maybe RuleSubst -> Maybe RuleSubst)
-> Maybe RuleSubst -> Maybe RuleSubst
forall a b. (a -> b) -> a -> b
$
RuleSubst -> Maybe RuleSubst
forall a. a -> Maybe a
Just RuleSubst
subst
match RuleMatchEnv
renv RuleSubst
subst (Var Var
v1) CoreExpr
e2 MCoercion
mco
= RuleMatchEnv -> RuleSubst -> Var -> CoreExpr -> Maybe RuleSubst
match_var RuleMatchEnv
renv RuleSubst
subst Var
v1 (CoreExpr -> MCoercion -> CoreExpr
mkCastMCo CoreExpr
e2 MCoercion
mco)
match RuleMatchEnv
renv RuleSubst
subst CoreExpr
e1 (Var Var
v2) MCoercion
mco
| Bool -> Bool
not (RnEnv2 -> Var -> Bool
inRnEnvR RnEnv2
rn_env Var
v2)
, Just CoreExpr
e2' <- Unfolding -> Maybe CoreExpr
expandUnfolding_maybe (RuleMatchEnv -> IdUnfoldingFun
rv_unf RuleMatchEnv
renv Var
v2')
= RuleMatchEnv
-> RuleSubst
-> CoreExpr
-> CoreExpr
-> MCoercion
-> Maybe RuleSubst
match (RuleMatchEnv
renv { rv_lcl :: RnEnv2
rv_lcl = RnEnv2 -> RnEnv2
nukeRnEnvR RnEnv2
rn_env }) RuleSubst
subst CoreExpr
e1 CoreExpr
e2' MCoercion
mco
where
v2' :: Var
v2' = RnEnv2 -> Var -> Var
lookupRnInScope RnEnv2
rn_env Var
v2
rn_env :: RnEnv2
rn_env = RuleMatchEnv -> RnEnv2
rv_lcl RuleMatchEnv
renv
match RuleMatchEnv
renv RuleSubst
subst (App CoreExpr
f1 CoreExpr
a1) (App CoreExpr
f2 CoreExpr
a2) MCoercion
MRefl
= do { RuleSubst
subst' <- RuleMatchEnv
-> RuleSubst
-> CoreExpr
-> CoreExpr
-> MCoercion
-> Maybe RuleSubst
match RuleMatchEnv
renv RuleSubst
subst CoreExpr
f1 CoreExpr
f2 MCoercion
MRefl
; RuleMatchEnv
-> RuleSubst
-> CoreExpr
-> CoreExpr
-> MCoercion
-> Maybe RuleSubst
match RuleMatchEnv
renv RuleSubst
subst' CoreExpr
a1 CoreExpr
a2 MCoercion
MRefl }
match RuleMatchEnv
renv RuleSubst
subst CoreExpr
e1 (Let CoreBind
bind CoreExpr
e2) MCoercion
mco
|
Bool -> Bool
not (CoreBind -> Bool
isJoinBind CoreBind
bind)
, RnEnv2 -> VarSet -> Bool
okToFloat (RuleMatchEnv -> RnEnv2
rv_lcl RuleMatchEnv
renv) (CoreBind -> VarSet
bindFreeVars CoreBind
bind)
= RuleMatchEnv
-> RuleSubst
-> CoreExpr
-> CoreExpr
-> MCoercion
-> Maybe RuleSubst
match (RuleMatchEnv
renv { rv_fltR :: Subst
rv_fltR = Subst
flt_subst'
, rv_lcl :: RnEnv2
rv_lcl = RuleMatchEnv -> RnEnv2
rv_lcl RuleMatchEnv
renv RnEnv2 -> [Var] -> RnEnv2
`extendRnInScopeSetList` [Var]
new_bndrs })
(RuleSubst
subst { rs_binds :: CoreExpr -> CoreExpr
rs_binds = RuleSubst -> CoreExpr -> CoreExpr
rs_binds RuleSubst
subst (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let CoreBind
bind'
, rs_bndrs :: [Var]
rs_bndrs = [Var]
new_bndrs [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ RuleSubst -> [Var]
rs_bndrs RuleSubst
subst })
CoreExpr
e1 CoreExpr
e2 MCoercion
mco
| Bool
otherwise
= Maybe RuleSubst
forall a. Maybe a
Nothing
where
in_scope :: InScopeSet
in_scope = RnEnv2 -> InScopeSet
rnInScopeSet (RuleMatchEnv -> RnEnv2
rv_lcl RuleMatchEnv
renv) InScopeSet -> [Var] -> InScopeSet
`extendInScopeSetList` RuleSubst -> [Var]
rs_bndrs RuleSubst
subst
flt_subst :: Subst
flt_subst = RuleMatchEnv -> Subst
rv_fltR RuleMatchEnv
renv Subst -> InScopeSet -> Subst
`setInScope` InScopeSet
in_scope
(Subst
flt_subst', CoreBind
bind') = (() :: Constraint) => Subst -> CoreBind -> (Subst, CoreBind)
Subst -> CoreBind -> (Subst, CoreBind)
substBind Subst
flt_subst CoreBind
bind
new_bndrs :: [Var]
new_bndrs = CoreBind -> [Var]
forall b. Bind b -> [b]
bindersOf CoreBind
bind'
match RuleMatchEnv
renv RuleSubst
subst (Lam Var
x1 CoreExpr
e1) CoreExpr
e2 MCoercion
mco
| Just (Var
x2, CoreExpr
e2', [CoreTickish]
ts) <- InScopeEnv -> CoreExpr -> Maybe (Var, CoreExpr, [CoreTickish])
(() :: Constraint) =>
InScopeEnv -> CoreExpr -> Maybe (Var, CoreExpr, [CoreTickish])
exprIsLambda_maybe (RuleMatchEnv -> InScopeEnv
rvInScopeEnv RuleMatchEnv
renv) (CoreExpr -> MCoercion -> CoreExpr
mkCastMCo CoreExpr
e2 MCoercion
mco)
= let renv' :: RuleMatchEnv
renv' = RuleMatchEnv -> Var -> Var -> RuleMatchEnv
rnMatchBndr2 RuleMatchEnv
renv Var
x1 Var
x2
subst' :: RuleSubst
subst' = RuleSubst
subst { rs_binds :: CoreExpr -> CoreExpr
rs_binds = RuleSubst -> CoreExpr -> CoreExpr
rs_binds RuleSubst
subst (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CoreExpr -> [CoreTickish] -> CoreExpr)
-> [CoreTickish] -> CoreExpr -> CoreExpr
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((CoreTickish -> CoreExpr -> CoreExpr)
-> CoreExpr -> [CoreTickish] -> CoreExpr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CoreTickish -> CoreExpr -> CoreExpr
mkTick) [CoreTickish]
ts }
in RuleMatchEnv
-> RuleSubst
-> CoreExpr
-> CoreExpr
-> MCoercion
-> Maybe RuleSubst
match RuleMatchEnv
renv' RuleSubst
subst' CoreExpr
e1 CoreExpr
e2' MCoercion
MRefl
match RuleMatchEnv
renv RuleSubst
subst CoreExpr
e1 e2 :: CoreExpr
e2@(Lam {}) MCoercion
mco
| Just (RuleMatchEnv
renv', CoreExpr
e2') <- RuleMatchEnv -> CoreExpr -> Maybe (RuleMatchEnv, CoreExpr)
eta_reduce RuleMatchEnv
renv CoreExpr
e2
= RuleMatchEnv
-> RuleSubst
-> CoreExpr
-> CoreExpr
-> MCoercion
-> Maybe RuleSubst
match RuleMatchEnv
renv' RuleSubst
subst CoreExpr
e1 CoreExpr
e2' MCoercion
mco
match RuleMatchEnv
renv RuleSubst
subst (Case CoreExpr
e1 Var
x1 Kind
ty1 [Alt Var]
alts1) (Case CoreExpr
e2 Var
x2 Kind
ty2 [Alt Var]
alts2) MCoercion
mco
= do { RuleSubst
subst1 <- RuleMatchEnv -> RuleSubst -> Kind -> Kind -> Maybe RuleSubst
match_ty RuleMatchEnv
renv RuleSubst
subst Kind
ty1 Kind
ty2
; RuleSubst
subst2 <- RuleMatchEnv
-> RuleSubst
-> CoreExpr
-> CoreExpr
-> MCoercion
-> Maybe RuleSubst
match RuleMatchEnv
renv RuleSubst
subst1 CoreExpr
e1 CoreExpr
e2 MCoercion
MRefl
; let renv' :: RuleMatchEnv
renv' = RuleMatchEnv -> Var -> Var -> RuleMatchEnv
rnMatchBndr2 RuleMatchEnv
renv Var
x1 Var
x2
; RuleMatchEnv
-> RuleSubst
-> [Alt Var]
-> [Alt Var]
-> MCoercion
-> Maybe RuleSubst
match_alts RuleMatchEnv
renv' RuleSubst
subst2 [Alt Var]
alts1 [Alt Var]
alts2 MCoercion
mco
}
match RuleMatchEnv
_ RuleSubst
_ CoreExpr
_e1 CoreExpr
_e2 MCoercion
_mco =
Maybe RuleSubst
forall a. Maybe a
Nothing
eta_reduce :: RuleMatchEnv -> CoreExpr -> Maybe (RuleMatchEnv, CoreExpr)
eta_reduce :: RuleMatchEnv -> CoreExpr -> Maybe (RuleMatchEnv, CoreExpr)
eta_reduce RuleMatchEnv
renv e :: CoreExpr
e@(Lam {})
= RuleMatchEnv
-> (CoreExpr -> CoreExpr)
-> [Var]
-> CoreExpr
-> Maybe (RuleMatchEnv, CoreExpr)
go RuleMatchEnv
renv CoreExpr -> CoreExpr
forall a. a -> a
id [] CoreExpr
e
where
go :: RuleMatchEnv -> BindWrapper -> [Var] -> CoreExpr
-> Maybe (RuleMatchEnv, CoreExpr)
go :: RuleMatchEnv
-> (CoreExpr -> CoreExpr)
-> [Var]
-> CoreExpr
-> Maybe (RuleMatchEnv, CoreExpr)
go RuleMatchEnv
renv CoreExpr -> CoreExpr
bw [Var]
vs (Let CoreBind
b CoreExpr
e) = RuleMatchEnv
-> (CoreExpr -> CoreExpr)
-> [Var]
-> CoreExpr
-> Maybe (RuleMatchEnv, CoreExpr)
go RuleMatchEnv
renv (CoreExpr -> CoreExpr
bw (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let CoreBind
b) [Var]
vs CoreExpr
e
go RuleMatchEnv
renv CoreExpr -> CoreExpr
bw [Var]
vs (Lam Var
v CoreExpr
e) = RuleMatchEnv
-> (CoreExpr -> CoreExpr)
-> [Var]
-> CoreExpr
-> Maybe (RuleMatchEnv, CoreExpr)
go RuleMatchEnv
renv' CoreExpr -> CoreExpr
bw (Var
v'Var -> [Var] -> [Var]
forall a. a -> [a] -> [a]
:[Var]
vs) CoreExpr
e
where
(RnEnv2
rn_env', Var
v') = RnEnv2 -> Var -> (RnEnv2, Var)
rnBndrR (RuleMatchEnv -> RnEnv2
rv_lcl RuleMatchEnv
renv) Var
v
renv' :: RuleMatchEnv
renv' = RuleMatchEnv
renv { rv_lcl :: RnEnv2
rv_lcl = RnEnv2
rn_env' }
go RuleMatchEnv
renv CoreExpr -> CoreExpr
bw (Var
v:[Var]
vs) (App CoreExpr
f CoreExpr
arg)
| Var Var
a <- CoreExpr
arg, Var
v Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== RnEnv2 -> Var -> Var
rnOccR (RuleMatchEnv -> RnEnv2
rv_lcl RuleMatchEnv
renv) Var
a
= RuleMatchEnv
-> (CoreExpr -> CoreExpr)
-> [Var]
-> CoreExpr
-> Maybe (RuleMatchEnv, CoreExpr)
go RuleMatchEnv
renv CoreExpr -> CoreExpr
bw [Var]
vs CoreExpr
f
| Type Kind
ty <- CoreExpr
arg, Just Var
tv <- Kind -> Maybe Var
getTyVar_maybe Kind
ty
, Var
v Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== RnEnv2 -> Var -> Var
rnOccR (RuleMatchEnv -> RnEnv2
rv_lcl RuleMatchEnv
renv) Var
tv
= RuleMatchEnv
-> (CoreExpr -> CoreExpr)
-> [Var]
-> CoreExpr
-> Maybe (RuleMatchEnv, CoreExpr)
go RuleMatchEnv
renv CoreExpr -> CoreExpr
bw [Var]
vs CoreExpr
f
go RuleMatchEnv
renv CoreExpr -> CoreExpr
bw [] CoreExpr
e = (RuleMatchEnv, CoreExpr) -> Maybe (RuleMatchEnv, CoreExpr)
forall a. a -> Maybe a
Just (RuleMatchEnv
renv, CoreExpr -> CoreExpr
bw CoreExpr
e)
go RuleMatchEnv
_ CoreExpr -> CoreExpr
_ (Var
_:[Var]
_) CoreExpr
_ = Maybe (RuleMatchEnv, CoreExpr)
forall a. Maybe a
Nothing
eta_reduce RuleMatchEnv
_ CoreExpr
_ = Maybe (RuleMatchEnv, CoreExpr)
forall a. Maybe a
Nothing
match_co :: RuleMatchEnv
-> RuleSubst
-> Coercion
-> Coercion
-> Maybe RuleSubst
match_co :: RuleMatchEnv
-> RuleSubst -> Coercion -> Coercion -> Maybe RuleSubst
match_co RuleMatchEnv
renv RuleSubst
subst Coercion
co1 Coercion
co2
| Just Var
cv <- Coercion -> Maybe Var
getCoVar_maybe Coercion
co1
= RuleMatchEnv -> RuleSubst -> Var -> CoreExpr -> Maybe RuleSubst
match_var RuleMatchEnv
renv RuleSubst
subst Var
cv (Coercion -> CoreExpr
forall b. Coercion -> Expr b
Coercion Coercion
co2)
| Just (Kind
ty1, Role
r1) <- Coercion -> Maybe (Kind, Role)
isReflCo_maybe Coercion
co1
= do { (Kind
ty2, Role
r2) <- Coercion -> Maybe (Kind, Role)
isReflCo_maybe Coercion
co2
; Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Role
r1 Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
r2)
; RuleMatchEnv -> RuleSubst -> Kind -> Kind -> Maybe RuleSubst
match_ty RuleMatchEnv
renv RuleSubst
subst Kind
ty1 Kind
ty2 }
| Bool
debugIsOn
= String -> SDoc -> Maybe RuleSubst -> Maybe RuleSubst
forall a. String -> SDoc -> a -> a
pprTrace String
"match_co: needs more cases" (Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co1 SDoc -> SDoc -> SDoc
$$ Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co2) Maybe RuleSubst
forall a. Maybe a
Nothing
| Bool
otherwise
= Maybe RuleSubst
forall a. Maybe a
Nothing
rnMatchBndr2 :: RuleMatchEnv -> Var -> Var -> RuleMatchEnv
rnMatchBndr2 :: RuleMatchEnv -> Var -> Var -> RuleMatchEnv
rnMatchBndr2 RuleMatchEnv
renv Var
x1 Var
x2
= RuleMatchEnv
renv { rv_lcl :: RnEnv2
rv_lcl = RnEnv2 -> Var -> Var -> RnEnv2
rnBndr2 (RuleMatchEnv -> RnEnv2
rv_lcl RuleMatchEnv
renv) Var
x1 Var
x2
, rv_fltR :: Subst
rv_fltR = Subst -> Var -> Subst
delBndr (RuleMatchEnv -> Subst
rv_fltR RuleMatchEnv
renv) Var
x2 }
match_alts :: RuleMatchEnv
-> RuleSubst
-> [CoreAlt]
-> [CoreAlt] -> MCoercion
-> Maybe RuleSubst
match_alts :: RuleMatchEnv
-> RuleSubst
-> [Alt Var]
-> [Alt Var]
-> MCoercion
-> Maybe RuleSubst
match_alts RuleMatchEnv
_ RuleSubst
subst [] [] MCoercion
_
= RuleSubst -> Maybe RuleSubst
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return RuleSubst
subst
match_alts RuleMatchEnv
renv RuleSubst
subst (Alt AltCon
c1 [Var]
vs1 CoreExpr
r1:[Alt Var]
alts1) (Alt AltCon
c2 [Var]
vs2 CoreExpr
r2:[Alt Var]
alts2) MCoercion
mco
| AltCon
c1 AltCon -> AltCon -> Bool
forall a. Eq a => a -> a -> Bool
== AltCon
c2
= do { RuleSubst
subst1 <- RuleMatchEnv
-> RuleSubst
-> CoreExpr
-> CoreExpr
-> MCoercion
-> Maybe RuleSubst
match RuleMatchEnv
renv' RuleSubst
subst CoreExpr
r1 CoreExpr
r2 MCoercion
mco
; RuleMatchEnv
-> RuleSubst
-> [Alt Var]
-> [Alt Var]
-> MCoercion
-> Maybe RuleSubst
match_alts RuleMatchEnv
renv RuleSubst
subst1 [Alt Var]
alts1 [Alt Var]
alts2 MCoercion
mco }
where
renv' :: RuleMatchEnv
renv' = (RuleMatchEnv -> (Var, Var) -> RuleMatchEnv)
-> RuleMatchEnv -> [(Var, Var)] -> RuleMatchEnv
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' RuleMatchEnv -> (Var, Var) -> RuleMatchEnv
mb RuleMatchEnv
renv ([Var]
vs1 [Var] -> [Var] -> [(Var, Var)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Var]
vs2)
mb :: RuleMatchEnv -> (Var, Var) -> RuleMatchEnv
mb RuleMatchEnv
renv (Var
v1,Var
v2) = RuleMatchEnv -> Var -> Var -> RuleMatchEnv
rnMatchBndr2 RuleMatchEnv
renv Var
v1 Var
v2
match_alts RuleMatchEnv
_ RuleSubst
_ [Alt Var]
_ [Alt Var]
_ MCoercion
_
= Maybe RuleSubst
forall a. Maybe a
Nothing
okToFloat :: RnEnv2 -> VarSet -> Bool
okToFloat :: RnEnv2 -> VarSet -> Bool
okToFloat RnEnv2
rn_env VarSet
bind_fvs
= (Var -> Bool) -> VarSet -> Bool
allVarSet Var -> Bool
not_captured VarSet
bind_fvs
where
not_captured :: Var -> Bool
not_captured Var
fv = Bool -> Bool
not (RnEnv2 -> Var -> Bool
inRnEnvR RnEnv2
rn_env Var
fv)
match_var :: RuleMatchEnv
-> RuleSubst
-> Var
-> CoreExpr
-> Maybe RuleSubst
match_var :: RuleMatchEnv -> RuleSubst -> Var -> CoreExpr -> Maybe RuleSubst
match_var renv :: RuleMatchEnv
renv@(RV { rv_tmpls :: RuleMatchEnv -> VarSet
rv_tmpls = VarSet
tmpls, rv_lcl :: RuleMatchEnv -> RnEnv2
rv_lcl = RnEnv2
rn_env, rv_fltR :: RuleMatchEnv -> Subst
rv_fltR = Subst
flt_env })
RuleSubst
subst Var
v1 CoreExpr
e2
| Var
v1' Var -> VarSet -> Bool
`elemVarSet` VarSet
tmpls
= RuleMatchEnv -> RuleSubst -> Var -> CoreExpr -> Maybe RuleSubst
match_tmpl_var RuleMatchEnv
renv RuleSubst
subst Var
v1' CoreExpr
e2
| Bool
otherwise
= case CoreExpr
e2 of
Var Var
v2 | Just Var
v2' <- RnEnv2 -> Var -> Maybe Var
rnOccR_maybe RnEnv2
rn_env Var
v2
->
if Var
v1' Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
v2' then RuleSubst -> Maybe RuleSubst
forall a. a -> Maybe a
Just RuleSubst
subst
else Maybe RuleSubst
forall a. Maybe a
Nothing
| Var Var
v2' <- (() :: Constraint) => Subst -> Var -> CoreExpr
Subst -> Var -> CoreExpr
lookupIdSubst Subst
flt_env Var
v2
, Var
v1' Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
v2'
-> RuleSubst -> Maybe RuleSubst
forall a. a -> Maybe a
Just RuleSubst
subst
| Bool
otherwise
-> Maybe RuleSubst
forall a. Maybe a
Nothing
CoreExpr
_ -> Maybe RuleSubst
forall a. Maybe a
Nothing
where
v1' :: Var
v1' = RnEnv2 -> Var -> Var
rnOccL RnEnv2
rn_env Var
v1
match_tmpl_var :: RuleMatchEnv
-> RuleSubst
-> Var
-> CoreExpr
-> Maybe RuleSubst
match_tmpl_var :: RuleMatchEnv -> RuleSubst -> Var -> CoreExpr -> Maybe RuleSubst
match_tmpl_var renv :: RuleMatchEnv
renv@(RV { rv_lcl :: RuleMatchEnv -> RnEnv2
rv_lcl = RnEnv2
rn_env, rv_fltR :: RuleMatchEnv -> Subst
rv_fltR = Subst
flt_env })
subst :: RuleSubst
subst@(RS { rs_id_subst :: RuleSubst -> IdSubstEnv
rs_id_subst = IdSubstEnv
id_subst, rs_bndrs :: RuleSubst -> [Var]
rs_bndrs = [Var]
let_bndrs })
Var
v1' CoreExpr
e2
| (Var -> Bool) -> [Var] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (RnEnv2 -> Var -> Bool
inRnEnvR RnEnv2
rn_env) (CoreExpr -> [Var]
exprFreeVarsList CoreExpr
e2)
= Maybe RuleSubst
forall a. Maybe a
Nothing
| Just CoreExpr
e1' <- IdSubstEnv -> Var -> Maybe CoreExpr
forall a. VarEnv a -> Var -> Maybe a
lookupVarEnv IdSubstEnv
id_subst Var
v1'
= if CoreExpr -> CoreExpr -> Bool
eqCoreExpr CoreExpr
e1' CoreExpr
e2'
then RuleSubst -> Maybe RuleSubst
forall a. a -> Maybe a
Just RuleSubst
subst
else Maybe RuleSubst
forall a. Maybe a
Nothing
| Bool
otherwise
= do { RuleSubst
subst' <- RuleMatchEnv -> RuleSubst -> Kind -> Kind -> Maybe RuleSubst
match_ty RuleMatchEnv
renv RuleSubst
subst (Var -> Kind
idType Var
v1') ((() :: Constraint) => CoreExpr -> Kind
CoreExpr -> Kind
exprType CoreExpr
e2)
; RuleSubst -> Maybe RuleSubst
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (RuleSubst
subst' { rs_id_subst :: IdSubstEnv
rs_id_subst = IdSubstEnv
id_subst' }) }
where
e2' :: CoreExpr
e2' | [Var] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
let_bndrs = CoreExpr
e2
| Bool
otherwise = (() :: Constraint) => Subst -> CoreExpr -> CoreExpr
Subst -> CoreExpr -> CoreExpr
substExpr Subst
flt_env CoreExpr
e2
id_subst' :: IdSubstEnv
id_subst' = IdSubstEnv -> Var -> CoreExpr -> IdSubstEnv
forall a. VarEnv a -> Var -> a -> VarEnv a
extendVarEnv (RuleSubst -> IdSubstEnv
rs_id_subst RuleSubst
subst) Var
v1' CoreExpr
e2'
match_ty :: RuleMatchEnv
-> RuleSubst
-> Type
-> Type
-> Maybe RuleSubst
match_ty :: RuleMatchEnv -> RuleSubst -> Kind -> Kind -> Maybe RuleSubst
match_ty RuleMatchEnv
renv RuleSubst
subst Kind
ty1 Kind
ty2
= do { TvSubstEnv
tv_subst'
<- VarSet -> RnEnv2 -> TvSubstEnv -> Kind -> Kind -> Maybe TvSubstEnv
Unify.ruleMatchTyKiX (RuleMatchEnv -> VarSet
rv_tmpls RuleMatchEnv
renv) (RuleMatchEnv -> RnEnv2
rv_lcl RuleMatchEnv
renv) TvSubstEnv
tv_subst Kind
ty1 Kind
ty2
; RuleSubst -> Maybe RuleSubst
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (RuleSubst
subst { rs_tv_subst :: TvSubstEnv
rs_tv_subst = TvSubstEnv
tv_subst' }) }
where
tv_subst :: TvSubstEnv
tv_subst = RuleSubst -> TvSubstEnv
rs_tv_subst RuleSubst
subst
ruleCheckProgram :: RuleOpts
-> CompilerPhase
-> String
-> (Id -> [CoreRule])
-> CoreProgram
-> SDoc
ruleCheckProgram :: RuleOpts
-> CompilerPhase
-> String
-> (Var -> [CoreRule])
-> [CoreBind]
-> SDoc
ruleCheckProgram RuleOpts
ropts CompilerPhase
phase String
rule_pat Var -> [CoreRule]
rules [CoreBind]
binds
| Bag SDoc -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag SDoc
results
= String -> SDoc
text String
"Rule check results: no rule application sites"
| Bool
otherwise
= [SDoc] -> SDoc
vcat [String -> SDoc
text String
"Rule check results:",
SDoc
line,
[SDoc] -> SDoc
vcat [ SDoc
p SDoc -> SDoc -> SDoc
$$ SDoc
line | SDoc
p <- Bag SDoc -> [SDoc]
forall a. Bag a -> [a]
bagToList Bag SDoc
results ]
]
where
env :: RuleCheckEnv
env = RuleCheckEnv { rc_is_active :: Activation -> Bool
rc_is_active = CompilerPhase -> Activation -> Bool
isActive CompilerPhase
phase
, rc_id_unf :: IdUnfoldingFun
rc_id_unf = IdUnfoldingFun
idUnfolding
, rc_pattern :: String
rc_pattern = String
rule_pat
, rc_rules :: Var -> [CoreRule]
rc_rules = Var -> [CoreRule]
rules
, rc_ropts :: RuleOpts
rc_ropts = RuleOpts
ropts
}
results :: Bag SDoc
results = [Bag SDoc] -> Bag SDoc
forall a. [Bag a] -> Bag a
unionManyBags ((CoreBind -> Bag SDoc) -> [CoreBind] -> [Bag SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (RuleCheckEnv -> CoreBind -> Bag SDoc
ruleCheckBind RuleCheckEnv
env) [CoreBind]
binds)
line :: SDoc
line = String -> SDoc
text (Arity -> Char -> String
forall a. Arity -> a -> [a]
replicate Arity
20 Char
'-')
data RuleCheckEnv = RuleCheckEnv {
RuleCheckEnv -> Activation -> Bool
rc_is_active :: Activation -> Bool,
RuleCheckEnv -> IdUnfoldingFun
rc_id_unf :: IdUnfoldingFun,
RuleCheckEnv -> String
rc_pattern :: String,
RuleCheckEnv -> Var -> [CoreRule]
rc_rules :: Id -> [CoreRule],
RuleCheckEnv -> RuleOpts
rc_ropts :: RuleOpts
}
ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
ruleCheckBind RuleCheckEnv
env (NonRec Var
_ CoreExpr
r) = RuleCheckEnv -> CoreExpr -> Bag SDoc
ruleCheck RuleCheckEnv
env CoreExpr
r
ruleCheckBind RuleCheckEnv
env (Rec [(Var, CoreExpr)]
prs) = [Bag SDoc] -> Bag SDoc
forall a. [Bag a] -> Bag a
unionManyBags [RuleCheckEnv -> CoreExpr -> Bag SDoc
ruleCheck RuleCheckEnv
env CoreExpr
r | (Var
_,CoreExpr
r) <- [(Var, CoreExpr)]
prs]
ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc
ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc
ruleCheck RuleCheckEnv
_ (Var Var
_) = Bag SDoc
forall a. Bag a
emptyBag
ruleCheck RuleCheckEnv
_ (Lit Literal
_) = Bag SDoc
forall a. Bag a
emptyBag
ruleCheck RuleCheckEnv
_ (Type Kind
_) = Bag SDoc
forall a. Bag a
emptyBag
ruleCheck RuleCheckEnv
_ (Coercion Coercion
_) = Bag SDoc
forall a. Bag a
emptyBag
ruleCheck RuleCheckEnv
env (App CoreExpr
f CoreExpr
a) = RuleCheckEnv -> CoreExpr -> [CoreExpr] -> Bag SDoc
ruleCheckApp RuleCheckEnv
env (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
f CoreExpr
a) []
ruleCheck RuleCheckEnv
env (Tick CoreTickish
_ CoreExpr
e) = RuleCheckEnv -> CoreExpr -> Bag SDoc
ruleCheck RuleCheckEnv
env CoreExpr
e
ruleCheck RuleCheckEnv
env (Cast CoreExpr
e Coercion
_) = RuleCheckEnv -> CoreExpr -> Bag SDoc
ruleCheck RuleCheckEnv
env CoreExpr
e
ruleCheck RuleCheckEnv
env (Let CoreBind
bd CoreExpr
e) = RuleCheckEnv -> CoreBind -> Bag SDoc
ruleCheckBind RuleCheckEnv
env CoreBind
bd Bag SDoc -> Bag SDoc -> Bag SDoc
forall a. Bag a -> Bag a -> Bag a
`unionBags` RuleCheckEnv -> CoreExpr -> Bag SDoc
ruleCheck RuleCheckEnv
env CoreExpr
e
ruleCheck RuleCheckEnv
env (Lam Var
_ CoreExpr
e) = RuleCheckEnv -> CoreExpr -> Bag SDoc
ruleCheck RuleCheckEnv
env CoreExpr
e
ruleCheck RuleCheckEnv
env (Case CoreExpr
e Var
_ Kind
_ [Alt Var]
as) = RuleCheckEnv -> CoreExpr -> Bag SDoc
ruleCheck RuleCheckEnv
env CoreExpr
e Bag SDoc -> Bag SDoc -> Bag SDoc
forall a. Bag a -> Bag a -> Bag a
`unionBags`
[Bag SDoc] -> Bag SDoc
forall a. [Bag a] -> Bag a
unionManyBags [RuleCheckEnv -> CoreExpr -> Bag SDoc
ruleCheck RuleCheckEnv
env CoreExpr
r | Alt AltCon
_ [Var]
_ CoreExpr
r <- [Alt Var]
as]
ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc
ruleCheckApp :: RuleCheckEnv -> CoreExpr -> [CoreExpr] -> Bag SDoc
ruleCheckApp RuleCheckEnv
env (App CoreExpr
f CoreExpr
a) [CoreExpr]
as = RuleCheckEnv -> CoreExpr -> Bag SDoc
ruleCheck RuleCheckEnv
env CoreExpr
a Bag SDoc -> Bag SDoc -> Bag SDoc
forall a. Bag a -> Bag a -> Bag a
`unionBags` RuleCheckEnv -> CoreExpr -> [CoreExpr] -> Bag SDoc
ruleCheckApp RuleCheckEnv
env CoreExpr
f (CoreExpr
aCoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
:[CoreExpr]
as)
ruleCheckApp RuleCheckEnv
env (Var Var
f) [CoreExpr]
as = RuleCheckEnv -> Var -> [CoreExpr] -> Bag SDoc
ruleCheckFun RuleCheckEnv
env Var
f [CoreExpr]
as
ruleCheckApp RuleCheckEnv
env CoreExpr
other [CoreExpr]
_ = RuleCheckEnv -> CoreExpr -> Bag SDoc
ruleCheck RuleCheckEnv
env CoreExpr
other
ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc
ruleCheckFun :: RuleCheckEnv -> Var -> [CoreExpr] -> Bag SDoc
ruleCheckFun RuleCheckEnv
env Var
fn [CoreExpr]
args
| [CoreRule] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreRule]
name_match_rules = Bag SDoc
forall a. Bag a
emptyBag
| Bool
otherwise = SDoc -> Bag SDoc
forall a. a -> Bag a
unitBag (RuleCheckEnv -> Var -> [CoreExpr] -> [CoreRule] -> SDoc
ruleAppCheck_help RuleCheckEnv
env Var
fn [CoreExpr]
args [CoreRule]
name_match_rules)
where
name_match_rules :: [CoreRule]
name_match_rules = (CoreRule -> Bool) -> [CoreRule] -> [CoreRule]
forall a. (a -> Bool) -> [a] -> [a]
filter CoreRule -> Bool
match (RuleCheckEnv -> Var -> [CoreRule]
rc_rules RuleCheckEnv
env Var
fn)
match :: CoreRule -> Bool
match CoreRule
rule = (RuleCheckEnv -> String
rc_pattern RuleCheckEnv
env) String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` RuleName -> String
unpackFS (CoreRule -> RuleName
ruleName CoreRule
rule)
ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc
ruleAppCheck_help :: RuleCheckEnv -> Var -> [CoreExpr] -> [CoreRule] -> SDoc
ruleAppCheck_help RuleCheckEnv
env Var
fn [CoreExpr]
args [CoreRule]
rules
=
[SDoc] -> SDoc
vcat [String -> SDoc
text String
"Expression:" SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
fn) [CoreExpr]
args),
[SDoc] -> SDoc
vcat ((CoreRule -> SDoc) -> [CoreRule] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map CoreRule -> SDoc
check_rule [CoreRule]
rules)]
where
n_args :: Arity
n_args = [CoreExpr] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [CoreExpr]
args
i_args :: [(CoreExpr, Arity)]
i_args = [CoreExpr]
args [CoreExpr] -> [Arity] -> [(CoreExpr, Arity)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Arity
1::Int ..]
rough_args :: [Maybe Name]
rough_args = (CoreExpr -> Maybe Name) -> [CoreExpr] -> [Maybe Name]
forall a b. (a -> b) -> [a] -> [b]
map CoreExpr -> Maybe Name
roughTopName [CoreExpr]
args
check_rule :: CoreRule -> SDoc
check_rule CoreRule
rule = CoreRule -> SDoc
rule_herald CoreRule
rule SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+> RuleOpts -> CoreRule -> SDoc
rule_info (RuleCheckEnv -> RuleOpts
rc_ropts RuleCheckEnv
env) CoreRule
rule
rule_herald :: CoreRule -> SDoc
rule_herald (BuiltinRule { ru_name :: CoreRule -> RuleName
ru_name = RuleName
name })
= String -> SDoc
text String
"Builtin rule" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
doubleQuotes (RuleName -> SDoc
ftext RuleName
name)
rule_herald (Rule { ru_name :: CoreRule -> RuleName
ru_name = RuleName
name })
= String -> SDoc
text String
"Rule" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
doubleQuotes (RuleName -> SDoc
ftext RuleName
name)
rule_info :: RuleOpts -> CoreRule -> SDoc
rule_info RuleOpts
opts CoreRule
rule
| Just CoreExpr
_ <- RuleOpts
-> InScopeEnv
-> (Activation -> Bool)
-> Var
-> [CoreExpr]
-> [Maybe Name]
-> CoreRule
-> Maybe CoreExpr
matchRule RuleOpts
opts (InScopeSet
emptyInScopeSet, RuleCheckEnv -> IdUnfoldingFun
rc_id_unf RuleCheckEnv
env)
Activation -> Bool
noBlackList Var
fn [CoreExpr]
args [Maybe Name]
rough_args CoreRule
rule
= String -> SDoc
text String
"matches (which is very peculiar!)"
rule_info RuleOpts
_ (BuiltinRule {}) = String -> SDoc
text String
"does not match"
rule_info RuleOpts
_ (Rule { ru_act :: CoreRule -> Activation
ru_act = Activation
act,
ru_bndrs :: CoreRule -> [Var]
ru_bndrs = [Var]
rule_bndrs, ru_args :: CoreRule -> [CoreExpr]
ru_args = [CoreExpr]
rule_args})
| Bool -> Bool
not (RuleCheckEnv -> Activation -> Bool
rc_is_active RuleCheckEnv
env Activation
act) = String -> SDoc
text String
"active only in later phase"
| Arity
n_args Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
< Arity
n_rule_args = String -> SDoc
text String
"too few arguments"
| Arity
n_mismatches Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
n_rule_args = String -> SDoc
text String
"no arguments match"
| Arity
n_mismatches Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
0 = String -> SDoc
text String
"all arguments match (considered individually), but rule as a whole does not"
| Bool
otherwise = String -> SDoc
text String
"arguments" SDoc -> SDoc -> SDoc
<+> [Arity] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Arity]
mismatches SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"do not match (1-indexing)"
where
n_rule_args :: Arity
n_rule_args = [CoreExpr] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [CoreExpr]
rule_args
n_mismatches :: Arity
n_mismatches = [Arity] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Arity]
mismatches
mismatches :: [Arity]
mismatches = [Arity
i | (CoreExpr
rule_arg, (CoreExpr
arg,Arity
i)) <- [CoreExpr]
rule_args [CoreExpr]
-> [(CoreExpr, Arity)] -> [(CoreExpr, (CoreExpr, Arity))]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [(CoreExpr, Arity)]
i_args,
Bool -> Bool
not (Maybe RuleSubst -> Bool
forall a. Maybe a -> Bool
isJust (CoreExpr -> CoreExpr -> Maybe RuleSubst
match_fn CoreExpr
rule_arg CoreExpr
arg))]
lhs_fvs :: VarSet
lhs_fvs = [CoreExpr] -> VarSet
exprsFreeVars [CoreExpr]
rule_args
match_fn :: CoreExpr -> CoreExpr -> Maybe RuleSubst
match_fn CoreExpr
rule_arg CoreExpr
arg = RuleMatchEnv
-> RuleSubst
-> CoreExpr
-> CoreExpr
-> MCoercion
-> Maybe RuleSubst
match RuleMatchEnv
renv RuleSubst
emptyRuleSubst CoreExpr
rule_arg CoreExpr
arg MCoercion
MRefl
where
in_scope :: InScopeSet
in_scope = VarSet -> InScopeSet
mkInScopeSet (VarSet
lhs_fvs VarSet -> VarSet -> VarSet
`unionVarSet` CoreExpr -> VarSet
exprFreeVars CoreExpr
arg)
renv :: RuleMatchEnv
renv = RV { rv_lcl :: RnEnv2
rv_lcl = InScopeSet -> RnEnv2
mkRnEnv2 InScopeSet
in_scope
, rv_tmpls :: VarSet
rv_tmpls = [Var] -> VarSet
mkVarSet [Var]
rule_bndrs
, rv_fltR :: Subst
rv_fltR = InScopeSet -> Subst
mkEmptySubst InScopeSet
in_scope
, rv_unf :: IdUnfoldingFun
rv_unf = RuleCheckEnv -> IdUnfoldingFun
rc_id_unf RuleCheckEnv
env }