-substIds :: (IdOrTyVarSet -> us -> Id -> Maybe (us, Id)) -- Cloner
- -> TyVarSubst -> IdSubst -> IdOrTyVarSet -- Usual stuff
- -> us -- Unique supply
- -> [Id]
- -> (IdSubst, IdOrTyVarSet, -- New id_subst, in_scope
- us, -- New unique supply
- [Id])
-
-substIds clone_fn ty_subst id_subst in_scope us []
- = (id_subst, in_scope, us, [])
-
-substIds clone_fn ty_subst id_subst in_scope us (id:ids)
- = case (substId clone_fn ty_subst id_subst in_scope us id) of {
- (id_subst', in_scope', us', id') ->
-
- case (substIds clone_fn ty_subst id_subst' in_scope' us' ids) of {
- (id_subst'', in_scope'', us'', ids') ->
-
- (id_subst'', in_scope'', us'', id':ids')
- }}
-
-
-substId :: (IdOrTyVarSet -> us -> Id -> Maybe (us, Id)) -- Cloner
- -> TyVarSubst -> IdSubst -> IdOrTyVarSet -- Usual stuff
- -> us -- Unique supply
- -> Id
- -> (IdSubst, IdOrTyVarSet, -- New id_subst, in_scope
- us, -- New unique supply
- Id)
-
--- Returns an Id with empty unfolding and spec-env.
--- It's up to the caller to sort these out.
-
-substId clone_fn
- ty_subst id_subst in_scope
- us id
- | old_id_will_do
- -- No need to clone, but we *must* zap any current substitution
- -- for the variable. For example:
- -- (\x.e) with id_subst = [x |-> e']
- -- Here we must simply zap the substitution for x
- = (delVarEnv id_subst id, extendVarSet in_scope id, us, id)
-
- | otherwise
- = (extendVarEnv id_subst id (Done (Var new_id)),
- extendVarSet in_scope new_id,
- new_us,
- new_id)
- where
- id_ty = idType id
- old_id_will_do = old1 && old2 && old3 && {-old4 && -}not cloned
-
- -- id1 has its type zapped
- (id1,old1) | isEmptyVarEnv ty_subst
- || isEmptyVarSet (tyVarsOfType id_ty) = (id, True)
- | otherwise = (setIdType id ty', False)
-
- ty' = fullSubstTy ty_subst in_scope id_ty
-
- -- id2 has its SpecEnv zapped
- -- It's filled in later by
- (id2,old2) | isEmptySpecEnv spec_env = (id1, True)
- | otherwise = (setIdSpecialisation id1 emptySpecEnv, False)
- spec_env = getIdSpecialisation id
-
- -- id3 has its Unfolding zapped
- -- This is very important; occasionally a let-bound binder is used
- -- as a binder in some lambda, in which case its unfolding is utterly
- -- bogus. Also the unfolding uses old binders so if we left it we'd
- -- have to substitute it. Much better simply to give the Id a new
- -- unfolding each time, which is what the simplifier does.
- (id3,old3) | hasUnfolding (getIdUnfolding id) = (id2 `setIdUnfolding` noUnfolding, False)
- | otherwise = (id2, True)
-
- -- new_id is cloned if necessary
- (new_us, new_id, cloned) = case clone_fn in_scope us id3 of
- Nothing -> (us, id3, False)
- Just (us', id') -> (us', id', True)
-
- -- new_id_bndr has its Inline info neutered. We must forget about whether it
- -- was marked safe-to-inline, because that isn't necessarily true in
- -- the simplified expression. We do this for the *binder* which will
- -- be used at the binding site, but we *dont* do it for new_id, which
- -- is put into the in_scope env. Why not? Because the in_scope env
- -- carries down the occurrence information to usage sites!
- --
- -- Net result: post-simplification, occurrences may have over-optimistic
- -- occurrence info, but binders won't.
-{- (new_id_bndr, old4)
- = case getInlinePragma id of
- ICanSafelyBeINLINEd _ _ -> (setInlinePragma new_id NoInlinePragInfo, False)
- other -> (new_id, True)
--}
+hashExpr :: CoreExpr -> Int
+hashExpr e | hash < 0 = 77 -- Just in case we hit -maxInt
+ | otherwise = hash
+ where
+ hash = abs (hash_expr e) -- Negative numbers kill UniqFM
+
+hash_expr (Note _ e) = hash_expr e
+hash_expr (Let (NonRec b r) e) = hashId b
+hash_expr (Let (Rec ((b,r):_)) e) = hashId b
+hash_expr (Case _ b _) = hashId b
+hash_expr (App f e) = hash_expr f * fast_hash_expr e
+hash_expr (Var v) = hashId v
+hash_expr (Lit lit) = hashLiteral lit
+hash_expr (Lam b _) = hashId b
+hash_expr (Type t) = trace "hash_expr: type" 1 -- Shouldn't happen
+
+fast_hash_expr (Var v) = hashId v
+fast_hash_expr (Lit lit) = hashLiteral lit
+fast_hash_expr (App f (Type _)) = fast_hash_expr f
+fast_hash_expr (App f a) = fast_hash_expr a
+fast_hash_expr (Lam b _) = hashId b
+fast_hash_expr other = 1
+
+hashId :: Id -> Int
+hashId id = hashName (idName id)