X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUtils.lhs;h=78da0e37faff422d182710bb9cb7ac9452a27ab5;hb=36d207aa8c9cedbf58e739178971292048bd41d0;hp=ddeffb7618cae958c90db336cce837c2d18603bd;hpb=49c98d143c382a1341e1046f5ca00819a25691ba;p=ghc-hetmet.git diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index ddeffb7..78da0e3 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -69,10 +69,8 @@ import Outputable import DynFlags import TysPrim import FastString - -#ifdef DEBUG +import Maybes import Util -#endif import GHC.Exts -- For `xori` \end{code} @@ -623,6 +621,10 @@ 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 (TickBox {}) _) + = False +exprIsHNF (Note (BinaryTickBox {}) _) + = False exprIsHNF (Note _ e) = exprIsHNF e exprIsHNF (Cast e co) = exprIsHNF e exprIsHNF (App e (Type _)) = exprIsHNF e @@ -803,6 +805,14 @@ 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. +exprIsConApp_maybe (Note (TickBox {}) expr) + = Nothing +exprIsConApp_maybe (Note (BinaryTickBox {}) expr) + = Nothing + exprIsConApp_maybe (Note _ expr) = exprIsConApp_maybe expr -- We ignore InlineMe notes in case we have @@ -1123,7 +1133,8 @@ eta_expand n us expr ty Lam lam_tv (eta_expand n us2 (App expr (Type (mkTyVarTy lam_tv))) (substTyWith [tv] [mkTyVarTy lam_tv] ty')) where - lam_tv = mkTyVar (mkSysTvName uniq FSLIT("etaT")) (tyVarKind tv) + lam_tv = setVarName tv (mkSysTvName uniq FSLIT("etaT")) + -- Using tv as a base retains its tyvar/covar-ness (uniq:us2) = us ; Nothing -> @@ -1186,6 +1197,9 @@ 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 @@ -1303,6 +1317,8 @@ 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 @@ -1336,32 +1352,48 @@ hashExpr :: CoreExpr -> Int -- expressions may hash to the different Ints -- -- The emphasis is on a crude, fast hash, rather than on high precision +-- +-- 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 | 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) + hash = abs (hash_expr (1,emptyVarEnv) e) -- Negative numbers kill UniqFM + +type HashEnv = (Int, VarEnv Int) -- Hash code for bound variables + +hash_expr :: HashEnv -> CoreExpr -> Int +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) = 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) = fast_hash_type env t + +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) = 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 -> Int +fast_hash_type env ty + | Just tv <- getTyVar_maybe ty = hashVar env tv + | Just (tc,_) <- splitTyConApp_maybe ty = 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 -> Int +hashVar (_,env) v = lookupVarEnv env v `orElse` hashName (idName v) \end{code} %************************************************************************ @@ -1448,6 +1480,8 @@ 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