Commit c45a0ac5 authored by simonpj's avatar simonpj
Browse files

[project @ 2004-12-20 17:16:24 by simonpj]

--------------------------------
	Deal properly with dual-renaming
	--------------------------------

When comparing types and terms, and during matching, we are faced
with 
	\x.e1	~   \y.e2

There are many pitfalls here, and GHC has never done the job properly.
Now, at last it does, using a new abstraction VarEnv.RnEnv2.  See
comments there for how it works.

There are lots of consequential changes to use the new stuff, especially
in 
	types/Type (type comparison), 
	types/Unify (matching on types)
	coreSyn/CoreUtils (equality on expressions), 
	specialise/Rules (matching).

I'm not 100% certain of that I've covered all the bases, so let me
know if something unexpected happens after you update.  Maybe wait until
a nightly build has worked ok first!
parent f207c9b9
......@@ -23,6 +23,10 @@ module VarEnv (
extendInScopeSet, extendInScopeSetList, modifyInScopeSet,
getInScopeVars, lookupInScope, elemInScopeSet, uniqAway,
-- RnEnv2 and its operations
RnEnv2, mkRnEnv2, rnBndr2, rnBndrs2, rnOccL, rnOccR, inRnEnvL, inRnEnvR,
rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR,
-- TidyEnvs
TidyEnv, emptyTidyEnv
) where
......@@ -34,7 +38,8 @@ import Var ( Var, setVarUnique )
import VarSet
import UniqFM
import Unique ( Unique, deriveUnique, getUnique )
import Util ( zipEqual )
import Util ( zipEqual, foldl2 )
import Maybes ( orElse, isJust )
import CmdLineOpts ( opt_PprStyle_Debug )
import Outputable
import FastTypes
......@@ -105,9 +110,14 @@ uniqAway :: InScopeSet -> Var -> Var
-- in-scope set, and gives that to v. It starts with v's current unique, of course,
-- in the hope that it won't have to change it, and thereafter uses a combination
-- of that and the hash-code found in the in-scope set
uniqAway (InScope set n) var
| not (var `elemVarSet` set) = var -- Nothing to do
| otherwise = try 1#
uniqAway in_scope var
| var `elemInScopeSet` in_scope = uniqAway' in_scope var -- Make a new one
| otherwise = var -- Nothing to do
uniqAway' :: InScopeSet -> Var -> Var
-- This one *always* makes up a new variable
uniqAway' (InScope set n) var
= try 1#
where
orig_unique = getUnique var
try k
......@@ -127,6 +137,110 @@ uniqAway (InScope set n) var
\end{code}
%************************************************************************
%* *
Dual renaming
%* *
%************************************************************************
When we are comparing (or matching) types or terms, we are faced with
"going under" corresponding binders. E.g. when comparing
\x. e1 ~ \y. e2
Basically we want to rename [x->y] or [y->x], but there are lots of
things we must be careful of. In particular, x might be free in e2, or
y in e1. So the idea is that we come up with a fresh binder that is free
in neither, and rename x and y respectively. That means we must maintain
a) a renaming for the left-hand expression
b) a renaming for the right-hand expressions
c) an in-scope set
Furthermore, when matching, we want to be able to have an 'occurs check',
to prevent
\x. f ~ \y. y
matching with f->y. So for each expression we want to know that set of
locally-bound variables. That is precisely the domain of the mappings (a)
and (b), but we must ensure that we always extend the mappings as we go in.
\begin{code}
data RnEnv2
= RV2 { envL :: VarEnv Var -- Renaming for Left term
, envR :: VarEnv Var -- Renaming for Right term
, in_scope :: InScopeSet } -- In scope in left or right terms
-- The renamings envL and envR are *guaranteed* to contain a binding
-- for every variable bound as we go into the term, even if it is not
-- renamed. That way we can ask what variables are locally bound
-- (inRnEnvL, inRnEnvR)
mkRnEnv2 :: InScopeSet -> RnEnv2
mkRnEnv2 vars = RV2 { envL = emptyVarEnv
, envR = emptyVarEnv
, in_scope = vars }
rnBndrs2 :: RnEnv2 -> [Var] -> [Var] -> RnEnv2
-- Arg lists must be of equal length
rnBndrs2 env bsL bsR = foldl2 rnBndr2 env bsL bsR
rnBndr2 :: RnEnv2 -> Var -> Var -> RnEnv2
-- (rnBndr2 env bL bR) go under a binder bL in the Left term 1,
-- and binder bR in the Right term
-- It finds a new binder, new_b,
-- and returns an environment mapping bL->new_b and bR->new_b resp.
rnBndr2 (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL bR
= RV2 { envL = extendVarEnv envL bL new_b -- See Note
, envR = extendVarEnv envR bR new_b -- [Rebinding]
, in_scope = extendInScopeSet in_scope new_b }
where
-- Find a new binder not in scope in either term
new_b | not (bL `elemInScopeSet` in_scope) = bL
| not (bR `elemInScopeSet` in_scope) = bR
| otherwise = uniqAway' in_scope bL
-- Note [Rebinding]
-- If the new var is the same as the old one, note that
-- the extendVarEnv *deletes* any current renaming
-- E.g. (\x. \x. ...) ~ (\y. \z. ...)
--
-- Inside \x \y { [x->y], [y->y], {y} }
-- \x \z { [x->x], [y->y, z->x], {y,x} }
rnBndrL, rnBndrR :: RnEnv2 -> Var -> (RnEnv2, Var)
-- Used when there's a binder on one side or the other only
-- Useful when eta-expanding
rnBndrL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL
= (RV2 { envL = extendVarEnv envL bL new_b
, envR = envR
, in_scope = extendInScopeSet in_scope new_b }, new_b)
where
new_b | not (bL `elemInScopeSet` in_scope) = bL
| otherwise = uniqAway' in_scope bL
rnBndrR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR
= (RV2 { envL = envL
, envR = extendVarEnv envR bR new_b
, in_scope = extendInScopeSet in_scope new_b }, new_b)
where
new_b | not (bR `elemInScopeSet` in_scope) = bR
| otherwise = uniqAway' in_scope bR
rnOccL, rnOccR :: RnEnv2 -> Var -> Var
-- Look up the renaming of an occurrence in the left or right term
rnOccL (RV2 { envL = env }) v = lookupVarEnv env v `orElse` v
rnOccR (RV2 { envR = env }) v = lookupVarEnv env v `orElse` v
inRnEnvL, inRnEnvR :: RnEnv2 -> Var -> Bool
-- Tells whether a variable is locally bound
inRnEnvL (RV2 { envL = env }) v = isJust (lookupVarEnv env v)
inRnEnvR (RV2 { envR = env }) v = isJust (lookupVarEnv env v)
nukeRnEnvL, nukeRnEnvR :: RnEnv2 -> RnEnv2
nukeRnEnvL env = env { envL = emptyVarEnv }
nukeRnEnvR env = env { envR = emptyVarEnv }
\end{code}
%************************************************************************
%* *
Tidying
......@@ -202,8 +316,8 @@ foldVarEnv = foldUFM
lookupVarEnv_Directly = lookupUFM_Directly
filterVarEnv_Directly = filterUFM_Directly
zipVarEnv tyvars tys = mkVarEnv (zipEqual "zipVarEnv" tyvars tys)
lookupVarEnv_NF env id = case (lookupVarEnv env id) of { Just xx -> xx }
zipVarEnv tyvars tys = mkVarEnv (zipEqual "zipVarEnv" tyvars tys)
lookupVarEnv_NF env id = case (lookupVarEnv env id) of { Just xx -> xx }
\end{code}
@modifyVarEnv@: Look up a thing in the VarEnv,
......
......@@ -27,7 +27,7 @@ import PprCore
import ErrUtils ( dumpIfSet_core, ghcExit, Message, showPass,
mkLocMessage, debugTraceMsg )
import SrcLoc ( SrcLoc, noSrcLoc, mkSrcSpan )
import Type ( Type, tyVarsOfType, eqType,
import Type ( Type, tyVarsOfType, coreEqType,
splitFunTy_maybe, mkTyVarTys,
splitForAllTy_maybe, splitTyConApp_maybe,
isUnLiftedType, typeKind,
......@@ -615,7 +615,7 @@ checkTys :: Type -> Type -> Message -> LintM ()
-- check ty2 is subtype of ty1 (ie, has same structure but usage
-- annotations need only be consistent, not equal)
-- Assumes ty1,ty2 are have alrady had the substitution applied
checkTys ty1 ty2 msg = checkL (ty1 `eqType` ty2) msg
checkTys ty1 ty2 msg = checkL (ty1 `coreEqType` ty2) msg
\end{code}
%************************************************************************
......
......@@ -31,7 +31,7 @@ module CoreUtils (
hashExpr,
-- Equality
cheapEqExpr, eqExpr, applyTypeToArgs, applyTypeToArg
cheapEqExpr, tcEqExpr, tcEqExprX, applyTypeToArgs, applyTypeToArg
) where
#include "HsVersions.h"
......@@ -40,8 +40,10 @@ module CoreUtils (
import GLAEXTS -- For `xori`
import CoreSyn
import CoreFVs ( exprFreeVars )
import PprCore ( pprCoreExpr )
import Var ( Var )
import VarSet ( unionVarSet )
import VarEnv
import Name ( hashName )
import Packages ( isDllName )
......@@ -59,10 +61,10 @@ import Id ( Id, idType, globalIdDetails, idNewStrictness,
import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo )
import NewDemand ( appIsBottom )
import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
splitFunTy,
splitFunTy, tcEqTypeX,
applyTys, isUnLiftedType, seqType, mkTyVarTy,
splitForAllTy_maybe, isForAllTy, splitRecNewType_maybe,
splitTyConApp_maybe, eqType, funResultTy, applyTy
splitTyConApp_maybe, coreEqType, funResultTy, applyTy
)
import TyCon ( tyConArity )
-- gaw 2004
......@@ -72,7 +74,7 @@ import BasicTypes ( Arity )
import Unique ( Unique )
import Outputable
import TysPrim ( alphaTy ) -- Debugging only
import Util ( equalLength, lengthAtLeast )
import Util ( equalLength, lengthAtLeast, foldl2 )
\end{code}
......@@ -205,12 +207,12 @@ mkCoerce to_ty expr = mkCoerce2 to_ty (exprType expr) expr
mkCoerce2 :: Type -> Type -> CoreExpr -> CoreExpr
mkCoerce2 to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
= ASSERT( from_ty `eqType` to_ty2 )
= ASSERT( from_ty `coreEqType` to_ty2 )
mkCoerce2 to_ty from_ty2 expr
mkCoerce2 to_ty from_ty expr
| to_ty `eqType` from_ty = expr
| otherwise = ASSERT( from_ty `eqType` exprType expr )
| to_ty `coreEqType` from_ty = expr
| otherwise = ASSERT( from_ty `coreEqType` exprType expr )
Note (Coerce to_ty from_ty) expr
\end{code}
......@@ -1003,7 +1005,7 @@ cheapEqExpr :: Expr b -> Expr b -> Bool
cheapEqExpr (Var v1) (Var v2) = v1==v2
cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
cheapEqExpr (Type t1) (Type t2) = t1 `eqType` t2
cheapEqExpr (Type t1) (Type t2) = t1 `coreEqType` t2
cheapEqExpr (App f1 a1) (App f2 a2)
= f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
......@@ -1021,57 +1023,49 @@ exprIsBig other = True
\begin{code}
eqExpr :: CoreExpr -> CoreExpr -> Bool
-- Works ok at more general type, but only needed at CoreExpr
-- Used in rule matching, so when we find a type we use
-- eqTcType, which doesn't look through newtypes
-- [And it doesn't risk falling into a black hole either.]
eqExpr e1 e2
= eq emptyVarEnv e1 e2
tcEqExpr :: CoreExpr -> CoreExpr -> Bool
-- Used in rule matching, so does *not* look through
-- newtypes, predicate types; hence tcEqExpr
tcEqExpr e1 e2 = tcEqExprX rn_env e1 e2
where
-- The "env" maps variables in e1 to variables in ty2
-- So when comparing lambdas etc,
-- we in effect substitute v2 for v1 in e1 before continuing
eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
Just v1' -> v1' == v2
Nothing -> v1 == v2
eq env (Lit lit1) (Lit lit2) = lit1 == lit2
eq env (App f1 a1) (App f2 a2) = eq env f1 f2 && eq env a1 a2
eq env (Lam v1 e1) (Lam v2 e2) = eq (extendVarEnv env v1 v2) e1 e2
eq env (Let (NonRec v1 r1) e1)
(Let (NonRec v2 r2) e2) = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
eq env (Let (Rec ps1) e1)
(Let (Rec ps2) e2) = equalLength ps1 ps2 &&
and (zipWith eq_rhs ps1 ps2) &&
eq env' e1 e2
rn_env = mkRnEnv2 (mkInScopeSet (exprFreeVars e1 `unionVarSet` exprFreeVars e2))
tcEqExprX :: RnEnv2 -> CoreExpr -> CoreExpr -> Bool
tcEqExprX env (Var v1) (Var v2) = rnOccL env v1 == rnOccR env v2
tcEqExprX env (Lit lit1) (Lit lit2) = lit1 == lit2
tcEqExprX env (App f1 a1) (App f2 a2) = tcEqExprX env f1 f2 && tcEqExprX env a1 a2
tcEqExprX env (Lam v1 e1) (Lam v2 e2) = tcEqExprX (rnBndr2 env v1 v2) e1 e2
tcEqExprX env (Let (NonRec v1 r1) e1)
(Let (NonRec v2 r2) e2) = tcEqExprX env r1 r2
&& tcEqExprX (rnBndr2 env v1 v2) e1 e2
tcEqExprX env (Let (Rec ps1) e1)
(Let (Rec ps2) e2) = equalLength ps1 ps2
&& and (zipWith eq_rhs ps1 ps2)
&& tcEqExprX env' e1 e2
where
env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
eq_rhs (_,r1) (_,r2) = eq env' r1 r2
eq env (Case e1 v1 t1 a1)
(Case e2 v2 t2 a2) = eq env e1 e2 &&
t1 `eqType` t2 &&
equalLength a1 a2 &&
and (zipWith (eq_alt env') a1 a2)
env' = foldl2 rn_bndr2 env ps2 ps2
rn_bndr2 env (b1,_) (b2,_) = rnBndr2 env b1 b2
eq_rhs (_,r1) (_,r2) = tcEqExprX env' r1 r2
tcEqExprX env (Case e1 v1 t1 a1)
(Case e2 v2 t2 a2) = tcEqExprX env e1 e2
&& tcEqTypeX env t1 t2
&& equalLength a1 a2
&& and (zipWith (eq_alt env') a1 a2)
where
env' = extendVarEnv env v1 v2
env' = rnBndr2 env v1 v2
eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
eq env (Type t1) (Type t2) = t1 `eqType` t2
eq env e1 e2 = False
tcEqExprX env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && tcEqExprX env e1 e2
tcEqExprX env (Type t1) (Type t2) = tcEqTypeX env t1 t2
tcEqExprX env e1 e2 = False
eq_list env [] [] = True
eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
eq_list env es1 es2 = False
eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1 `eqType` t2 && f1 `eqType` f2
eq_note env InlineCall InlineCall = True
eq_note env (CoreNote s1) (CoreNote s2) = s1 == s2
eq_note env other1 other2 = False
eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 && tcEqExprX (rnBndrs2 env vs1 vs2) r1 r2
eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
eq_note env (Coerce t1 f1) (Coerce t2 f2) = tcEqTypeX env t1 t2 && tcEqTypeX env f1 f2
eq_note env InlineCall InlineCall = True
eq_note env (CoreNote s1) (CoreNote s2) = s1 == s2
eq_note env other1 other2 = False
\end{code}
......
......@@ -6,8 +6,9 @@
\begin{code}
module Subst (
-- Substitution stuff
Subst, SubstResult(..),
emptySubst, mkSubst, substInScope, substTy,
IdSubstEnv, SubstResult(..),
Subst, emptySubst, mkSubst, substInScope, substTy,
lookupIdSubst, lookupTvSubst, isEmptySubst,
extendIdSubst, extendIdSubstList, extendTvSubst, extendTvSubstList,
zapSubstEnv, setSubstEnv,
......
......@@ -26,7 +26,7 @@ import Literal ( Literal(..) )
import Module ( moduleString )
import Name ( getOccString, NamedThing(..) )
import OccName ( encodeFS )
import Type ( repType, eqType, typePrimRep )
import Type ( repType, coreEqType, typePrimRep )
import TcType ( Type, mkFunTys, mkForAllTys, mkTyConApp,
mkFunTy, tcSplitTyConApp_maybe,
tcSplitForAllTys, tcSplitFunTys, tcTyConAppArgs,
......@@ -156,7 +156,7 @@ dsCImport :: Id
-> DsM ([Binding], SDoc, SDoc)
dsCImport id (CLabel cid) _ _ no_hdrs
= resultWrapper (idType id) `thenDs` \ (resTy, foRhs) ->
ASSERT(fromJust resTy `eqType` addrPrimTy) -- typechecker ensures this
ASSERT(fromJust resTy `coreEqType` addrPrimTy) -- typechecker ensures this
let rhs = foRhs (mkLit (MachLabel cid Nothing)) in
returnDs ([(setImpInline no_hdrs id, rhs)], empty, empty)
dsCImport id (CFunction target) cconv safety no_hdrs
......@@ -465,7 +465,7 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
= map snd extra_cnames_and_tys ++ arg_htys
-- stuff to do with the return type of the C function
res_hty_is_unit = res_hty `eqType` unitTy -- Look through any newtypes
res_hty_is_unit = res_hty `coreEqType` unitTy -- Look through any newtypes
cResType | res_hty_is_unit = text "void"
| otherwise = showStgType res_hty
......
......@@ -36,7 +36,7 @@ import TysWiredIn ( boolTy, trueDataConId, falseDataConId )
import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon )
import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG )
import CoreUtils ( cheapEqExpr, exprIsConApp_maybe )
import Type ( tyConAppTyCon, eqType )
import Type ( tyConAppTyCon, coreEqType )
import OccName ( occNameUserString)
import PrelNames ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey,
eqStringName, unpackCStringIdKey )
......@@ -420,7 +420,7 @@ match_append_lit [Type ty1,
]
| unpk `hasKey` unpackCStringFoldrIdKey &&
c1 `cheapEqExpr` c2
= ASSERT( ty1 `eqType` ty2 )
= ASSERT( ty1 `coreEqType` ty2 )
Just (Var unpk `App` Type ty1
`App` Lit (MachStr (s1 `appendFS` s2))
`App` c1
......
......@@ -49,7 +49,7 @@ import Rules ( lookupRule )
import BasicTypes ( isMarkedStrict )
import CostCentre ( currentCCS )
import Type ( TvSubstEnv, isUnLiftedType, seqType, tyConAppArgs, funArgTy,
splitFunTy_maybe, splitFunTy, eqType, substTy,
splitFunTy_maybe, splitFunTy, coreEqType, substTy,
mkTyVarTys, mkTyConApp
)
import VarEnv ( elemVarEnv )
......@@ -846,7 +846,7 @@ simplNote env (Coerce to from) body cont
-- we may find (coerce T (coerce S (\x.e))) y
-- and we'd like it to simplify to e[y/x] in one round
-- of simplification
| t1 `eqType` k1 = cont -- The coerces cancel out
| t1 `coreEqType` k1 = cont -- The coerces cancel out
| otherwise = CoerceIt t1 cont -- They don't cancel, but
-- the inner one is redundant
......
......@@ -16,26 +16,22 @@ module Rules (
import CoreSyn -- All of it
import OccurAnal ( occurAnalyseRule )
import CoreFVs ( exprFreeVars, ruleRhsFreeVars )
import CoreFVs ( exprFreeVars, exprsFreeVars, ruleRhsFreeVars )
import CoreUnfold ( isCheapUnfolding, unfoldingTemplate )
import CoreUtils ( eqExpr )
import CoreUtils ( tcEqExprX )
import CoreTidy ( pprTidyIdRules )
import Subst ( Subst, SubstResult(..), extendIdSubst,
getTvSubstEnv, setTvSubstEnv,
emptySubst, isInScope, lookupIdSubst, lookupTvSubst,
bindSubstList, unBindSubstList, substInScope
)
import Subst ( IdSubstEnv, SubstResult(..) )
import Id ( Id, idUnfolding, idSpecialisation, setIdSpecialisation )
import Var ( Var, isId )
import Var ( Var )
import VarSet
import VarEnv
import TcType ( mkTyVarTy )
import qualified Unify ( matchTyX )
import TcType ( TvSubstEnv )
import Unify ( matchTyX, MatchEnv(..) )
import BasicTypes ( Activation, CompilerPhase, isActive )
import Outputable
import FastString
import Maybe ( isJust, isNothing, fromMaybe )
import Maybe ( isJust, fromMaybe )
import Util ( sortLe )
import Bag
import List ( isPrefixOf )
......@@ -120,27 +116,6 @@ matchRule :: (Activation -> Bool) -> InScopeSet
--
-- Any 'surplus' arguments in the input are simply put on the end
-- of the output.
--
-- ASSUMPTION (A):
-- A1. No top-level variable is bound in the target
-- A2. No template variable is bound in the target
-- A3. No lambda bound template variable is free in any subexpression of the target
--
-- To see why A1 is necessary, consider matching
-- \x->f against \f->f
-- When we meet the lambdas we substitute [f/x] in the template (a no-op),
-- and then erroneously succeed in matching f against f.
--
-- To see why A2 is needed consider matching
-- forall a. \b->b against \a->3
-- When we meet the lambdas we substitute [a/b] in the template, and then
-- erroneously succeed in matching what looks like the template variable 'a' against 3.
--
-- A3 is needed to validate the rule that says
-- (\x->E) matches F
-- if
-- (\x->E) matches (\x->F x)
matchRule is_active in_scope rule@(BuiltinRule name match_fn) args
= case match_fn args of
......@@ -151,251 +126,193 @@ matchRule is_active in_scope rule@(Rule rn act tpl_vars tpl_args rhs) args
| not (is_active act)
= Nothing
| otherwise
= go tpl_args args emptySubst
-- We used to use the in_scope set, but I don't think that's necessary
-- After all, the result is going to be simplified again with that in_scope set
where
tpl_var_set = mkVarSet tpl_vars
-----------------------
-- Do the business
go (tpl_arg:tpl_args) (arg:args) subst = match tpl_arg arg tpl_var_set (go tpl_args args) subst
-- Two easy ways to terminate
go [] [] subst = Just (rn, app_match subst (mkLams tpl_vars rhs) tpl_vars)
go [] args subst = Just (rn, app_match subst (mkLams tpl_vars rhs) tpl_vars `mkApps` args)
-- One tiresome way to terminate: check for excess unmatched
-- template arguments
go tpl_args [] subst = Nothing -- Failure
-----------------------
app_match subst fn vs = foldl go fn vs
where
go fn v = case lookupVar subst v of
Just e -> fn `App` e
Nothing -> pprPanic "app_match: unbound tpl" (ppr v)
lookupVar :: Subst -> Var -> Maybe CoreExpr
lookupVar subst v
| isId v = case lookupIdSubst subst v of
Just (DoneEx ex) -> Just ex
other -> Nothing
| otherwise = case lookupTvSubst subst v of
Just ty -> Just (Type ty)
Nothing -> Nothing
-----------------------
{- The code below tries to match even if there are more
template args than real args.
I now think this is probably a bad idea.
Should the template (map f xs) match (map g)? I think not.
For a start, in general eta expansion wastes work.
SLPJ July 99
= case eta_complete tpl_args (mkVarSet leftovers) of
Just leftovers' -> Just (rn, mkLams done (mkLams leftovers' rhs),
mk_result_args subst done)
Nothing -> Nothing -- Failure
where
(done, leftovers) = partition (\v -> isJust (lookupSubstEnv subst_env v))
(map zapOccInfo tpl_vars)
-- Zap the occ info
subst_env = substEnv subst
-----------------------
eta_complete [] vars = ASSERT( isEmptyVarSet vars )
Just []
eta_complete (Type ty:tpl_args) vars
= case getTyVar_maybe ty of
Just tv | tv `elemVarSet` vars
-> case eta_complete tpl_args (vars `delVarSet` tv) of
Just vars' -> Just (tv:vars')
Nothing -> Nothing
other -> Nothing
eta_complete (Var v:tpl_args) vars
| v `elemVarSet` vars
= case eta_complete tpl_args (vars `delVarSet` v) of
Just vars' -> Just (v:vars')
Nothing -> Nothing
eta_complete other vars = Nothing
zapOccInfo bndr | isTyVar bndr = bndr
| otherwise = zapLamIdInfo bndr
-}
= case matchN in_scope tpl_vars tpl_args args of
Just (tpl_vals, leftovers) -> Just (rn, mkLams tpl_vars rhs `mkApps` tpl_vals `mkApps` leftovers)
Nothing -> Nothing
\end{code}
\begin{code}
type Matcher result = VarSet -- Template variables
-> (Subst -> Maybe result) -- Continuation if success
-> Subst -> Maybe result -- Substitution so far -> result
-- The *SubstEnv* in these Substs apply to the TEMPLATE only
-- The *InScopeSet* in these Substs is HIJACKED,
-- to give the set of variables bound so far in the
-- target term. So when matching forall a. (\x. a x) against (\y. y y)
-- while processing the body of the lambdas, the in-scope set will be {y}.
-- That lets us do the occurs-check when matching 'a' against 'y'
--
-- It starts off empty
match :: CoreExpr -- Template
matchN :: InScopeSet
-> [Var] -- Template tyvars
-> [CoreExpr] -- Template
-> [CoreExpr] -- Target; can have more elts than template
-> Maybe ([CoreExpr], -- What is substituted for each template var
[CoreExpr]) -- Leftover target exprs
matchN in_scope tmpl_vars tmpl_es target_es
= do { (subst, leftover_es) <- go init_menv emptySubstEnv tmpl_es target_es
; return (map (lookup_tmpl subst) tmpl_vars, leftover_es) }
where
init_menv = ME { me_tmpls = mkVarSet tmpl_vars, me_env = init_rn_env }
init_rn_env = mkRnEnv2 (extendInScopeSetList in_scope tmpl_vars)
go menv subst [] es = Just (subst, es)
go menv subst ts [] = Nothing -- Fail if too few actual args
go menv subst (t:ts) (e:es) = do { subst1 <- match menv subst t e
; go menv subst1 ts es }
lookup_tmpl :: (TvSubstEnv, IdSubstEnv) -> Var -> CoreExpr
lookup_tmpl (tv_subst, id_subst) tmpl_var
| isTyVar tmpl_var = case lookupVarEnv tv_subst tmpl_var of
Just ty -> Type ty
Nothing -> unbound tmpl_var
| otherwise = case lookupVarEnv id_subst tmpl_var of
Just (DoneEx e) -> e
other -> unbound tmpl_var
unbound var = pprPanic "Template variable unbound in rewrite rule" (ppr var)
emptySubstEnv :: (TvSubstEnv, IdSubstEnv)
emptySubstEnv = (emptyVarEnv, emptyVarEnv)
-- At one stage I tried to match even if there are more
-- template args than real args.
-- I now think this is probably a bad idea.
-- Should the template (map f xs) match (map g)? I think not.
-- For a start, in general eta expansion wastes work.
-- SLPJ July 99
match :: MatchEnv
-> (TvSubstEnv, IdSubstEnv)
-> CoreExpr -- Template
-> CoreExpr -- Target
-> Matcher result
match_fail = Nothing
-- ToDo: remove this debugging junk
-- match e1 e2 tpls kont subst = pprTrace "match" (ppr e1 <+> ppr e2 <+> ppr subst) $ match_ e1 e2 tpls kont subst
match = match_
match_ (Var v1) e2 tpl_vars kont subst
= case lookupIdSubst subst v1 of
Nothing | v1 `elemVarSet` tpl_vars -- v1 is a template variable
-> if (any (`isInScope` subst) (varSetElems (exprFreeVars e2))) then