X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUtils.lhs;h=a425bc3b9ad1b6007199a527764912b74de7f12b;hb=5815105cd4613a200c3730b76aa342c979f9fcec;hp=ddeffb7618cae958c90db336cce837c2d18603bd;hpb=49c98d143c382a1341e1046f5ca00819a25691ba;p=ghc-hetmet.git

diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index ddeffb7..a425bc3 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -13,7 +13,7 @@ module CoreUtils (
 	mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
 
 	-- Taking expressions apart
-	findDefault, findAlt, isDefaultAlt, mergeAlts,
+	findDefault, findAlt, isDefaultAlt, mergeAlts, trimConArgs,
 
 	-- Properties of expressions
 	exprType, coreAltType,
@@ -69,10 +69,10 @@ import Outputable
 import DynFlags
 import TysPrim
 import FastString
-
-#ifdef DEBUG
+import Maybes
 import Util
-#endif
+import Data.Word
+import Data.Bits
 
 import GHC.Exts		-- For `xori` 
 \end{code}
@@ -87,14 +87,13 @@ import GHC.Exts		-- For `xori`
 \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
@@ -314,6 +313,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}
 
 
@@ -519,7 +530,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
@@ -604,8 +617,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}
@@ -631,22 +644,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}
@@ -803,6 +806,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
@@ -1123,7 +1136,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 ->
   
@@ -1303,7 +1317,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`
@@ -1336,32 +1350,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}
 
 %************************************************************************