{-# LANGUAGE CPP #-}
module Rules (
emptyRuleBase, mkRuleBase, extendRuleBaseList,
unionRuleBase, pprRuleBase,
ruleCheckProgram,
mkRuleInfo, extendRuleInfo, addRuleInfo,
addIdSpecialisations,
rulesOfBinds, getRules, pprRulesForUser,
lookupRule, mkRule, roughTopNames
) where
#include "HsVersions.h"
import GhcPrelude
import CoreSyn
import Module ( Module, ModuleSet, elemModuleSet )
import CoreSubst
import CoreOpt ( exprIsLambda_maybe )
import CoreFVs ( exprFreeVars, exprsFreeVars, bindFreeVars
, rulesFreeVarsDSet, exprsOrphNames, exprFreeVarsList )
import CoreUtils ( exprType, eqExpr, mkTick, mkTicks,
stripTicksTopT, stripTicksTopE,
isJoinBind )
import PprCore ( pprRules )
import Type ( Type, TCvSubst, extendTvSubst, extendCvSubst
, mkEmptyTCvSubst, substTy )
import TcType ( tcSplitTyConApp_maybe )
import TysWiredIn ( anyTypeOfKind )
import Coercion
import CoreTidy ( tidyRules )
import Id
import IdInfo ( RuleInfo( RuleInfo ) )
import Var
import VarEnv
import VarSet
import Name ( Name, NamedThing(..), nameIsLocalOrFrom )
import NameSet
import NameEnv
import UniqFM
import Unify ( ruleMatchTyKiX )
import BasicTypes
import DynFlags ( DynFlags )
import Outputable
import FastString
import Maybes
import Bag
import Util
import Data.List
import Data.Ord
import Control.Monad ( guard )
mkRule :: Module -> Bool -> Bool -> RuleName -> Activation
-> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule
mkRule :: Module
-> Bool
-> Bool
-> RuleName
-> Activation
-> Name
-> [CoreBndr]
-> [CoreExpr]
-> CoreExpr
-> CoreRule
mkRule Module
this_mod Bool
is_auto Bool
is_local RuleName
name Activation
act Name
fn [CoreBndr]
bndrs [CoreExpr]
args CoreExpr
rhs
= Rule :: RuleName
-> Activation
-> Name
-> [Maybe Name]
-> [CoreBndr]
-> [CoreExpr]
-> CoreExpr
-> Bool
-> Module
-> IsOrphan
-> Bool
-> CoreRule
Rule { ru_name :: RuleName
ru_name = RuleName
name, ru_fn :: Name
ru_fn = Name
fn, ru_act :: Activation
ru_act = Activation
act,
ru_bndrs :: [CoreBndr]
ru_bndrs = [CoreBndr]
bndrs, ru_args :: [CoreExpr]
ru_args = [CoreExpr]
args,
ru_rhs :: CoreExpr
ru_rhs = 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 Type
ty) = case HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty of
Just (TyCon
tc,[Type]
_) -> Name -> Maybe Name
forall a. a -> Maybe a
Just (TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
tc)
Maybe (TyCon, [Type])
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 CoreBndr
f) | CoreBndr -> Bool
isGlobalId CoreBndr
f
, CoreBndr -> Bool
isDataConWorkId CoreBndr
f Bool -> Bool -> Bool
|| CoreBndr -> Arity
idArity CoreBndr
f Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
> Arity
0
= Name -> Maybe Name
forall a. a -> Maybe a
Just (CoreBndr -> Name
idName CoreBndr
f)
roughTopName (Tick Tickish CoreBndr
t CoreExpr
e) | Tickish CoreBndr -> Bool
forall id. Tickish id -> Bool
tickishFloatable Tickish CoreBndr
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 :: DynFlags -> [CoreRule] -> SDoc
pprRulesForUser :: DynFlags -> [CoreRule] -> SDoc
pprRulesForUser DynFlags
dflags [CoreRule]
rules
= PprStyle -> SDoc -> SDoc
withPprStyle (DynFlags -> PprStyle
defaultUserStyle DynFlags
dflags) (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 ((CoreRule -> RuleName) -> CoreRule -> CoreRule -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing CoreRule -> RuleName
ruleName) ([CoreRule] -> [CoreRule]) -> [CoreRule] -> [CoreRule]
forall a b. (a -> b) -> a -> b
$
TidyEnv -> [CoreRule] -> [CoreRule]
tidyRules TidyEnv
emptyTidyEnv [CoreRule]
rules
mkRuleInfo :: [CoreRule] -> RuleInfo
mkRuleInfo :: [CoreRule] -> RuleInfo
mkRuleInfo [CoreRule]
rules = [CoreRule] -> DVarSet -> RuleInfo
RuleInfo [CoreRule]
rules ([CoreRule] -> DVarSet
rulesFreeVarsDSet [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 :: CoreBndr -> [CoreRule] -> CoreBndr
addIdSpecialisations CoreBndr
id [CoreRule]
rules
| [CoreRule] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreRule]
rules
= CoreBndr
id
| Bool
otherwise
= CoreBndr -> RuleInfo -> CoreBndr
setIdSpecialisation CoreBndr
id (RuleInfo -> CoreBndr) -> RuleInfo -> CoreBndr
forall a b. (a -> b) -> a -> b
$
RuleInfo -> [CoreRule] -> RuleInfo
extendRuleInfo (CoreBndr -> RuleInfo
idSpecialisation CoreBndr
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 ((CoreBndr -> [CoreRule]) -> [CoreBndr] -> [CoreRule]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CoreBndr -> [CoreRule]
idCoreRules ([CoreBndr] -> [CoreRule])
-> (CoreBind -> [CoreBndr]) -> CoreBind -> [CoreRule]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBind -> [CoreBndr]
forall b. Bind b -> [b]
bindersOf) [CoreBind]
binds
getRules :: RuleEnv -> Id -> [CoreRule]
getRules :: RuleEnv -> CoreBndr -> [CoreRule]
getRules (RuleEnv { re_base :: RuleEnv -> RuleBase
re_base = RuleBase
rule_base, re_visible_orphs :: RuleEnv -> ModuleSet
re_visible_orphs = ModuleSet
orphs }) CoreBndr
fn
= CoreBndr -> [CoreRule]
idCoreRules CoreBndr
fn [CoreRule] -> [CoreRule] -> [CoreRule]
forall a. [a] -> [a] -> [a]
++ (CoreRule -> Bool) -> [CoreRule] -> [CoreRule]
forall a. (a -> Bool) -> [a] -> [a]
filter (ModuleSet -> CoreRule -> Bool
ruleIsVisible ModuleSet
orphs) [CoreRule]
imp_rules
where
imp_rules :: [CoreRule]
imp_rules = RuleBase -> Name -> Maybe [CoreRule]
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv RuleBase
rule_base (CoreBndr -> Name
idName CoreBndr
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 (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' RuleBase -> CoreRule -> RuleBase
extendRuleBase RuleBase
rule_base [CoreRule]
new_guys
unionRuleBase :: RuleBase -> RuleBase -> RuleBase
unionRuleBase :: RuleBase -> RuleBase -> RuleBase
unionRuleBase RuleBase
rb1 RuleBase
rb2 = ([CoreRule] -> [CoreRule] -> [CoreRule])
-> RuleBase -> RuleBase -> RuleBase
forall a. (a -> a -> a) -> NameEnv a -> NameEnv a -> NameEnv a
plusNameEnv_C [CoreRule] -> [CoreRule] -> [CoreRule]
forall a. [a] -> [a] -> [a]
(++) RuleBase
rb1 RuleBase
rb2
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]
singleton RuleBase
rule_base (CoreRule -> Name
ruleIdName CoreRule
rule) CoreRule
rule
pprRuleBase :: RuleBase -> SDoc
pprRuleBase :: RuleBase -> SDoc
pprRuleBase RuleBase
rules = RuleBase -> ([[CoreRule]] -> SDoc) -> SDoc
forall a. UniqFM 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 :: DynFlags -> InScopeEnv
-> (Activation -> Bool)
-> Id -> [CoreExpr]
-> [CoreRule] -> Maybe (CoreRule, CoreExpr)
lookupRule :: DynFlags
-> InScopeEnv
-> (Activation -> Bool)
-> CoreBndr
-> [CoreExpr]
-> [CoreRule]
-> Maybe (CoreRule, CoreExpr)
lookupRule DynFlags
dflags InScopeEnv
in_scope Activation -> Bool
is_active CoreBndr
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 ((CoreBndr, [CoreExpr])
-> (CoreRule, CoreExpr)
-> [(CoreRule, CoreExpr)]
-> (CoreRule, CoreExpr)
findBest (CoreBndr
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 ((Tickish CoreBndr -> Bool) -> CoreExpr -> CoreExpr
forall b. (Tickish CoreBndr -> Bool) -> Expr b -> Expr b
stripTicksTopE Tickish CoreBndr -> Bool
forall id. Tickish id -> Bool
tickishFloatable) [CoreExpr]
args
ticks :: [Tickish CoreBndr]
ticks = (CoreExpr -> [Tickish CoreBndr])
-> [CoreExpr] -> [Tickish CoreBndr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Tickish CoreBndr -> Bool) -> CoreExpr -> [Tickish CoreBndr]
forall b.
(Tickish CoreBndr -> Bool) -> Expr b -> [Tickish CoreBndr]
stripTicksTopT Tickish CoreBndr -> Bool
forall id. Tickish id -> 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 <- DynFlags
-> InScopeEnv
-> (Activation -> Bool)
-> CoreBndr
-> [CoreExpr]
-> [Maybe Name]
-> CoreRule
-> Maybe CoreExpr
matchRule DynFlags
dflags InScopeEnv
in_scope Activation -> Bool
is_active CoreBndr
fn [CoreExpr]
args' [Maybe Name]
rough_args CoreRule
r
= [(CoreRule, CoreExpr)] -> [CoreRule] -> [(CoreRule, CoreExpr)]
go ((CoreRule
r,[Tickish CoreBndr] -> CoreExpr -> CoreExpr
mkTicks [Tickish CoreBndr]
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 :: (Id, [CoreExpr])
-> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr)
findBest :: (CoreBndr, [CoreExpr])
-> (CoreRule, CoreExpr)
-> [(CoreRule, CoreExpr)]
-> (CoreRule, CoreExpr)
findBest (CoreBndr, [CoreExpr])
_ (CoreRule
rule,CoreExpr
ans) [] = (CoreRule
rule,CoreExpr
ans)
findBest (CoreBndr, [CoreExpr])
target (CoreRule
rule1,CoreExpr
ans1) ((CoreRule
rule2,CoreExpr
ans2):[(CoreRule, CoreExpr)]
prs)
| CoreRule
rule1 CoreRule -> CoreRule -> Bool
`isMoreSpecific` CoreRule
rule2 = (CoreBndr, [CoreExpr])
-> (CoreRule, CoreExpr)
-> [(CoreRule, CoreExpr)]
-> (CoreRule, CoreExpr)
findBest (CoreBndr, [CoreExpr])
target (CoreRule
rule1,CoreExpr
ans1) [(CoreRule, CoreExpr)]
prs
| CoreRule
rule2 CoreRule -> CoreRule -> Bool
`isMoreSpecific` CoreRule
rule1 = (CoreBndr, [CoreExpr])
-> (CoreRule, CoreExpr)
-> [(CoreRule, CoreExpr)]
-> (CoreRule, CoreExpr)
findBest (CoreBndr, [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
<+> CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBndr
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
$
(CoreBndr, [CoreExpr])
-> (CoreRule, CoreExpr)
-> [(CoreRule, CoreExpr)]
-> (CoreRule, CoreExpr)
findBest (CoreBndr, [CoreExpr])
target (CoreRule
rule1,CoreExpr
ans1) [(CoreRule, CoreExpr)]
prs
| Bool
otherwise = (CoreBndr, [CoreExpr])
-> (CoreRule, CoreExpr)
-> [(CoreRule, CoreExpr)]
-> (CoreRule, CoreExpr)
findBest (CoreBndr, [CoreExpr])
target (CoreRule
rule1,CoreExpr
ans1) [(CoreRule, CoreExpr)]
prs
where
(CoreBndr
fn,[CoreExpr]
args) = (CoreBndr, [CoreExpr])
target
isMoreSpecific :: CoreRule -> CoreRule -> Bool
isMoreSpecific :: CoreRule -> CoreRule -> Bool
isMoreSpecific (BuiltinRule {}) CoreRule
_ = Bool
False
isMoreSpecific (Rule {}) (BuiltinRule {}) = Bool
True
isMoreSpecific (Rule { ru_bndrs :: CoreRule -> [CoreBndr]
ru_bndrs = [CoreBndr]
bndrs1, ru_args :: CoreRule -> [CoreExpr]
ru_args = [CoreExpr]
args1 })
(Rule { ru_bndrs :: CoreRule -> [CoreBndr]
ru_bndrs = [CoreBndr]
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
rhs })
= Maybe CoreExpr -> Bool
forall a. Maybe a -> Bool
isJust (InScopeEnv
-> RuleName
-> [CoreBndr]
-> [CoreExpr]
-> [CoreExpr]
-> CoreExpr
-> Maybe CoreExpr
matchN (InScopeSet
in_scope, CoreBndr -> Unfolding
forall p. p -> Unfolding
id_unfolding_fun) RuleName
rule_name2 [CoreBndr]
bndrs2 [CoreExpr]
args2 [CoreExpr]
args1 CoreExpr
rhs)
where
id_unfolding_fun :: p -> Unfolding
id_unfolding_fun p
_ = Unfolding
NoUnfolding
in_scope :: InScopeSet
in_scope = VarSet -> InScopeSet
mkInScopeSet ([CoreBndr] -> VarSet
mkVarSet [CoreBndr]
bndrs1)
noBlackList :: Activation -> Bool
noBlackList :: Activation -> Bool
noBlackList Activation
_ = Bool
False
matchRule :: DynFlags -> InScopeEnv -> (Activation -> Bool)
-> Id -> [CoreExpr] -> [Maybe Name]
-> CoreRule -> Maybe CoreExpr
matchRule :: DynFlags
-> InScopeEnv
-> (Activation -> Bool)
-> CoreBndr
-> [CoreExpr]
-> [Maybe Name]
-> CoreRule
-> Maybe CoreExpr
matchRule DynFlags
dflags InScopeEnv
rule_env Activation -> Bool
_is_active CoreBndr
fn [CoreExpr]
args [Maybe Name]
_rough_args
(BuiltinRule { ru_try :: CoreRule -> RuleFun
ru_try = RuleFun
match_fn })
= case RuleFun
match_fn DynFlags
dflags InScopeEnv
rule_env CoreBndr
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 DynFlags
_ InScopeEnv
in_scope Activation -> Bool
is_active CoreBndr
_ [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 -> [CoreBndr]
ru_bndrs = [CoreBndr]
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
-> [CoreBndr]
-> [CoreExpr]
-> [CoreExpr]
-> CoreExpr
-> Maybe CoreExpr
matchN InScopeEnv
in_scope RuleName
rule_name [CoreBndr]
tpl_vars [CoreExpr]
tpl_args [CoreExpr]
args CoreExpr
rhs
matchN :: InScopeEnv
-> RuleName -> [Var] -> [CoreExpr]
-> [CoreExpr] -> CoreExpr
-> Maybe CoreExpr
matchN :: InScopeEnv
-> RuleName
-> [CoreBndr]
-> [CoreExpr]
-> [CoreExpr]
-> CoreExpr
-> Maybe CoreExpr
matchN (InScopeSet
in_scope, CoreBndr -> Unfolding
id_unf) RuleName
rule_name [CoreBndr]
tmpl_vars [CoreExpr]
tmpl_es [CoreExpr]
target_es CoreExpr
rhs
= do { RuleSubst
rule_subst <- RuleMatchEnv
-> RuleSubst -> [CoreExpr] -> [CoreExpr] -> Maybe RuleSubst
go RuleMatchEnv
init_menv RuleSubst
emptyRuleSubst [CoreExpr]
tmpl_es [CoreExpr]
target_es
; let (TCvSubst
_, [CoreExpr]
matched_es) = (TCvSubst -> (CoreBndr, CoreBndr) -> (TCvSubst, CoreExpr))
-> TCvSubst -> [(CoreBndr, CoreBndr)] -> (TCvSubst, [CoreExpr])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (RuleSubst
-> TCvSubst -> (CoreBndr, CoreBndr) -> (TCvSubst, CoreExpr)
lookup_tmpl RuleSubst
rule_subst)
(InScopeSet -> TCvSubst
mkEmptyTCvSubst InScopeSet
in_scope) ([(CoreBndr, CoreBndr)] -> (TCvSubst, [CoreExpr]))
-> [(CoreBndr, CoreBndr)] -> (TCvSubst, [CoreExpr])
forall a b. (a -> b) -> a -> b
$
[CoreBndr]
tmpl_vars [CoreBndr] -> [CoreBndr] -> [(CoreBndr, CoreBndr)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [CoreBndr]
tmpl_vars1
bind_wrapper :: CoreExpr -> CoreExpr
bind_wrapper = RuleSubst -> CoreExpr -> CoreExpr
rs_binds RuleSubst
rule_subst
; CoreExpr -> Maybe CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> CoreExpr
bind_wrapper (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
[CoreBndr] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [CoreBndr]
tmpl_vars CoreExpr
rhs CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
`mkApps` [CoreExpr]
matched_es) }
where
(RnEnv2
init_rn_env, [CoreBndr]
tmpl_vars1) = (RnEnv2 -> CoreBndr -> (RnEnv2, CoreBndr))
-> RnEnv2 -> [CoreBndr] -> (RnEnv2, [CoreBndr])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL RnEnv2 -> CoreBndr -> (RnEnv2, CoreBndr)
rnBndrL (InScopeSet -> RnEnv2
mkRnEnv2 InScopeSet
in_scope) [CoreBndr]
tmpl_vars
init_menv :: RuleMatchEnv
init_menv = RV :: RnEnv2
-> VarSet -> Subst -> (CoreBndr -> Unfolding) -> RuleMatchEnv
RV { rv_tmpls :: VarSet
rv_tmpls = [CoreBndr] -> VarSet
mkVarSet [CoreBndr]
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 :: CoreBndr -> Unfolding
rv_unf = CoreBndr -> Unfolding
id_unf }
go :: RuleMatchEnv
-> RuleSubst -> [CoreExpr] -> [CoreExpr] -> Maybe RuleSubst
go RuleMatchEnv
_ RuleSubst
subst [] [CoreExpr]
_ = RuleSubst -> Maybe RuleSubst
forall a. a -> Maybe a
Just RuleSubst
subst
go RuleMatchEnv
_ RuleSubst
_ [CoreExpr]
_ [] = Maybe RuleSubst
forall a. Maybe a
Nothing
go RuleMatchEnv
menv RuleSubst
subst (CoreExpr
t:[CoreExpr]
ts) (CoreExpr
e:[CoreExpr]
es) = do { RuleSubst
subst1 <- RuleMatchEnv
-> RuleSubst -> CoreExpr -> CoreExpr -> Maybe RuleSubst
match RuleMatchEnv
menv RuleSubst
subst CoreExpr
t CoreExpr
e
; RuleMatchEnv
-> RuleSubst -> [CoreExpr] -> [CoreExpr] -> Maybe RuleSubst
go RuleMatchEnv
menv RuleSubst
subst1 [CoreExpr]
ts [CoreExpr]
es }
lookup_tmpl :: RuleSubst -> TCvSubst -> (InVar,OutVar) -> (TCvSubst, CoreExpr)
lookup_tmpl :: RuleSubst
-> TCvSubst -> (CoreBndr, CoreBndr) -> (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 (CoreBndr
tmpl_var, CoreBndr
tmpl_var1)
| CoreBndr -> Bool
isId CoreBndr
tmpl_var1
= case IdSubstEnv -> CoreBndr -> Maybe CoreExpr
forall a. VarEnv a -> CoreBndr -> Maybe a
lookupVarEnv IdSubstEnv
id_subst CoreBndr
tmpl_var1 of
Just CoreExpr
e | Coercion Coercion
co <- CoreExpr
e
-> (TCvSubst -> CoreBndr -> Coercion -> TCvSubst
Type.extendCvSubst TCvSubst
tcv_subst CoreBndr
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 <- CoreBndr -> Maybe Coercion
isReflCoVar_maybe CoreBndr
tmpl_var1
, let co :: Coercion
co = HasCallStack => TCvSubst -> Coercion -> Coercion
TCvSubst -> Coercion -> Coercion
Coercion.substCo TCvSubst
tcv_subst Coercion
refl_co
->
(TCvSubst -> CoreBndr -> Coercion -> TCvSubst
Type.extendCvSubst TCvSubst
tcv_subst CoreBndr
tmpl_var1 Coercion
co, Coercion -> CoreExpr
forall b. Coercion -> Expr b
Coercion Coercion
co)
| Bool
otherwise
-> CoreBndr -> (TCvSubst, CoreExpr)
forall a. CoreBndr -> a
unbound CoreBndr
tmpl_var
| Bool
otherwise
= (TCvSubst -> CoreBndr -> Type -> TCvSubst
Type.extendTvSubst TCvSubst
tcv_subst CoreBndr
tmpl_var1 Type
ty', Type -> CoreExpr
forall b. Type -> Expr b
Type Type
ty')
where
ty' :: Type
ty' = case TvSubstEnv -> CoreBndr -> Maybe Type
forall a. VarEnv a -> CoreBndr -> Maybe a
lookupVarEnv TvSubstEnv
tv_subst CoreBndr
tmpl_var1 of
Just Type
ty -> Type
ty
Maybe Type
Nothing -> Type
fake_ty
fake_ty :: Type
fake_ty = Type -> Type
anyTypeOfKind (HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
Type.substTy TCvSubst
tcv_subst (CoreBndr -> Type
tyVarKind CoreBndr
tmpl_var1))
unbound :: CoreBndr -> a
unbound CoreBndr
tmpl_var
= String -> SDoc -> a
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Template variable unbound in rewrite rule" (SDoc -> a) -> SDoc -> a
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Variable:" SDoc -> SDoc -> SDoc
<+> CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBndr
tmpl_var SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CoreBndr -> Type
varType CoreBndr
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
<+> [CoreBndr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreBndr]
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 -> CoreBndr -> Unfolding
rv_unf :: IdUnfoldingFun
}
rvInScopeEnv :: RuleMatchEnv -> InScopeEnv
rvInScopeEnv :: RuleMatchEnv -> InScopeEnv
rvInScopeEnv RuleMatchEnv
renv = (RnEnv2 -> InScopeSet
rnInScopeSet (RuleMatchEnv -> RnEnv2
rv_lcl RuleMatchEnv
renv), RuleMatchEnv -> CoreBndr -> Unfolding
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 -> VarSet
rs_bndrs :: VarSet
}
type BindWrapper = CoreExpr -> CoreExpr
emptyRuleSubst :: RuleSubst
emptyRuleSubst :: RuleSubst
emptyRuleSubst = RS :: TvSubstEnv
-> IdSubstEnv -> (CoreExpr -> CoreExpr) -> VarSet -> RuleSubst
RS { rs_tv_subst :: TvSubstEnv
rs_tv_subst = TvSubstEnv
forall a. NameEnv a
emptyVarEnv, rs_id_subst :: IdSubstEnv
rs_id_subst = IdSubstEnv
forall a. NameEnv a
emptyVarEnv
, rs_binds :: CoreExpr -> CoreExpr
rs_binds = \CoreExpr
e -> CoreExpr
e, rs_bndrs :: VarSet
rs_bndrs = VarSet
emptyVarSet }
match :: RuleMatchEnv
-> RuleSubst
-> CoreExpr
-> CoreExpr
-> Maybe RuleSubst
match :: RuleMatchEnv
-> RuleSubst -> CoreExpr -> CoreExpr -> Maybe RuleSubst
match RuleMatchEnv
renv RuleSubst
subst CoreExpr
e1 (Tick Tickish CoreBndr
t CoreExpr
e2)
| Tickish CoreBndr -> Bool
forall id. Tickish id -> Bool
tickishFloatable Tickish CoreBndr
t
= RuleMatchEnv
-> RuleSubst -> CoreExpr -> CoreExpr -> Maybe RuleSubst
match RuleMatchEnv
renv RuleSubst
subst' CoreExpr
e1 CoreExpr
e2
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
. Tickish CoreBndr -> CoreExpr -> CoreExpr
mkTick Tickish CoreBndr
t }
match RuleMatchEnv
_ RuleSubst
_ e :: CoreExpr
e@Tick{} CoreExpr
_
= 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 (Var CoreBndr
v1) CoreExpr
e2
= RuleMatchEnv
-> RuleSubst -> CoreBndr -> CoreExpr -> Maybe RuleSubst
match_var RuleMatchEnv
renv RuleSubst
subst CoreBndr
v1 CoreExpr
e2
match RuleMatchEnv
renv RuleSubst
subst CoreExpr
e1 (Var CoreBndr
v2)
| Bool -> Bool
not (RnEnv2 -> CoreBndr -> Bool
inRnEnvR RnEnv2
rn_env CoreBndr
v2)
, Just CoreExpr
e2' <- Unfolding -> Maybe CoreExpr
expandUnfolding_maybe (RuleMatchEnv -> CoreBndr -> Unfolding
rv_unf RuleMatchEnv
renv CoreBndr
v2')
= RuleMatchEnv
-> RuleSubst -> CoreExpr -> CoreExpr -> Maybe RuleSubst
match (RuleMatchEnv
renv { rv_lcl :: RnEnv2
rv_lcl = RnEnv2 -> RnEnv2
nukeRnEnvR RnEnv2
rn_env }) RuleSubst
subst CoreExpr
e1 CoreExpr
e2'
where
v2' :: CoreBndr
v2' = RnEnv2 -> CoreBndr -> CoreBndr
lookupRnInScope RnEnv2
rn_env CoreBndr
v2
rn_env :: RnEnv2
rn_env = RuleMatchEnv -> RnEnv2
rv_lcl RuleMatchEnv
renv
match RuleMatchEnv
renv RuleSubst
subst CoreExpr
e1 (Let CoreBind
bind CoreExpr
e2)
|
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 -> Maybe RuleSubst
match (RuleMatchEnv
renv { rv_fltR :: Subst
rv_fltR = Subst
flt_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
. CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let CoreBind
bind'
, rs_bndrs :: VarSet
rs_bndrs = VarSet -> [CoreBndr] -> VarSet
extendVarSetList (RuleSubst -> VarSet
rs_bndrs RuleSubst
subst) [CoreBndr]
new_bndrs })
CoreExpr
e1 CoreExpr
e2
where
flt_subst :: Subst
flt_subst = Subst -> VarSet -> Subst
addInScopeSet (RuleMatchEnv -> Subst
rv_fltR RuleMatchEnv
renv) (RuleSubst -> VarSet
rs_bndrs RuleSubst
subst)
(Subst
flt_subst', CoreBind
bind') = Subst -> CoreBind -> (Subst, CoreBind)
substBind Subst
flt_subst CoreBind
bind
new_bndrs :: [CoreBndr]
new_bndrs = CoreBind -> [CoreBndr]
forall b. Bind b -> [b]
bindersOf CoreBind
bind'
match RuleMatchEnv
_ RuleSubst
subst (Lit Literal
lit1) (Lit Literal
lit2)
| Literal
lit1 Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Literal
lit2
= RuleSubst -> Maybe RuleSubst
forall a. a -> Maybe a
Just RuleSubst
subst
match RuleMatchEnv
renv RuleSubst
subst (App CoreExpr
f1 CoreExpr
a1) (App CoreExpr
f2 CoreExpr
a2)
= do { RuleSubst
subst' <- RuleMatchEnv
-> RuleSubst -> CoreExpr -> CoreExpr -> Maybe RuleSubst
match RuleMatchEnv
renv RuleSubst
subst CoreExpr
f1 CoreExpr
f2
; RuleMatchEnv
-> RuleSubst -> CoreExpr -> CoreExpr -> Maybe RuleSubst
match RuleMatchEnv
renv RuleSubst
subst' CoreExpr
a1 CoreExpr
a2 }
match RuleMatchEnv
renv RuleSubst
subst (Lam CoreBndr
x1 CoreExpr
e1) CoreExpr
e2
| Just (CoreBndr
x2, CoreExpr
e2, [Tickish CoreBndr]
ts) <- InScopeEnv
-> CoreExpr -> Maybe (CoreBndr, CoreExpr, [Tickish CoreBndr])
exprIsLambda_maybe (RuleMatchEnv -> InScopeEnv
rvInScopeEnv RuleMatchEnv
renv) CoreExpr
e2
= let renv' :: RuleMatchEnv
renv' = RuleMatchEnv
renv { rv_lcl :: RnEnv2
rv_lcl = RnEnv2 -> CoreBndr -> CoreBndr -> RnEnv2
rnBndr2 (RuleMatchEnv -> RnEnv2
rv_lcl RuleMatchEnv
renv) CoreBndr
x1 CoreBndr
x2
, rv_fltR :: Subst
rv_fltR = Subst -> CoreBndr -> Subst
delBndr (RuleMatchEnv -> Subst
rv_fltR RuleMatchEnv
renv) CoreBndr
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 -> [Tickish CoreBndr] -> CoreExpr)
-> [Tickish CoreBndr] -> CoreExpr -> CoreExpr
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Tickish CoreBndr -> CoreExpr -> CoreExpr)
-> CoreExpr -> [Tickish CoreBndr] -> CoreExpr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Tickish CoreBndr -> CoreExpr -> CoreExpr
mkTick) [Tickish CoreBndr]
ts }
in RuleMatchEnv
-> RuleSubst -> CoreExpr -> CoreExpr -> Maybe RuleSubst
match RuleMatchEnv
renv' RuleSubst
subst' CoreExpr
e1 CoreExpr
e2
match RuleMatchEnv
renv RuleSubst
subst (Case CoreExpr
e1 CoreBndr
x1 Type
ty1 [Alt CoreBndr]
alts1) (Case CoreExpr
e2 CoreBndr
x2 Type
ty2 [Alt CoreBndr]
alts2)
= do { RuleSubst
subst1 <- RuleMatchEnv -> RuleSubst -> Type -> Type -> Maybe RuleSubst
match_ty RuleMatchEnv
renv RuleSubst
subst Type
ty1 Type
ty2
; RuleSubst
subst2 <- RuleMatchEnv
-> RuleSubst -> CoreExpr -> CoreExpr -> Maybe RuleSubst
match RuleMatchEnv
renv RuleSubst
subst1 CoreExpr
e1 CoreExpr
e2
; let renv' :: RuleMatchEnv
renv' = RuleMatchEnv -> RuleSubst -> CoreBndr -> CoreBndr -> RuleMatchEnv
rnMatchBndr2 RuleMatchEnv
renv RuleSubst
subst CoreBndr
x1 CoreBndr
x2
; RuleMatchEnv
-> RuleSubst -> [Alt CoreBndr] -> [Alt CoreBndr] -> Maybe RuleSubst
match_alts RuleMatchEnv
renv' RuleSubst
subst2 [Alt CoreBndr]
alts1 [Alt CoreBndr]
alts2
}
match RuleMatchEnv
renv RuleSubst
subst (Type Type
ty1) (Type Type
ty2)
= RuleMatchEnv -> RuleSubst -> Type -> Type -> Maybe RuleSubst
match_ty RuleMatchEnv
renv RuleSubst
subst Type
ty1 Type
ty2
match RuleMatchEnv
renv RuleSubst
subst (Coercion Coercion
co1) (Coercion Coercion
co2)
= RuleMatchEnv
-> RuleSubst -> Coercion -> Coercion -> Maybe RuleSubst
match_co RuleMatchEnv
renv RuleSubst
subst Coercion
co1 Coercion
co2
match RuleMatchEnv
renv RuleSubst
subst (Cast CoreExpr
e1 Coercion
co1) (Cast CoreExpr
e2 Coercion
co2)
= do { RuleSubst
subst1 <- RuleMatchEnv
-> RuleSubst -> Coercion -> Coercion -> Maybe RuleSubst
match_co RuleMatchEnv
renv RuleSubst
subst Coercion
co1 Coercion
co2
; RuleMatchEnv
-> RuleSubst -> CoreExpr -> CoreExpr -> Maybe RuleSubst
match RuleMatchEnv
renv RuleSubst
subst1 CoreExpr
e1 CoreExpr
e2 }
match RuleMatchEnv
_ RuleSubst
_ CoreExpr
_e1 CoreExpr
_e2 =
Maybe RuleSubst
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 CoreBndr
cv <- Coercion -> Maybe CoreBndr
getCoVar_maybe Coercion
co1
= RuleMatchEnv
-> RuleSubst -> CoreBndr -> CoreExpr -> Maybe RuleSubst
match_var RuleMatchEnv
renv RuleSubst
subst CoreBndr
cv (Coercion -> CoreExpr
forall b. Coercion -> Expr b
Coercion Coercion
co2)
| Just (Type
ty1, Role
r1) <- Coercion -> Maybe (Type, Role)
isReflCo_maybe Coercion
co1
= do { (Type
ty2, Role
r2) <- Coercion -> Maybe (Type, 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 -> Type -> Type -> Maybe RuleSubst
match_ty RuleMatchEnv
renv RuleSubst
subst Type
ty1 Type
ty2 }
match_co RuleMatchEnv
renv RuleSubst
subst Coercion
co1 Coercion
co2
| Just (TyCon
tc1, [Coercion]
cos1) <- Coercion -> Maybe (TyCon, [Coercion])
splitTyConAppCo_maybe Coercion
co1
= case Coercion -> Maybe (TyCon, [Coercion])
splitTyConAppCo_maybe Coercion
co2 of
Just (TyCon
tc2, [Coercion]
cos2)
| TyCon
tc1 TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tc2
-> RuleMatchEnv
-> RuleSubst -> [Coercion] -> [Coercion] -> Maybe RuleSubst
match_cos RuleMatchEnv
renv RuleSubst
subst [Coercion]
cos1 [Coercion]
cos2
Maybe (TyCon, [Coercion])
_ -> Maybe RuleSubst
forall a. Maybe a
Nothing
match_co RuleMatchEnv
renv RuleSubst
subst Coercion
co1 Coercion
co2
| Just (Coercion
arg1, Coercion
res1) <- Coercion -> Maybe (Coercion, Coercion)
splitFunCo_maybe Coercion
co1
= case Coercion -> Maybe (Coercion, Coercion)
splitFunCo_maybe Coercion
co2 of
Just (Coercion
arg2, Coercion
res2)
-> RuleMatchEnv
-> RuleSubst -> [Coercion] -> [Coercion] -> Maybe RuleSubst
match_cos RuleMatchEnv
renv RuleSubst
subst [Coercion
arg1, Coercion
res1] [Coercion
arg2, Coercion
res2]
Maybe (Coercion, Coercion)
_ -> Maybe RuleSubst
forall a. Maybe a
Nothing
match_co RuleMatchEnv
_ RuleSubst
_ Coercion
_co1 Coercion
_co2
#if defined(DEBUG)
= pprTrace "match_co: needs more cases" (ppr _co1 $$ ppr _co2) Nothing
#else
= Maybe RuleSubst
forall a. Maybe a
Nothing
#endif
match_cos :: RuleMatchEnv
-> RuleSubst
-> [Coercion]
-> [Coercion]
-> Maybe RuleSubst
match_cos :: RuleMatchEnv
-> RuleSubst -> [Coercion] -> [Coercion] -> Maybe RuleSubst
match_cos RuleMatchEnv
renv RuleSubst
subst (Coercion
co1:[Coercion]
cos1) (Coercion
co2:[Coercion]
cos2) =
do { RuleSubst
subst' <- RuleMatchEnv
-> RuleSubst -> Coercion -> Coercion -> Maybe RuleSubst
match_co RuleMatchEnv
renv RuleSubst
subst Coercion
co1 Coercion
co2
; RuleMatchEnv
-> RuleSubst -> [Coercion] -> [Coercion] -> Maybe RuleSubst
match_cos RuleMatchEnv
renv RuleSubst
subst' [Coercion]
cos1 [Coercion]
cos2 }
match_cos RuleMatchEnv
_ RuleSubst
subst [] [] = RuleSubst -> Maybe RuleSubst
forall a. a -> Maybe a
Just RuleSubst
subst
match_cos RuleMatchEnv
_ RuleSubst
_ [Coercion]
cos1 [Coercion]
cos2 = String -> SDoc -> Maybe RuleSubst -> Maybe RuleSubst
forall a. String -> SDoc -> a -> a
pprTrace String
"match_cos: not same length" ([Coercion] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Coercion]
cos1 SDoc -> SDoc -> SDoc
$$ [Coercion] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Coercion]
cos2) Maybe RuleSubst
forall a. Maybe a
Nothing
rnMatchBndr2 :: RuleMatchEnv -> RuleSubst -> Var -> Var -> RuleMatchEnv
rnMatchBndr2 :: RuleMatchEnv -> RuleSubst -> CoreBndr -> CoreBndr -> RuleMatchEnv
rnMatchBndr2 RuleMatchEnv
renv RuleSubst
subst CoreBndr
x1 CoreBndr
x2
= RuleMatchEnv
renv { rv_lcl :: RnEnv2
rv_lcl = RnEnv2 -> CoreBndr -> CoreBndr -> RnEnv2
rnBndr2 RnEnv2
rn_env CoreBndr
x1 CoreBndr
x2
, rv_fltR :: Subst
rv_fltR = Subst -> CoreBndr -> Subst
delBndr (RuleMatchEnv -> Subst
rv_fltR RuleMatchEnv
renv) CoreBndr
x2 }
where
rn_env :: RnEnv2
rn_env = RnEnv2 -> VarSet -> RnEnv2
addRnInScopeSet (RuleMatchEnv -> RnEnv2
rv_lcl RuleMatchEnv
renv) (RuleSubst -> VarSet
rs_bndrs RuleSubst
subst)
match_alts :: RuleMatchEnv
-> RuleSubst
-> [CoreAlt]
-> [CoreAlt]
-> Maybe RuleSubst
match_alts :: RuleMatchEnv
-> RuleSubst -> [Alt CoreBndr] -> [Alt CoreBndr] -> Maybe RuleSubst
match_alts RuleMatchEnv
_ RuleSubst
subst [] []
= RuleSubst -> Maybe RuleSubst
forall (m :: * -> *) a. Monad m => a -> m a
return RuleSubst
subst
match_alts RuleMatchEnv
renv RuleSubst
subst ((AltCon
c1,[CoreBndr]
vs1,CoreExpr
r1):[Alt CoreBndr]
alts1) ((AltCon
c2,[CoreBndr]
vs2,CoreExpr
r2):[Alt CoreBndr]
alts2)
| AltCon
c1 AltCon -> AltCon -> Bool
forall a. Eq a => a -> a -> Bool
== AltCon
c2
= do { RuleSubst
subst1 <- RuleMatchEnv
-> RuleSubst -> CoreExpr -> CoreExpr -> Maybe RuleSubst
match RuleMatchEnv
renv' RuleSubst
subst CoreExpr
r1 CoreExpr
r2
; RuleMatchEnv
-> RuleSubst -> [Alt CoreBndr] -> [Alt CoreBndr] -> Maybe RuleSubst
match_alts RuleMatchEnv
renv RuleSubst
subst1 [Alt CoreBndr]
alts1 [Alt CoreBndr]
alts2 }
where
renv' :: RuleMatchEnv
renv' = (RuleMatchEnv -> (CoreBndr, CoreBndr) -> RuleMatchEnv)
-> RuleMatchEnv -> [(CoreBndr, CoreBndr)] -> RuleMatchEnv
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' RuleMatchEnv -> (CoreBndr, CoreBndr) -> RuleMatchEnv
mb RuleMatchEnv
renv ([CoreBndr]
vs1 [CoreBndr] -> [CoreBndr] -> [(CoreBndr, CoreBndr)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [CoreBndr]
vs2)
mb :: RuleMatchEnv -> (CoreBndr, CoreBndr) -> RuleMatchEnv
mb RuleMatchEnv
renv (CoreBndr
v1,CoreBndr
v2) = RuleMatchEnv -> RuleSubst -> CoreBndr -> CoreBndr -> RuleMatchEnv
rnMatchBndr2 RuleMatchEnv
renv RuleSubst
subst CoreBndr
v1 CoreBndr
v2
match_alts RuleMatchEnv
_ RuleSubst
_ [Alt CoreBndr]
_ [Alt CoreBndr]
_
= Maybe RuleSubst
forall a. Maybe a
Nothing
okToFloat :: RnEnv2 -> VarSet -> Bool
okToFloat :: RnEnv2 -> VarSet -> Bool
okToFloat RnEnv2
rn_env VarSet
bind_fvs
= (CoreBndr -> Bool) -> VarSet -> Bool
allVarSet CoreBndr -> Bool
not_captured VarSet
bind_fvs
where
not_captured :: CoreBndr -> Bool
not_captured CoreBndr
fv = Bool -> Bool
not (RnEnv2 -> CoreBndr -> Bool
inRnEnvR RnEnv2
rn_env CoreBndr
fv)
match_var :: RuleMatchEnv
-> RuleSubst
-> Var
-> CoreExpr
-> Maybe RuleSubst
match_var :: RuleMatchEnv
-> RuleSubst -> CoreBndr -> 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 CoreBndr
v1 CoreExpr
e2
| CoreBndr
v1' CoreBndr -> VarSet -> Bool
`elemVarSet` VarSet
tmpls
= RuleMatchEnv
-> RuleSubst -> CoreBndr -> CoreExpr -> Maybe RuleSubst
match_tmpl_var RuleMatchEnv
renv RuleSubst
subst CoreBndr
v1' CoreExpr
e2
| Bool
otherwise
= case CoreExpr
e2 of
Var CoreBndr
v2 | CoreBndr
v1' CoreBndr -> CoreBndr -> Bool
forall a. Eq a => a -> a -> Bool
== RnEnv2 -> CoreBndr -> CoreBndr
rnOccR RnEnv2
rn_env CoreBndr
v2
-> RuleSubst -> Maybe RuleSubst
forall a. a -> Maybe a
Just RuleSubst
subst
| Var CoreBndr
v2' <- SDoc -> Subst -> CoreBndr -> CoreExpr
lookupIdSubst (String -> SDoc
text String
"match_var") Subst
flt_env CoreBndr
v2
, CoreBndr
v1' CoreBndr -> CoreBndr -> Bool
forall a. Eq a => a -> a -> Bool
== CoreBndr
v2'
-> RuleSubst -> Maybe RuleSubst
forall a. a -> Maybe a
Just RuleSubst
subst
CoreExpr
_ -> Maybe RuleSubst
forall a. Maybe a
Nothing
where
v1' :: CoreBndr
v1' = RnEnv2 -> CoreBndr -> CoreBndr
rnOccL RnEnv2
rn_env CoreBndr
v1
match_tmpl_var :: RuleMatchEnv
-> RuleSubst
-> Var
-> CoreExpr
-> Maybe RuleSubst
match_tmpl_var :: RuleMatchEnv
-> RuleSubst -> CoreBndr -> 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 -> VarSet
rs_bndrs = VarSet
let_bndrs })
CoreBndr
v1' CoreExpr
e2
| (CoreBndr -> Bool) -> [CoreBndr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (RnEnv2 -> CoreBndr -> Bool
inRnEnvR RnEnv2
rn_env) (CoreExpr -> [CoreBndr]
exprFreeVarsList CoreExpr
e2)
= Maybe RuleSubst
forall a. Maybe a
Nothing
| Just CoreExpr
e1' <- IdSubstEnv -> CoreBndr -> Maybe CoreExpr
forall a. VarEnv a -> CoreBndr -> Maybe a
lookupVarEnv IdSubstEnv
id_subst CoreBndr
v1'
= if InScopeSet -> CoreExpr -> CoreExpr -> Bool
eqExpr (RnEnv2 -> InScopeSet
rnInScopeSet RnEnv2
rn_env) 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 -> Type -> Type -> Maybe RuleSubst
match_ty RuleMatchEnv
renv RuleSubst
subst (CoreBndr -> Type
idType CoreBndr
v1') (CoreExpr -> Type
exprType CoreExpr
e2)
; RuleSubst -> Maybe RuleSubst
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' | VarSet -> Bool
isEmptyVarSet VarSet
let_bndrs = CoreExpr
e2
| Bool
otherwise = SDoc -> Subst -> CoreExpr -> CoreExpr
substExpr (String -> SDoc
text String
"match_tmpl_var") Subst
flt_env CoreExpr
e2
id_subst' :: IdSubstEnv
id_subst' = IdSubstEnv -> CoreBndr -> CoreExpr -> IdSubstEnv
forall a. VarEnv a -> CoreBndr -> a -> VarEnv a
extendVarEnv (RuleSubst -> IdSubstEnv
rs_id_subst RuleSubst
subst) CoreBndr
v1' CoreExpr
e2'
match_ty :: RuleMatchEnv
-> RuleSubst
-> Type
-> Type
-> Maybe RuleSubst
match_ty :: RuleMatchEnv -> RuleSubst -> Type -> Type -> Maybe RuleSubst
match_ty RuleMatchEnv
renv RuleSubst
subst Type
ty1 Type
ty2
= do { TvSubstEnv
tv_subst'
<- VarSet -> RnEnv2 -> TvSubstEnv -> Type -> Type -> Maybe TvSubstEnv
Unify.ruleMatchTyKiX (RuleMatchEnv -> VarSet
rv_tmpls RuleMatchEnv
renv) (RuleMatchEnv -> RnEnv2
rv_lcl RuleMatchEnv
renv) TvSubstEnv
tv_subst Type
ty1 Type
ty2
; RuleSubst -> Maybe RuleSubst
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 :: CompilerPhase
-> String
-> (Id -> [CoreRule])
-> CoreProgram
-> SDoc
ruleCheckProgram :: CompilerPhase
-> String -> (CoreBndr -> [CoreRule]) -> [CoreBind] -> SDoc
ruleCheckProgram CompilerPhase
phase String
rule_pat CoreBndr -> [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 :: (Activation -> Bool)
-> (CoreBndr -> Unfolding)
-> String
-> (CoreBndr -> [CoreRule])
-> RuleCheckEnv
RuleCheckEnv { rc_is_active :: Activation -> Bool
rc_is_active = CompilerPhase -> Activation -> Bool
isActive CompilerPhase
phase
, rc_id_unf :: CoreBndr -> Unfolding
rc_id_unf = CoreBndr -> Unfolding
idUnfolding
, rc_pattern :: String
rc_pattern = String
rule_pat
, rc_rules :: CoreBndr -> [CoreRule]
rc_rules = CoreBndr -> [CoreRule]
rules }
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 -> CoreBndr -> Unfolding
rc_id_unf :: IdUnfoldingFun,
RuleCheckEnv -> String
rc_pattern :: String,
RuleCheckEnv -> CoreBndr -> [CoreRule]
rc_rules :: Id -> [CoreRule]
}
ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
ruleCheckBind RuleCheckEnv
env (NonRec CoreBndr
_ CoreExpr
r) = RuleCheckEnv -> CoreExpr -> Bag SDoc
ruleCheck RuleCheckEnv
env CoreExpr
r
ruleCheckBind RuleCheckEnv
env (Rec [(CoreBndr, CoreExpr)]
prs) = [Bag SDoc] -> Bag SDoc
forall a. [Bag a] -> Bag a
unionManyBags [RuleCheckEnv -> CoreExpr -> Bag SDoc
ruleCheck RuleCheckEnv
env CoreExpr
r | (CoreBndr
_,CoreExpr
r) <- [(CoreBndr, CoreExpr)]
prs]
ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc
ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc
ruleCheck RuleCheckEnv
_ (Var CoreBndr
_) = Bag SDoc
forall a. Bag a
emptyBag
ruleCheck RuleCheckEnv
_ (Lit Literal
_) = Bag SDoc
forall a. Bag a
emptyBag
ruleCheck RuleCheckEnv
_ (Type Type
_) = 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 Tickish CoreBndr
_ 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 CoreBndr
_ CoreExpr
e) = RuleCheckEnv -> CoreExpr -> Bag SDoc
ruleCheck RuleCheckEnv
env CoreExpr
e
ruleCheck RuleCheckEnv
env (Case CoreExpr
e CoreBndr
_ Type
_ [Alt CoreBndr]
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 | (AltCon
_,[CoreBndr]
_,CoreExpr
r) <- [Alt CoreBndr]
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 CoreBndr
f) [CoreExpr]
as = RuleCheckEnv -> CoreBndr -> [CoreExpr] -> Bag SDoc
ruleCheckFun RuleCheckEnv
env CoreBndr
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 -> CoreBndr -> [CoreExpr] -> Bag SDoc
ruleCheckFun RuleCheckEnv
env CoreBndr
fn [CoreExpr]
args
| [CoreRule] -> 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 -> CoreBndr -> [CoreExpr] -> [CoreRule] -> SDoc
ruleAppCheck_help RuleCheckEnv
env CoreBndr
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 -> CoreBndr -> [CoreRule]
rc_rules RuleCheckEnv
env CoreBndr
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 -> CoreBndr -> [CoreExpr] -> [CoreRule] -> SDoc
ruleAppCheck_help RuleCheckEnv
env CoreBndr
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 (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
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 (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 = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
CoreRule -> SDoc
rule_herald CoreRule
rule SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+> DynFlags -> CoreRule -> SDoc
rule_info DynFlags
dflags 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 :: DynFlags -> CoreRule -> SDoc
rule_info DynFlags
dflags CoreRule
rule
| Just CoreExpr
_ <- DynFlags
-> InScopeEnv
-> (Activation -> Bool)
-> CoreBndr
-> [CoreExpr]
-> [Maybe Name]
-> CoreRule
-> Maybe CoreExpr
matchRule DynFlags
dflags (InScopeSet
emptyInScopeSet, RuleCheckEnv -> CoreBndr -> Unfolding
rc_id_unf RuleCheckEnv
env)
Activation -> Bool
noBlackList CoreBndr
fn [CoreExpr]
args [Maybe Name]
rough_args CoreRule
rule
= String -> SDoc
text String
"matches (which is very peculiar!)"
rule_info DynFlags
_ (BuiltinRule {}) = String -> SDoc
text String
"does not match"
rule_info DynFlags
_ (Rule { ru_act :: CoreRule -> Activation
ru_act = Activation
act,
ru_bndrs :: CoreRule -> [CoreBndr]
ru_bndrs = [CoreBndr]
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 (t :: * -> *) a. Foldable t => t a -> Arity
length [CoreExpr]
rule_args
n_mismatches :: Arity
n_mismatches = [Arity] -> 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 -> Maybe RuleSubst
match RuleMatchEnv
renv RuleSubst
emptyRuleSubst CoreExpr
rule_arg CoreExpr
arg
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 :: RnEnv2
-> VarSet -> Subst -> (CoreBndr -> Unfolding) -> RuleMatchEnv
RV { rv_lcl :: RnEnv2
rv_lcl = InScopeSet -> RnEnv2
mkRnEnv2 InScopeSet
in_scope
, rv_tmpls :: VarSet
rv_tmpls = [CoreBndr] -> VarSet
mkVarSet [CoreBndr]
rule_bndrs
, rv_fltR :: Subst
rv_fltR = InScopeSet -> Subst
mkEmptySubst InScopeSet
in_scope
, rv_unf :: CoreBndr -> Unfolding
rv_unf = RuleCheckEnv -> CoreBndr -> Unfolding
rc_id_unf RuleCheckEnv
env }