\begin{code}
module Subst (
-- In-scope set
- InScopeSet, emptyInScopeSet,
- lookupInScope, setInScope, extendInScope, extendInScopes, isInScope, modifyInScope,
+ InScopeSet, emptyInScopeSet, mkInScopeSet,
+ extendInScopeSet, extendInScopeSetList,
+ lookupInScope, elemInScopeSet, uniqAway,
+
-- Substitution stuff
Subst, TyVarSubst, IdSubst,
emptySubst, mkSubst, substEnv, substInScope,
lookupSubst, lookupIdSubst, isEmptySubst, extendSubst, extendSubstList,
zapSubstEnv, setSubstEnv,
+ setInScope,
+ extendInScope, extendInScopeList, extendNewInScope, extendNewInScopeList,
+ isInScope, modifyInScope,
bindSubst, unBindSubst, bindSubstList, unBindSubstList,
#include "HsVersions.h"
-import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, CoreBndr,
+import CmdLineOpts ( opt_PprStyle_Debug )
+import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr,
CoreRules(..), CoreRule(..),
- emptyCoreRules, isEmptyCoreRules, seqRules
+ isEmptyCoreRules, seqRules
)
import CoreFVs ( exprFreeVars, mustHaveLocalBinding )
-import TypeRep ( Type(..), TyNote(..),
- ) -- friend
+import TypeRep ( Type(..), TyNote(..) ) -- friend
import Type ( ThetaType, PredType(..), ClassContext,
- tyVarsOfType, tyVarsOfTypes, mkAppTy
+ tyVarsOfType, tyVarsOfTypes, mkAppTy, mkUTy, isUTy
)
import VarSet
import VarEnv
import Var ( setVarUnique, isId )
-import Id ( idType, setIdType, idOccInfo, zapFragileIdInfo )
-import IdInfo ( IdInfo, isFragileOccInfo,
+import Id ( idType, setIdType, idOccInfo, zapFragileIdInfo, maybeModifyIdInfo )
+import IdInfo ( IdInfo, isFragileOcc,
specInfo, setSpecInfo,
- WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo
+ WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo,
+ lbvarInfo, LBVarInfo(..), setLBVarInfo
)
+import Unique ( Uniquable(..), deriveUnique )
+import UniqSet ( elemUniqSet_Directly )
import UniqSupply ( UniqSupply, uniqFromSupply, splitUniqSupply )
import Var ( Var, Id, TyVar, isTyVar )
import Outputable
-import PprCore () -- Instances
+import PprCore () -- Instances
+import UniqFM ( ufmToList ) -- Yuk (add a new op to VarEnv)
import Util ( mapAccumL, foldl2, seqList, ($!) )
+import FastTypes
\end{code}
+
%************************************************************************
%* *
-\subsection{Substitutions}
+\subsection{The in-scope set}
%* *
%************************************************************************
\begin{code}
-type InScopeSet = VarEnv Var
+data InScopeSet = InScope (VarEnv Var) FastInt
+ -- The Int# is a kind of hash-value used by uniqAway
+ -- For example, it might be the size of the set
+ -- INVARIANT: it's not zero; we use it as a multiplier in uniqAway
+
+emptyInScopeSet :: InScopeSet
+emptyInScopeSet = InScope emptyVarSet 1#
+
+mkInScopeSet :: VarEnv Var -> InScopeSet
+mkInScopeSet in_scope = InScope in_scope 1#
+
+extendInScopeSet :: InScopeSet -> Var -> InScopeSet
+extendInScopeSet (InScope in_scope n) v = InScope (extendVarEnv in_scope v v) (n +# 1#)
+
+extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet
+extendInScopeSetList (InScope in_scope n) vs
+ = InScope (foldl (\s v -> extendVarEnv s v v) in_scope vs)
+ (n +# iUnbox (length vs))
+
+modifyInScopeSet :: InScopeSet -> Var -> Var -> InScopeSet
+-- Exploit the fact that the in-scope "set" is really a map
+-- Make old_v map to new_v
+modifyInScopeSet (InScope in_scope n) old_v new_v = InScope (extendVarEnv in_scope old_v new_v) (n +# 1#)
+
+delInScopeSet :: InScopeSet -> Var -> InScopeSet
+delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n
+
+elemInScopeSet :: Var -> InScopeSet -> Bool
+elemInScopeSet v (InScope in_scope n) = v `elemVarEnv` in_scope
+
+lookupInScope :: InScopeSet -> Var -> Var
+-- It's important to look for a fixed point
+-- When we see (case x of y { I# v -> ... })
+-- we add [x -> y] to the in-scope set (Simplify.simplCaseBinder).
+-- When we lookup up an occurrence of x, we map to y, but then
+-- we want to look up y in case it has acquired more evaluation information by now.
+lookupInScope (InScope in_scope n) v
+ = go v
+ where
+ go v = case lookupVarEnv in_scope v of
+ Just v' | v == v' -> v' -- Reached a fixed point
+ | otherwise -> go v'
+ Nothing -> WARN( mustHaveLocalBinding v, ppr v )
+ v
+\end{code}
+
+\begin{code}
+uniqAway :: InScopeSet -> Var -> Var
+-- (uniqAway in_scope v) finds a unique that is not used in the
+-- 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, nad 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#
+ where
+ orig_unique = getUnique var
+ try k
+#ifdef DEBUG
+ | k ># 1000#
+ = pprPanic "uniqAway loop:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n))
+#endif
+ | uniq `elemUniqSet_Directly` set = try (k +# 1#)
+#ifdef DEBUG
+ | opt_PprStyle_Debug && k ># 3#
+ = pprTrace "uniqAway:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n))
+ setVarUnique var uniq
+#endif
+ | otherwise = setVarUnique var uniq
+ where
+ uniq = deriveUnique orig_unique (iBox (n *# k))
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Substitutions}
+%* *
+%************************************************************************
+\begin{code}
data Subst = Subst InScopeSet -- In scope
SubstEnv -- Substitution itself
-- INVARIANT 1: The (domain of the) in-scope set is a superset
--
-- INVARIANT 2: No variable is both in scope and in the domain of the substitution
-- Equivalently, the substitution is idempotent
- --
+ -- [Sep 2000: Lies, all lies. The substitution now does contain
+ -- mappings x77 -> DoneId x77 occ
+ -- to record x's occurrence information.]
+ -- [Also watch out: the substitution can contain x77 -> DoneEx (Var x77)
+ -- Consider let x = case k of I# x77 -> ... in
+ -- let y = case k of I# x77 -> ... in ...
+ -- and suppose the body is strict in both x and y. Then the simplifier
+ -- will pull the first (case k) to the top; so the second (case k) will
+ -- cancel out, mapping x77 to, well, x77! But one is an in-Id and the
+ -- other is an out-Id. So the substitution is idempotent in the sense
+ -- that we *must not* repeatedly apply it.]
type IdSubst = Subst
\end{code}
That is added back in later. So new_id is the minimal thing it's
correct to substitute.
-* substId adds a binding (DoneVar new_id occ) to the substitution if
+* substId adds a binding (DoneId new_id occ) to the substitution if
EITHER the Id's unique has changed
OR the Id has interesting occurrence information
So in effect you can only get to interesting occurrence information
case y of x { ... }
That's why the "set" is actually a VarEnv Var
-\begin{code}
-emptyInScopeSet :: InScopeSet
-emptyInScopeSet = emptyVarSet
-
-add_in_scope :: InScopeSet -> Var -> InScopeSet
-add_in_scope in_scope v = extendVarEnv in_scope v v
-\end{code}
-
-
\begin{code}
isEmptySubst :: Subst -> Bool
zapSubstEnv (Subst in_scope env) = Subst in_scope emptySubstEnv
extendSubst :: Subst -> Var -> SubstResult -> Subst
-extendSubst (Subst in_scope env) v r = Subst in_scope (extendSubstEnv env v r)
+extendSubst (Subst in_scope env) v r = UASSERT( case r of { DoneTy ty -> not (isUTy ty) ; _ -> True } )
+ Subst in_scope (extendSubstEnv env v r)
extendSubstList :: Subst -> [Var] -> [SubstResult] -> Subst
-extendSubstList (Subst in_scope env) v r = Subst in_scope (extendSubstEnvList env v r)
+extendSubstList (Subst in_scope env) v r = UASSERT( all (\ r1 -> case r1 of { DoneTy ty -> not (isUTy ty) ; _ -> True }) r )
+ Subst in_scope (extendSubstEnvList env v r)
lookupSubst :: Subst -> Var -> Maybe SubstResult
lookupSubst (Subst _ env) v = lookupSubstEnv env v
Just res -> res
Nothing -> DoneId v' (idOccInfo v')
-- We don't use DoneId for LoopBreakers, so the idOccInfo is
- -- very important! If isFragileOccInfo returned True for
+ -- very important! If isFragileOcc returned True for
-- loop breakers we could avoid this call, but at the expense
-- of adding more to the substitution, and building new Ids
-- in substId a bit more often than really necessary
where
v' = lookupInScope in_scope v
-lookupInScope :: InScopeSet -> Var -> Var
--- It's important to look for a fixed point
--- When we see (case x of y { I# v -> ... })
--- we add [x -> y] to the in-scope set (Simplify.simplCaseBinder).
--- When we lookup up an occurrence of x, we map to y, but then
--- we want to look up y in case it has acquired more evaluation information by now.
-lookupInScope in_scope v
- = case lookupVarEnv in_scope v of
- Just v' | v == v' -> v' -- Reached a fixed point
- | otherwise -> lookupInScope in_scope v'
- Nothing -> WARN( mustHaveLocalBinding v, ppr v )
- v
-
isInScope :: Var -> Subst -> Bool
-isInScope v (Subst in_scope _) = v `elemVarEnv` in_scope
-
-extendInScope :: Subst -> Var -> Subst
-extendInScope (Subst in_scope env) v = Subst (in_scope `add_in_scope` v) env
+isInScope v (Subst in_scope _) = v `elemInScopeSet` in_scope
modifyInScope :: Subst -> Var -> Var -> Subst
-modifyInScope (Subst in_scope env) old_v new_v = Subst (extendVarEnv in_scope old_v new_v) env
+modifyInScope (Subst in_scope env) old_v new_v = Subst (modifyInScopeSet in_scope old_v new_v) env
-- make old_v map to new_v
-extendInScopes :: Subst -> [Var] -> Subst
-extendInScopes (Subst in_scope env) vs = Subst (foldl add_in_scope in_scope vs) env
+extendInScope :: Subst -> Var -> Subst
+ -- Add a new variable as in-scope
+ -- Remember to delete any existing binding in the substitution!
+extendInScope (Subst in_scope env) v = Subst (in_scope `extendInScopeSet` v)
+ (env `delSubstEnv` v)
+
+extendInScopeList :: Subst -> [Var] -> Subst
+extendInScopeList (Subst in_scope env) vs = Subst (extendInScopeSetList in_scope vs)
+ (delSubstEnvList env vs)
+
+-- The "New" variants are guaranteed to be adding freshly-allocated variables
+-- It's not clear that the gain (not needing to delete it from the substitution)
+-- is worth the extra proof obligation
+extendNewInScope :: Subst -> Var -> Subst
+extendNewInScope (Subst in_scope env) v = Subst (in_scope `extendInScopeSet` v) env
+
+extendNewInScopeList :: Subst -> [Var] -> Subst
+extendNewInScopeList (Subst in_scope env) vs = Subst (in_scope `extendInScopeSetList` vs) env
-------------------------------
bindSubst :: Subst -> Var -> Var -> Subst
-- Extend with a substitution, v1 -> Var v2
-- and extend the in-scopes with v2
bindSubst (Subst in_scope env) old_bndr new_bndr
- = Subst (in_scope `add_in_scope` new_bndr)
+ = Subst (in_scope `extendInScopeSet` new_bndr)
(extendSubstEnv env old_bndr subst_result)
where
subst_result | isId old_bndr = DoneEx (Var new_bndr)
-- Reverse the effect of bindSubst
-- If old_bndr was already in the substitution, this doesn't quite work
unBindSubst (Subst in_scope env) old_bndr new_bndr
- = Subst (in_scope `delVarEnv` new_bndr) (delSubstEnv env old_bndr)
+ = Subst (in_scope `delInScopeSet` new_bndr) (delSubstEnv env old_bndr)
-- And the "List" forms
bindSubstList :: Subst -> [Var] -> [Var] -> Subst
setSubstEnv (Subst in_scope1 _) env2 = Subst in_scope1 env2
\end{code}
+Pretty printing, for debugging only
+
+\begin{code}
+instance Outputable SubstResult where
+ ppr (DoneEx e) = ptext SLIT("DoneEx") <+> ppr e
+ ppr (DoneId v _) = ptext SLIT("DoneId") <+> ppr v
+ ppr (ContEx _ e) = ptext SLIT("ContEx") <+> ppr e
+ ppr (DoneTy t) = ptext SLIT("DoneTy") <+> ppr t
+
+instance Outputable SubstEnv where
+ ppr se = brackets (fsep (punctuate comma (map ppr_elt (ufmToList (substEnvEnv se)))))
+ where
+ ppr_elt (uniq,sr) = ppr uniq <+> ptext SLIT("->") <+> ppr sr
+
+instance Outputable Subst where
+ ppr (Subst (InScope in_scope _) se)
+ = ptext SLIT("<InScope =") <+> braces (fsep (map ppr (rngVarEnv in_scope)))
+ $$ ptext SLIT(" Subst =") <+> ppr se <> char '>'
+\end{code}
%************************************************************************
%* *
%************************************************************************
\begin{code}
-type TyVarSubst = Subst -- TyVarSubst are expected to have range elements
+type TyVarSubst = Subst -- TyVarSubst are expected to have range elements
-- (We could have a variant of Subst, but it doesn't seem worth it.)
-- mkTyVarSubst generates the in-scope set from
-- the types given; but it's just a thunk so with a bit of luck
-- it'll never be evaluated
mkTyVarSubst :: [TyVar] -> [Type] -> Subst
-mkTyVarSubst tyvars tys = Subst (tyVarsOfTypes tys) (zip_ty_env tyvars tys emptySubstEnv)
+mkTyVarSubst tyvars tys = Subst (mkInScopeSet (tyVarsOfTypes tys)) (zip_ty_env tyvars tys emptySubstEnv)
-- mkTopTyVarSubst is called when doing top-level substitutions.
-- Here we expect that the free vars of the range of the
mkTopTyVarSubst tyvars tys = Subst emptyInScopeSet (zip_ty_env tyvars tys emptySubstEnv)
zip_ty_env [] [] env = env
-zip_ty_env (tv:tvs) (ty:tys) env = zip_ty_env tvs tys (extendSubstEnv env tv (DoneTy ty))
+zip_ty_env (tv:tvs) (ty:tys) env = UASSERT( not (isUTy ty) )
+ zip_ty_env tvs tys (extendSubstEnv env tv (DoneTy ty))
\end{code}
substTy works with general Substs, so that it can be called from substExpr too.
where
go (TyConApp tc tys) = let args = map go tys
in args `seqList` TyConApp tc args
+
+ go (PredTy p) = PredTy $! (substPred subst p)
+
go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote $! (go ty1)) $! (go ty2)
go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note
- go (NoteTy (UsgNote usg) ty2) = (NoteTy $! UsgNote usg) $! go ty2 -- Keep usage annot
- go (NoteTy (UsgForAll uv) ty2) = (NoteTy $! UsgForAll uv) $! go ty2 -- Keep uvar bdr
- go (NoteTy (IPNote nm) ty2) = (NoteTy $! IPNote nm) $! go ty2 -- Keep ip note
go (FunTy arg res) = (FunTy $! (go arg)) $! (go res)
go (AppTy fun arg) = mkAppTy (go fun) $! (go arg)
go (ForAllTy tv ty) = case substTyVar subst tv of
(subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty)
+
+ go (UsageTy u ty) = mkUTy (go u) $! (go ty)
\end{code}
Here is where we invent a new binder if necessary.
--
-- The new_id isn't cloned, but it may have a different type
-- etc, so we must return it, not the old id
- = (Subst (in_scope `add_in_scope` new_var)
+ = (Subst (in_scope `extendInScopeSet` new_var)
(delSubstEnv env old_var),
new_var)
-- Extending the substitution to do this renaming also
-- has the (correct) effect of discarding any existing
-- substitution for that variable
- = (Subst (in_scope `add_in_scope` new_var)
+ = (Subst (in_scope `extendInScopeSet` new_var)
(extendSubstEnv env old_var (DoneTy (TyVarTy new_var))),
new_var)
where
-- top of this module
substId subst@(Subst in_scope env) old_id
- = (Subst (in_scope `add_in_scope` new_id) new_env, new_id)
+ = (Subst (in_scope `extendInScopeSet` new_id) new_env, new_id)
where
id_ty = idType old_id
occ_info = idOccInfo old_id
-- id2 has its IdInfo zapped
id2 = zapFragileIdInfo id1
- -- new_id is cloned if necessary
- new_id = uniqAway in_scope id2
+ -- id3 has its LBVarInfo zapped
+ id3 = maybeModifyIdInfo (\ info -> go info (lbvarInfo info)) id2
+ where go info (LBVarInfo u@(TyVarTy _)) = Just $ setLBVarInfo info $
+ LBVarInfo (subst_ty subst u)
+ go info _ = Nothing
+ -- new_id is cloned if necessary
+ new_id = uniqAway in_scope id3
-- Extend the substitution if the unique has changed,
-- or there's some useful occurrence information
-- See the notes with substTyVar for the delSubstEnv
- new_env | new_id /= old_id || isFragileOccInfo occ_info
+ new_env | new_id /= old_id || isFragileOcc occ_info
= extendSubstEnv env old_id (DoneId new_id occ_info)
| otherwise
= delSubstEnv env old_id
substAndCloneId :: Subst -> UniqSupply -> Id -> (Subst, UniqSupply, Id)
substAndCloneId subst@(Subst in_scope env) us old_id
- = (Subst (in_scope `add_in_scope` new_id)
+ = (Subst (in_scope `extendInScopeSet` new_id)
(extendSubstEnv env old_id (DoneEx (Var new_id))),
new_us,
new_id)