X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUtils.lhs;h=362fb5272b48625497db90b500f9bd896051544f;hb=957b762c4db8d3f2f3673e3595ec80c2d64a3274;hp=637f66a17e0f648f21ffbc84e6102ccc09808e8d;hpb=35d3bb34cef41053d0cb2bd03df927885b1b7d2e;p=ghc-hetmet.git diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 637f66a..362fb52 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -1,7 +1,9 @@ % +% (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} module CoreUtils ( @@ -38,57 +40,41 @@ module CoreUtils ( #include "HsVersions.h" - -import GLAEXTS -- For `xori` - import CoreSyn -import CoreFVs ( exprFreeVars ) -import PprCore ( pprCoreExpr ) -import Var ( Var, TyVar, CoVar, tyVarKind, mkCoVar, mkTyVar ) -import OccName ( mkVarOccFS ) -import SrcLoc ( noSrcLoc ) -import VarSet ( unionVarSet ) +import CoreFVs +import PprCore +import Var +import SrcLoc +import VarSet import VarEnv -import Name ( hashName, mkSysTvName ) +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, eqSpecPreds, - dataConTyCon, dataConRepArgTys, - dataConUnivTyVars, dataConExTyVars, dataConEqSpec, - dataConOrigArgTys, dataConTheta ) -import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap ) -import Id ( Id, idType, globalIdDetails, idNewStrictness, - mkWildId, idArity, idName, idUnfolding, idInfo, - isOneShotBndr, isStateHackType, - isDataConWorkId_maybe, mkSysLocal, mkUserLocal, - 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, - splitTyConApp_maybe, splitTyConApp, coreEqType, funResultTy, applyTy, - substTyWith, mkPredTy, zipOpenTvSubst, substTy, substTyVar - ) -import Coercion ( Coercion, mkTransCoercion, coercionKind, - splitNewTypeRepCo_maybe, mkSymCoercion, - decomposeCo, coercionKindPredTy ) -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 FastString ( FastString ) +import DynFlags +import TysPrim +import FastString +import Maybes +import Util +import Data.Word +import Data.Bits + +import GHC.Exts -- For `xori` \end{code} @@ -533,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 @@ -633,15 +621,15 @@ 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 @@ -817,6 +805,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 @@ -1137,7 +1135,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 -> @@ -1240,6 +1239,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} @@ -1316,7 +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 - + varSize :: Var -> Int varSize b | isTyVar b = 1 | otherwise = seqType (idType b) `seq` @@ -1349,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} %************************************************************************