X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUtils.lhs;h=92f89790e796f6f77a554ff5e99b9b52340c5b46;hb=7b01315da1b2fab02d3778bedec3ae8c57a1bc42;hp=b0de6f294dd59b81a69b40d5aef38b94987f82f5;hpb=ab22f4e6456820c1b5169d75f5975a94e61f54ce;p=ghc-hetmet.git diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index b0de6f2..92f8979 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 @@ -601,8 +606,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} @@ -628,22 +633,12 @@ 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} @@ -800,6 +795,16 @@ 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 @@ -1120,7 +1125,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 -> @@ -1300,7 +1306,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` @@ -1333,32 +1339,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} %************************************************************************