#include "HsVersions.h"
import CoreSyn -- All of it
-import CoreSubst ( substExpr, mkSubst )
import OccurAnal ( occurAnalyseExpr )
import CoreFVs ( exprFreeVars, exprsFreeVars, bindFreeVars, rulesRhsFreeVars )
import CoreUnfold ( isCheapUnfolding, unfoldingTemplate )
-import CoreUtils ( tcEqExprX )
+import CoreUtils ( tcEqExprX, exprType )
import PprCore ( pprRules )
-import Type ( TvSubstEnv )
+import Type ( Type, TvSubstEnv )
import Coercion ( coercionKind )
import TcType ( tcSplitTyConApp_maybe )
import CoreTidy ( tidyRules )
-import Id ( Id, idUnfolding, isLocalId, isGlobalId, idName,
+import Id ( Id, idUnfolding, isLocalId, isGlobalId, idName, idType,
idSpecialisation, idCoreRules, setIdSpecialisation )
import IdInfo ( SpecInfo( SpecInfo ) )
import Var ( Var )
import VarEnv
import VarSet
-import Name ( Name, NamedThing(..), nameOccName )
+import Name ( Name, NamedThing(..) )
import NameEnv
import Unify ( ruleMatchTyX, MatchEnv(..) )
import BasicTypes ( Activation, CompilerPhase, isActive )
= Rule { ru_name = name, ru_fn = fn, ru_act = act,
ru_bndrs = bndrs, ru_args = args,
ru_rhs = rhs, ru_rough = roughTopNames args,
- ru_orph = Just (nameOccName fn), ru_local = True }
+ ru_local = True }
--------------
roughTopNames :: [CoreExpr] -> [Maybe Name]
%* *
%************************************************************************
+Note [Extra args in rule matching]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we find a matching rule, we return (Just (rule, rhs)),
+but the rule firing has only consumed as many of the input args
+as the ruleArity says. It's up to the caller to keep track
+of any left-over args. E.g. if you call
+ lookupRule ... f [e1, e2, e3]
+and it returns Just (r, rhs), where r has ruleArity 2
+then the real rewrite is
+ f e1 e2 e3 ==> rhs e3
+
+You might think it'd be cleaner for lookupRule to deal with the
+leftover arguments, by applying 'rhs' to them, but the main call
+in the Simplifier works better as it is. Reason: the 'args' passed
+to lookupRule are the result of a lazy substitution
+
\begin{code}
lookupRule :: (Activation -> Bool) -> InScopeSet
-> RuleBase -- Imported rules
-> Id -> [CoreExpr] -> Maybe (CoreRule, CoreExpr)
+-- See Note [Extra argsin rule matching]
lookupRule is_active in_scope rule_base fn args
= matchRules is_active in_scope fn args rules
where
-- potentially inefficient, because of the calls to substExpr,
-- but I don't think it'll happen much in pracice.
+{- Cases to think about
+ (let x=y+1 in \x. (x,x))
+ --> let x=y+1 in (\x1. (x1,x1))
+ (\x. let x = y+1 in (x,x))
+ --> let x1 = y+1 in (\x. (x1,x1)
+ (let x=y+1 in (x,x), let x=y-1 in (x,x))
+ --> let x=y+1 in let x1=y-1 in ((x,x),(x1,x1))
+
+Watch out!
+ (let x=y+1 in let z=x+1 in (z,z)
+ --> matches (p,p) but watch out that the use of
+ x on z's rhs is OK!
+I'm removing the cloning because that makes the above case
+fail, because the inner let looks as if it has locally-bound vars -}
+
match menv subst@(tv_subst, id_subst, binds) e1 (Let bind e2)
- | not (any locally_bound bind_fvs)
+ | all freshly_bound bndrs,
+ not (any locally_bound bind_fvs)
= match (menv { me_env = rn_env' })
(tv_subst, id_subst, binds `snocOL` bind')
e1 e2'
where
rn_env = me_env menv
bndrs = bindersOf bind
- rhss = rhssOfBind bind
bind_fvs = varSetElems (bindFreeVars bind)
locally_bound x = inRnEnvR rn_env x
+ freshly_bound x = not (x `rnInScope` rn_env)
+ bind' = bind
+ e2' = e2
+ rn_env' = extendRnInScopeList rn_env bndrs
+{-
(rn_env', bndrs') = mapAccumL rnBndrR rn_env bndrs
s_prs = [(bndr, Var bndr') | (bndr,bndr') <- zip bndrs bndrs', bndr /= bndr']
subst = mkSubst (rnInScopeSet rn_env) emptyVarEnv (mkVarEnv s_prs)
s_bind = case bind of
NonRec {} -> NonRec (head bndrs') (head rhss)
Rec {} -> Rec (bndrs' `zip` map (substExpr subst) rhss)
+-}
match menv subst (Lit lit1) (Lit lit2)
| lit1 == lit2
-> Nothing -- Occurs check failure
-- e.g. match forall a. (\x-> a x) against (\y. y y)
- | otherwise -- No renaming to do on e2
- -> Just (tv_subst, extendVarEnv id_subst v1' e2, binds)
+ | otherwise -- No renaming to do on e2, because no free var
+ -- of e2 is in the rnEnvR of the envt
+ -- However, we must match the *types*; e.g.
+ -- forall (c::Char->Int) (x::Char).
+ -- f (c x) = "RULE FIRED"
+ -- We must only match on args that have the right type
+ -- It's actually quite difficult to come up with an example that shows
+ -- you need type matching, esp since matching is left-to-right, so type
+ -- args get matched first. But it's possible (e.g. simplrun008) and
+ -- this is the Right Thing to do
+ -> do { tv_subst' <- Unify.ruleMatchTyX menv tv_subst (idType v1') (exprType e2)
+ -- c.f. match_ty below
+ ; return (tv_subst', extendVarEnv id_subst v1' e2, binds) }
Just e1' | tcEqExprX (nukeRnEnvL rn_env) e1' e2
-> Just subst
\begin{code}
------------------------------------------
+match_ty :: MatchEnv
+ -> SubstEnv
+ -> Type -- Template
+ -> Type -- Target
+ -> Maybe SubstEnv
match_ty menv (tv_subst, id_subst, binds) ty1 ty2
= do { tv_subst' <- Unify.ruleMatchTyX menv tv_subst ty1 ty2
; return (tv_subst', id_subst, binds) }
projects / ghc-hetmet.git / blobdiff