X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUtils.lhs;h=362fb5272b48625497db90b500f9bd896051544f;hb=8ffdb8eed6b38db00761093889f5cddbe8ca1d60;hp=d82acb967ca5a40eb251430c871dab76ce709c33;hpb=d5934bbb856aa0aa620c9b2e0fa51c90a1a5a048;p=ghc-hetmet.git diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index d82acb9..362fb52 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -69,7 +69,10 @@ import Outputable import DynFlags import TysPrim import FastString +import Maybes import Util +import Data.Word +import Data.Bits import GHC.Exts -- For `xori` \end{code} @@ -516,7 +519,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 @@ -800,6 +805,7 @@ exprIsConApp_maybe (Cast expr co) 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. @@ -807,6 +813,7 @@ exprIsConApp_maybe (Note (TickBox {}) expr) = Nothing exprIsConApp_maybe (Note (BinaryTickBox {}) expr) = Nothing +-} exprIsConApp_maybe (Note _ expr) = exprIsConApp_maybe expr @@ -1192,9 +1199,6 @@ exprArity e = go e go (Var v) = idArity v go (Lam x e) | isId x = go e + 1 | otherwise = go e - go (Note (TickBox {}) _) = 0 - go (Note (BinaryTickBox {}) _) - = 0 go (Note n e) = go e go (Cast e _) = go e go (App e (Type t)) = go e @@ -1312,9 +1316,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 -noteSize (TickBox m n) = m `seq` n `seq` 1 -noteSize (BinaryTickBox m t e) = m `seq` t `seq` e `seq` 1 - + varSize :: Var -> Int varSize b | isTyVar b = 1 | otherwise = seqType (idType b) `seq` @@ -1347,32 +1349,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,_) <- splitTyConApp_maybe ty + = fromIntegral (hashName (tyConName tc)) + | 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} %************************************************************************ @@ -1459,8 +1481,6 @@ rhsIsStatic this_pkg rhs = is_static False rhs is_static False (Lam b e) = isRuntimeVar b || is_static False e is_static in_arg (Note (SCC _) e) = False - is_static in_arg (Note (TickBox {}) e) = False - is_static in_arg (Note (BinaryTickBox {}) e) = False is_static in_arg (Note _ e) = is_static in_arg e is_static in_arg (Cast e co) = is_static in_arg e