X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUtils.lhs;h=b58825b38afb76fe80d1aad6a75478adc8b9633a;hp=0077183ac346b670c8c58be488ee2871b954d941;hb=17b297d97d327620ed6bfab942f8992b2446f1bf;hpb=204e70a4a6b977116c77226f014ebed5407713c2 diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 0077183..b58825b 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -1,17 +1,26 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[CoreUtils]{Utility functions on @Core@ syntax} + +Utility functions on @Core@ syntax \begin{code} +{-# OPTIONS_GHC -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings +-- for details + module CoreUtils ( -- Construction - mkInlineMe, mkSCC, mkCoerce, + mkInlineMe, mkSCC, mkCoerce, mkCoerceI, bindNonRec, needsCaseBinding, mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes, -- Taking expressions apart - findDefault, findAlt, isDefaultAlt, mergeAlts, + findDefault, findAlt, isDefaultAlt, mergeAlts, trimConArgs, -- Properties of expressions exprType, coreAltType, @@ -31,58 +40,48 @@ module CoreUtils ( hashExpr, -- Equality - cheapEqExpr, tcEqExpr, tcEqExprX, applyTypeToArgs, applyTypeToArg + cheapEqExpr, tcEqExpr, tcEqExprX, applyTypeToArgs, applyTypeToArg, + + dataConOrigInstPat, dataConRepInstPat, dataConRepFSInstPat ) where #include "HsVersions.h" - -import GLAEXTS -- For `xori` - import CoreSyn -import CoreFVs ( exprFreeVars ) -import PprCore ( pprCoreExpr ) -import Var ( Var, TyVar, isCoVar, tyVarKind ) -import VarSet ( unionVarSet ) +import CoreFVs +import PprCore +import Var +import SrcLoc +import VarSet import VarEnv -import Name ( hashName ) +import Name #if mingw32_TARGET_OS -import Packages ( isDllName ) +import Packages #endif -import Literal ( hashLiteral, literalType, litIsDupable, - litIsTrivial, isZeroLit, Literal( MachLabel ) ) -import DataCon ( DataCon, dataConRepArity, - isVanillaDataCon, dataConTyCon, dataConRepArgTys, - dataConUnivTyVars, dataConExTyVars ) -import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap ) -import Id ( Id, idType, globalIdDetails, idNewStrictness, - mkWildId, idArity, idName, idUnfolding, idInfo, - isOneShotBndr, isStateHackType, isDataConWorkId_maybe, mkSysLocal, - isDataConWorkId, isBottomingId, isDictId - ) -import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo ) -import NewDemand ( appIsBottom ) -import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, - splitFunTy, tcEqTypeX, - applyTys, isUnLiftedType, seqType, mkTyVarTy, - splitForAllTy_maybe, isForAllTy, splitRecNewType_maybe, - splitTyConApp_maybe, coreEqType, funResultTy, applyTy, - substTyWith - ) -import Coercion ( Coercion, mkTransCoercion, coercionKind, - splitNewTypeRepCo_maybe, mkSymCoercion, mkLeftCoercion, - mkRightCoercion, decomposeCo, coercionKindPredTy, - splitCoercionKind ) -import TyCon ( tyConArity ) -import TysWiredIn ( boolTy, trueDataCon, falseDataCon ) -import CostCentre ( CostCentre ) -import BasicTypes ( Arity ) -import PackageConfig ( PackageId ) -import Unique ( Unique ) +import Literal +import DataCon +import PrimOp +import Id +import IdInfo +import NewDemand +import Type +import Coercion +import TyCon +import TysWiredIn +import CostCentre +import BasicTypes +import PackageConfig +import Unique import Outputable -import DynFlags ( DynFlags, DynFlag(Opt_DictsCheap), dopt ) -import TysPrim ( alphaTy ) -- Debugging only -import Util ( equalLength, lengthAtLeast, foldl2 ) +import DynFlags +import TysPrim +import FastString +import Maybes +import Util +import Data.Word +import Data.Bits + +import GHC.Exts -- For `xori` \end{code} @@ -95,14 +94,13 @@ import Util ( equalLength, lengthAtLeast, foldl2 ) \begin{code} exprType :: CoreExpr -> Type -exprType (Var var) = idType var -exprType (Lit lit) = literalType lit -exprType (Let _ body) = exprType body -exprType (Case _ _ ty alts) = ty -exprType (Cast e co) - = let (_, ty) = coercionKind co in ty -exprType (Note other_note e) = exprType e -exprType (Lam binder expr) = mkPiType binder (exprType expr) +exprType (Var var) = idType var +exprType (Lit lit) = literalType lit +exprType (Let _ body) = exprType body +exprType (Case _ _ ty alts) = ty +exprType (Cast e co) = snd (coercionKind co) +exprType (Note other_note e) = exprType e +exprType (Lam binder expr) = mkPiType binder (exprType expr) exprType e@(App _ _) = case collectArgs e of (fun, args) -> applyTypeToArgs e (exprType fun) args @@ -203,10 +201,14 @@ mkInlineMe e = Note InlineMe e \begin{code} +mkCoerceI :: CoercionI -> CoreExpr -> CoreExpr +mkCoerceI IdCo e = e +mkCoerceI (ACo co) e = mkCoerce co e + mkCoerce :: Coercion -> CoreExpr -> CoreExpr mkCoerce co (Cast expr co2) - = ASSERT(let { (from_ty, to_ty) = coercionKind co; - (from_ty2, to_ty2) = coercionKind co2} in + = ASSERT(let { (from_ty, _to_ty) = coercionKind co; + (_from_ty2, to_ty2) = coercionKind co2} in from_ty `coreEqType` to_ty2 ) mkCoerce (mkTransCoercion co2 co) expr @@ -268,6 +270,8 @@ mkAltExpr (DataAlt con) args inst_tys = mkConApp con (map Type inst_tys ++ varsToCoreExprs args) mkAltExpr (LitAlt lit) [] [] = Lit lit +mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt" +mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT" mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr mkIfThenElse guard then_expr else_expr @@ -322,6 +326,18 @@ mergeAlts (a1:as1) (a2:as2) LT -> a1 : mergeAlts as1 (a2:as2) EQ -> a1 : mergeAlts as1 as2 -- Discard a2 GT -> a2 : mergeAlts (a1:as1) as2 + + +--------------------------------- +trimConArgs :: AltCon -> [CoreArg] -> [CoreArg] +-- Given case (C a b x y) of +-- C b x y -> ... +-- we want to drop the leading type argument of the scrutinee +-- leaving the arguments to match agains the pattern + +trimConArgs DEFAULT args = ASSERT( null args ) [] +trimConArgs (LitAlt lit) args = ASSERT( null args ) [] +trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args \end{code} @@ -527,7 +543,9 @@ side effects, and can't diverge or raise an exception. exprOkForSpeculation :: CoreExpr -> Bool exprOkForSpeculation (Lit _) = True exprOkForSpeculation (Type _) = True + -- Tick boxes are *not* suitable for speculation exprOkForSpeculation (Var v) = isUnLiftedType (idType v) + && not (isTickBoxOp v) exprOkForSpeculation (Note _ e) = exprOkForSpeculation e exprOkForSpeculation (Cast e co) = exprOkForSpeculation e exprOkForSpeculation other_expr @@ -612,8 +630,8 @@ Because `seq` on such things completes immediately For unlifted argument types, we have to be careful: C (f x :: Int#) -Suppose (f x) diverges; then C (f x) is not a value. True, but -this form is illegal (see the invariants in CoreSyn). Args of unboxed +Suppose (f x) diverges; then C (f x) is not a value. However this can't +happen: see CoreSyn Note [CoreSyn let/app invariant]. Args of unboxed type must be ok-for-speculation (or trivial). \begin{code} @@ -627,123 +645,194 @@ exprIsHNF (Var v) -- NB: There are no value args at this point -- A worry: what if an Id's unfolding is just itself: -- then we could get an infinite loop... -exprIsHNF (Lit l) = True -exprIsHNF (Type ty) = True -- Types are honorary Values; - -- we don't mind copying them -exprIsHNF (Lam b e) = isRuntimeVar b || exprIsHNF e -exprIsHNF (Note _ e) = exprIsHNF e -exprIsHNF (Cast e co) = exprIsHNF e +exprIsHNF (Lit l) = True +exprIsHNF (Type ty) = True -- Types are honorary Values; + -- we don't mind copying them +exprIsHNF (Lam b e) = isRuntimeVar b || exprIsHNF e +exprIsHNF (Note _ e) = exprIsHNF e +exprIsHNF (Cast e co) = exprIsHNF e exprIsHNF (App e (Type _)) = exprIsHNF e exprIsHNF (App e a) = app_is_value e [a] -exprIsHNF other = False +exprIsHNF other = False -- There is at least one value argument app_is_value (Var fun) args - | isDataConWorkId fun -- Constructor apps are values - || idArity fun > valArgCount args -- Under-applied function - = check_args (idType fun) args -app_is_value (App f a) as = app_is_value f (a:as) -app_is_value other as = False - - -- 'check_args' checks that unlifted-type args - -- are in fact guaranteed non-divergent -check_args fun_ty [] = True -check_args fun_ty (Type _ : args) = case splitForAllTy_maybe fun_ty of - Just (_, ty) -> check_args ty args -check_args fun_ty (arg : args) - | isUnLiftedType arg_ty = exprOkForSpeculation arg - | otherwise = check_args res_ty args - where - (arg_ty, res_ty) = splitFunTy fun_ty + = idArity fun > valArgCount args -- Under-applied function + || isDataConWorkId fun -- or data constructor +app_is_value (Note n f) as = app_is_value f as +app_is_value (Cast f _) as = app_is_value f as +app_is_value (App f a) as = app_is_value f (a:as) +app_is_value other as = False \end{code} \begin{code} --- deep applies a TyConApp coercion as a substitution to a reflexive coercion --- deepCast t [a1,...,an] co corresponds to deep(t, [a1,...,an], co) from --- FC paper -deepCast :: Type -> [TyVar] -> Coercion -> Coercion -deepCast ty tyVars co - = ASSERT( let {(lty, rty) = coercionKind co; - Just (tc1, lArgs) = splitTyConApp_maybe lty; - Just (tc2, rArgs) = splitTyConApp_maybe rty} - in - tc1 == tc2 && length lArgs == length rArgs && - length lArgs == length tyVars ) - substTyWith tyVars coArgs ty - where - -- coArgs = [right (left (left co)), right (left co), right co] - coArgs = decomposeCo (length tyVars) co +-- These InstPat functions go here to avoid circularity between DataCon and Id +dataConRepInstPat = dataConInstPat dataConRepArgTys (repeat (FSLIT("ipv"))) +dataConRepFSInstPat = dataConInstPat dataConRepArgTys +dataConOrigInstPat = dataConInstPat dc_arg_tys (repeat (FSLIT("ipv"))) + where + dc_arg_tys dc = map mkPredTy (dataConEqTheta dc) ++ map mkPredTy (dataConDictTheta dc) ++ dataConOrigArgTys dc + -- Remember to include the existential dictionaries + +dataConInstPat :: (DataCon -> [Type]) -- function used to find arg tys + -> [FastString] -- A long enough list of FSs to use for names + -> [Unique] -- An equally long list of uniques, at least one for each binder + -> DataCon + -> [Type] -- Types to instantiate the universally quantified tyvars + -> ([TyVar], [CoVar], [Id]) -- Return instantiated variables +-- dataConInstPat arg_fun fss us con inst_tys returns a triple +-- (ex_tvs, co_tvs, arg_ids), +-- +-- ex_tvs are intended to be used as binders for existential type args +-- +-- co_tvs are intended to be used as binders for coercion args and the kinds +-- of these vars have been instantiated by the inst_tys and the ex_tys +-- The co_tvs include both GADT equalities (dcEqSpec) and +-- programmer-specified equalities (dcEqTheta) +-- +-- arg_ids are indended to be used as binders for value arguments, +-- and their types have been instantiated with inst_tys and ex_tys +-- The arg_ids include both dicts (dcDictTheta) and +-- programmer-specified arguments (after rep-ing) (deRepArgTys) +-- +-- Example. +-- The following constructor T1 +-- +-- data T a where +-- T1 :: forall b. Int -> b -> T(a,b) +-- ... +-- +-- has representation type +-- forall a. forall a1. forall b. (a :=: (a1,b)) => +-- Int -> b -> T a +-- +-- dataConInstPat fss us T1 (a1',b') will return +-- +-- ([a1'', b''], [c :: (a1', b'):=:(a1'', b'')], [x :: Int, y :: b'']) +-- +-- where the double-primed variables are created with the FastStrings and +-- Uniques given as fss and us +dataConInstPat arg_fun fss uniqs con inst_tys + = (ex_bndrs, co_bndrs, arg_ids) + where + univ_tvs = dataConUnivTyVars con + ex_tvs = dataConExTyVars con + arg_tys = arg_fun con + eq_spec = dataConEqSpec con + eq_theta = dataConEqTheta con + eq_preds = eqSpecPreds eq_spec ++ eq_theta + + n_ex = length ex_tvs + n_co = length eq_preds + + -- split the Uniques and FastStrings + (ex_uniqs, uniqs') = splitAt n_ex uniqs + (co_uniqs, id_uniqs) = splitAt n_co uniqs' + + (ex_fss, fss') = splitAt n_ex fss + (co_fss, id_fss) = splitAt n_co fss' + + -- Make existential type variables + ex_bndrs = zipWith3 mk_ex_var ex_uniqs ex_fss ex_tvs + mk_ex_var uniq fs var = mkTyVar new_name kind + where + new_name = mkSysTvName uniq fs + kind = tyVarKind var + + -- Make the instantiating substitution + subst = zipOpenTvSubst (univ_tvs ++ ex_tvs) (inst_tys ++ map mkTyVarTy ex_bndrs) + + -- Make new coercion vars, instantiating kind + co_bndrs = zipWith3 mk_co_var co_uniqs co_fss eq_preds + mk_co_var uniq fs eq_pred = mkCoVar new_name co_kind + where + new_name = mkSysTvName uniq fs + co_kind = substTy subst (mkPredTy eq_pred) + + -- make value vars, instantiating types + mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (substTy subst ty) noSrcSpan + arg_ids = zipWith3 mk_id_var id_uniqs id_fss arg_tys exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr]) -- Returns (Just (dc, [x1..xn])) if the argument expression is -- a constructor application of the form (dc x1 .. xn) - exprIsConApp_maybe (Cast expr co) - = -- Maybe this is over the top, but here we try to turn - -- coerce (S,T) ( x, y ) - -- effectively into - -- ( coerce S x, coerce T y ) - -- This happens in anger in PrelArrExts which has a coerce - -- case coerce memcpy a b of - -- (# r, s #) -> ... - -- where the memcpy is in the IO monad, but the call is in - -- the (ST s) monad + = -- Here we do the PushC reduction rule as described in the FC paper case exprIsConApp_maybe expr of { - Nothing -> Nothing ; - Just (dc, args) -> - - let (from_ty, to_ty) = coercionKind co in - + Nothing -> Nothing ; + Just (dc, dc_args) -> + + -- The transformation applies iff we have + -- (C e1 ... en) `cast` co + -- where co :: (T t1 .. tn) :=: (T s1 ..sn) + -- That is, with a T at the top of both sides + -- The left-hand one must be a T, because exprIsConApp returned True + -- but the right-hand one might not be. (Though it usually will.) + + let (from_ty, to_ty) = coercionKind co + (from_tc, from_tc_arg_tys) = splitTyConApp from_ty + -- The inner one must be a TyConApp + in case splitTyConApp_maybe to_ty of { Nothing -> Nothing ; - Just (tc, tc_arg_tys) | tc /= dataConTyCon dc -> Nothing - -- | not (isVanillaDataCon dc) -> Nothing - | otherwise -> - -- Type constructor must match datacon - - case splitTyConApp_maybe from_ty of { - Nothing -> Nothing ; - Just (tc', tc_arg_tys') | tc /= tc' -> Nothing - -- Both sides of coercion must have the same type constructor - | otherwise -> - + Just (to_tc, to_tc_arg_tys) + | from_tc /= to_tc -> Nothing + -- These two Nothing cases are possible; we might see + -- (C x y) `cast` (g :: T a ~ S [a]), + -- where S is a type function. In fact, exprIsConApp + -- will probably not be called in such circumstances, + -- but there't nothing wrong with it + + | otherwise -> let - -- here we do the PushC reduction rule as described in the FC paper - arity = tyConArity tc - n_ex_tvs = length dc_ex_tyvars + tc_arity = tyConArity from_tc - (univ_args, rest) = splitAt arity args - (ex_args, val_args) = splitAt n_ex_tvs rest + (univ_args, rest1) = splitAt tc_arity dc_args + (ex_args, rest2) = splitAt n_ex_tvs rest1 + (co_args, val_args) = splitAt n_cos rest2 arg_tys = dataConRepArgTys dc - dc_tyvars = dataConUnivTyVars dc + dc_univ_tyvars = dataConUnivTyVars dc dc_ex_tyvars = dataConExTyVars dc - - deep arg_ty = deepCast arg_ty dc_tyvars co - - -- first we appropriately cast the value arguments - arg_cos = map deep arg_tys - new_val_args = zipWith mkCoerce (map deep arg_tys) val_args - - -- then we cast the existential coercion arguments - orig_tvs = dc_tyvars ++ dc_ex_tyvars - gammas = decomposeCo arity co - new_tys = gammas ++ (map (\ (Type t) -> t) ex_args) - theta = substTyWith orig_tvs new_tys - cast_ty tv (Type ty) - | isCoVar tv - , (ty1, ty2) <- splitCoercionKind (tyVarKind tv) - = Type $ mkTransCoercion (mkSymCoercion (theta ty1)) - (mkTransCoercion ty (theta ty2)) - | otherwise - = Type ty - new_ex_args = zipWith cast_ty dc_ex_tyvars ex_args + dc_eq_spec = dataConEqSpec dc + dc_tyvars = dc_univ_tyvars ++ dc_ex_tyvars + n_ex_tvs = length dc_ex_tyvars + n_cos = length dc_eq_spec + + -- Make the "theta" from Fig 3 of the paper + gammas = decomposeCo tc_arity co + new_tys = gammas ++ map (\ (Type t) -> t) ex_args + theta = zipOpenTvSubst dc_tyvars new_tys + + -- First we cast the existential coercion arguments + cast_co (tv,ty) (Type co) = Type $ mkSymCoercion (substTyVar theta tv) + `mkTransCoercion` co + `mkTransCoercion` (substTy theta ty) + new_co_args = zipWith cast_co dc_eq_spec co_args + -- ...and now value arguments + new_val_args = zipWith cast_arg arg_tys val_args + cast_arg arg_ty arg = mkCoerce (substTy theta arg_ty) arg + in - ASSERT( all isTypeArg (take arity args) ) - ASSERT( equalLength val_args arg_tys ) - Just (dc, map Type tc_arg_tys ++ new_ex_args ++ new_val_args) - }}} + ASSERT( length univ_args == tc_arity ) + ASSERT( from_tc == dataConTyCon dc ) + ASSERT( and (zipWith coreEqType [t | Type t <- univ_args] from_tc_arg_tys) ) + ASSERT( all isTypeArg (univ_args ++ ex_args) ) + ASSERT2( equalLength val_args arg_tys, ppr dc $$ ppr dc_tyvars $$ ppr dc_ex_tyvars $$ ppr arg_tys $$ ppr dc_args $$ ppr univ_args $$ ppr ex_args $$ ppr val_args $$ ppr arg_tys ) + + Just (dc, map Type to_tc_arg_tys ++ ex_args ++ new_co_args ++ new_val_args) + }} + +{- +-- We do not want to tell the world that we have a +-- Cons, to *stop* Case of Known Cons, which removes +-- the TickBox. +exprIsConApp_maybe (Note (TickBox {}) expr) + = Nothing +exprIsConApp_maybe (Note (BinaryTickBox {}) expr) + = Nothing +-} exprIsConApp_maybe (Note _ expr) = exprIsConApp_maybe expr @@ -1061,8 +1150,13 @@ eta_expand n us (Lam v body) ty eta_expand n us expr ty = ASSERT2 (exprType expr `coreEqType` ty, ppr (exprType expr) $$ ppr ty) case splitForAllTy_maybe ty of { - Just (tv,ty') -> Lam tv (eta_expand n us (App expr (Type (mkTyVarTy tv))) ty') + Just (tv,ty') -> + Lam lam_tv (eta_expand n us2 (App expr (Type (mkTyVarTy lam_tv))) (substTyWith [tv] [mkTyVarTy lam_tv] ty')) + where + lam_tv = setVarName tv (mkSysTvName uniq FSLIT("etaT")) + -- Using tv as a base retains its tyvar/covar-ness + (uniq:us2) = us ; Nothing -> case splitFunTy_maybe ty of { @@ -1081,8 +1175,8 @@ eta_expand n us expr ty -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x) case splitNewTypeRepCo_maybe ty of { - Just(ty1,co) -> - mkCoerce co (eta_expand n us (mkCoerce (mkSymCoercion co) expr) ty1) ; + Just(ty1,co) -> mkCoerce (mkSymCoercion co) + (eta_expand n us (mkCoerce co expr) ty1) ; Nothing -> -- We have an expression of arity > 0, but its type isn't a function @@ -1164,6 +1258,7 @@ exprIsBig (Lit _) = False exprIsBig (Var v) = False exprIsBig (Type t) = False exprIsBig (App f a) = exprIsBig f || exprIsBig a +exprIsBig (Cast e _) = exprIsBig e -- Hopefully coercions are not too big! exprIsBig other = True \end{code} @@ -1240,7 +1335,7 @@ exprSize (Type t) = seqType t `seq` 1 noteSize (SCC cc) = cc `seq` 1 noteSize InlineMe = 1 noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations - + varSize :: Var -> Int varSize b | isTyVar b = 1 | otherwise = seqType (idType b) `seq` @@ -1273,32 +1368,52 @@ hashExpr :: CoreExpr -> Int -- expressions may hash to the different Ints -- -- The emphasis is on a crude, fast hash, rather than on high precision - -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 (Cast e co) = 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) +-- +-- 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 co) = hash_expr env e +hash_expr env (Var v) = hashVar env v +hash_expr env (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,r):_)) 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 env (Type t) = 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. + +fast_hash_expr env (Var v) = hashVar env v +fast_hash_expr env (Type t) = fast_hash_type env t +fast_hash_expr env (Lit lit) = fromIntegral (hashLiteral lit) +fast_hash_expr env (Cast e co) = fast_hash_expr env e +fast_hash_expr env (Note n e) = fast_hash_expr env e +fast_hash_expr env (App f a) = fast_hash_expr env a -- A bit idiosyncratic ('a' not 'f')! +fast_hash_expr env other = 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 + +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} %************************************************************************