+-- We must be careful that @\\x.x@ and @\\y.y@ map to the same hash code,
+-- (at least if we want the above invariant to be true).
+
+hashExpr e = fromIntegral (hash_expr (1,emptyVarEnv) e .&. 0x7fffffff)
+ -- UniqFM doesn't like negative Ints
+
+type HashEnv = (Int, VarEnv Int) -- Hash code for bound variables
+
+hash_expr :: HashEnv -> CoreExpr -> Word32
+-- Word32, because we're expecting overflows here, and overflowing
+-- signed types just isn't cool. In C it's even undefined.
+hash_expr env (Note _ e) = hash_expr env e
+hash_expr env (Cast e _) = hash_expr env e
+hash_expr env (Var v) = hashVar env v
+hash_expr _ (Lit lit) = fromIntegral (hashLiteral lit)
+hash_expr env (App f e) = hash_expr env f * fast_hash_expr env e
+hash_expr env (Let (NonRec b r) e) = hash_expr (extend_env env b) e * fast_hash_expr env r
+hash_expr env (Let (Rec ((b,_):_)) e) = hash_expr (extend_env env b) e
+hash_expr env (Case e _ _ _) = hash_expr env e
+hash_expr env (Lam b e) = hash_expr (extend_env env b) e
+hash_expr _ (Type _) = WARN(True, text "hash_expr: type") 1
+-- Shouldn't happen. Better to use WARN than trace, because trace
+-- prevents the CPR optimisation kicking in for hash_expr.
+hash_expr _ (Coercion _) = WARN(True, text "hash_expr: coercion") 1
+
+fast_hash_expr :: HashEnv -> CoreExpr -> Word32
+fast_hash_expr env (Var v) = hashVar env v
+fast_hash_expr env (Type t) = fast_hash_type env t
+fast_hash_expr env (Coercion co) = fast_hash_co env co
+fast_hash_expr _ (Lit lit) = fromIntegral (hashLiteral lit)
+fast_hash_expr env (Cast e _) = fast_hash_expr env e
+fast_hash_expr env (Note _ e) = fast_hash_expr env e
+fast_hash_expr env (App _ a) = fast_hash_expr env a -- A bit idiosyncratic ('a' not 'f')!
+fast_hash_expr _ _ = 1
+
+fast_hash_type :: HashEnv -> Type -> Word32
+fast_hash_type env ty
+ | Just tv <- getTyVar_maybe ty = hashVar env tv
+ | Just (tc,tys) <- splitTyConApp_maybe ty = let hash_tc = fromIntegral (hashName (tyConName tc))
+ in foldr (\t n -> fast_hash_type env t + n) hash_tc tys
+ | otherwise = 1
+
+fast_hash_co :: HashEnv -> Coercion -> Word32
+fast_hash_co env co
+ | Just cv <- getCoVar_maybe co = hashVar env cv
+ | Just (tc,cos) <- splitTyConAppCo_maybe co = let hash_tc = fromIntegral (hashName (tyConName tc))
+ in foldr (\c n -> fast_hash_co env c + n) hash_tc cos
+ | otherwise = 1
+
+extend_env :: HashEnv -> Var -> (Int, VarEnv Int)
+extend_env (n,env) b = (n+1, extendVarEnv env b n)
+
+hashVar :: HashEnv -> Var -> Word32
+hashVar (_,env) v
+ = fromIntegral (lookupVarEnv env v `orElse` hashName (idName v))
+\end{code}
+
+
+%************************************************************************
+%* *
+ Eta reduction
+%* *
+%************************************************************************
+
+Note [Eta reduction conditions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We try for eta reduction here, but *only* if we get all the way to an
+trivial expression. We don't want to remove extra lambdas unless we
+are going to avoid allocating this thing altogether.
+
+There are some particularly delicate points here:
+
+* Eta reduction is not valid in general:
+ \x. bot /= bot
+ This matters, partly for old-fashioned correctness reasons but,
+ worse, getting it wrong can yield a seg fault. Consider
+ f = \x.f x
+ h y = case (case y of { True -> f `seq` True; False -> False }) of
+ True -> ...; False -> ...
+
+ If we (unsoundly) eta-reduce f to get f=f, the strictness analyser
+ says f=bottom, and replaces the (f `seq` True) with just
+ (f `cast` unsafe-co). BUT, as thing stand, 'f' got arity 1, and it
+ *keeps* arity 1 (perhaps also wrongly). So CorePrep eta-expands
+ the definition again, so that it does not termninate after all.
+ Result: seg-fault because the boolean case actually gets a function value.
+ See Trac #1947.
+
+ So it's important to to the right thing.
+
+* Note [Arity care]: we need to be careful if we just look at f's
+ arity. Currently (Dec07), f's arity is visible in its own RHS (see
+ Note [Arity robustness] in SimplEnv) so we must *not* trust the
+ arity when checking that 'f' is a value. Otherwise we will
+ eta-reduce
+ f = \x. f x
+ to
+ f = f
+ Which might change a terminiating program (think (f `seq` e)) to a
+ non-terminating one. So we check for being a loop breaker first.
+
+ However for GlobalIds we can look at the arity; and for primops we
+ must, since they have no unfolding.
+
+* Regardless of whether 'f' is a value, we always want to
+ reduce (/\a -> f a) to f
+ This came up in a RULE: foldr (build (/\a -> g a))
+ did not match foldr (build (/\b -> ...something complex...))
+ The type checker can insert these eta-expanded versions,
+ with both type and dictionary lambdas; hence the slightly
+ ad-hoc isDictId
+
+* Never *reduce* arity. For example
+ f = \xy. g x y
+ Then if h has arity 1 we don't want to eta-reduce because then
+ f's arity would decrease, and that is bad
+
+These delicacies are why we don't use exprIsTrivial and exprIsHNF here.
+Alas.
+
+Note [Eta reduction with casted arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ (\(x:t3). f (x |> g)) :: t3 -> t2
+ where
+ f :: t1 -> t2
+ g :: t3 ~ t1
+This should be eta-reduced to
+
+ f |> (sym g -> t2)
+
+So we need to accumulate a coercion, pushing it inward (past
+variable arguments only) thus:
+ f (x |> co_arg) |> co --> (f |> (sym co_arg -> co)) x
+ f (x:t) |> co --> (f |> (t -> co)) x
+ f @ a |> co --> (f |> (forall a.co)) @ a
+ f @ (g:t1~t2) |> co --> (f |> (t1~t2 => co)) @ (g:t1~t2)
+These are the equations for ok_arg.
+
+It's true that we could also hope to eta reduce these:
+ (\xy. (f x |> g) y)
+ (\xy. (f x y) |> g)
+But the simplifier pushes those casts outwards, so we don't
+need to address that here.
+
+\begin{code}
+tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr
+tryEtaReduce bndrs body
+ = go (reverse bndrs) body (mkReflCo (exprType body))
+ where
+ incoming_arity = count isId bndrs
+
+ go :: [Var] -- Binders, innermost first, types [a3,a2,a1]
+ -> CoreExpr -- Of type tr
+ -> Coercion -- Of type tr ~ ts
+ -> Maybe CoreExpr -- Of type a1 -> a2 -> a3 -> ts
+ -- See Note [Eta reduction with casted arguments]
+ -- for why we have an accumulating coercion
+ go [] fun co
+ | ok_fun fun = Just (mkCoerce co fun)
+
+ go (b : bs) (App fun arg) co
+ | Just co' <- ok_arg b arg co
+ = go bs fun co'
+
+ go _ _ _ = Nothing -- Failure!
+
+ ---------------
+ -- Note [Eta reduction conditions]
+ ok_fun (App fun (Type ty))
+ | not (any (`elemVarSet` tyVarsOfType ty) bndrs)
+ = ok_fun fun
+ ok_fun (Var fun_id)
+ = not (fun_id `elem` bndrs)
+ && (ok_fun_id fun_id || all ok_lam bndrs)
+ ok_fun _fun = False
+
+ ---------------
+ ok_fun_id fun = fun_arity fun >= incoming_arity
+
+ ---------------
+ fun_arity fun -- See Note [Arity care]
+ | isLocalId fun && isLoopBreaker (idOccInfo fun) = 0
+ | otherwise = idArity fun
+
+ ---------------
+ ok_lam v = isTyVar v || isEvVar v
+
+ ---------------
+ ok_arg :: Var -- Of type bndr_t
+ -> CoreExpr -- Of type arg_t
+ -> Coercion -- Of kind (t1~t2)
+ -> Maybe Coercion -- Of type (arg_t -> t1 ~ bndr_t -> t2)
+ -- (and similarly for tyvars, coercion args)
+ -- See Note [Eta reduction with casted arguments]
+ ok_arg bndr (Type ty) co
+ | Just tv <- getTyVar_maybe ty
+ , bndr == tv = Just (mkForAllCo tv co)
+ ok_arg bndr (Var v) co
+ | bndr == v = Just (mkFunCo (mkReflCo (idType bndr)) co)
+ ok_arg bndr (Cast (Var v) co_arg) co
+ | bndr == v = Just (mkFunCo (mkSymCo co_arg) co)
+ -- The simplifier combines multiple casts into one,
+ -- so we can have a simple-minded pattern match here
+ ok_arg _ _ _ = Nothing
projects / ghc-hetmet.git / blobdiff