X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUtils.lhs;h=b58825b38afb76fe80d1aad6a75478adc8b9633a;hp=b847df0f17dc26cccce5803c3a518a6ce8aefd03;hb=17b297d97d327620ed6bfab942f8992b2446f1bf;hpb=8100cd4395e46ae747be4298c181a4730d6206bc

diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index b847df0..b58825b 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -6,14 +6,21 @@
 Utility functions on @Core@ syntax
 
 \begin{code}
+{-# OPTIONS_GHC -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
+-- for details
+
 module CoreUtils (
 	-- Construction
-	mkInlineMe, mkSCC, mkCoerce, 
+	mkInlineMe, mkSCC, mkCoerce, mkCoerceI,
 	bindNonRec, needsCaseBinding,
 	mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
 
 	-- Taking expressions apart
-	findDefault, findAlt, isDefaultAlt, mergeAlts,
+	findDefault, findAlt, isDefaultAlt, mergeAlts, trimConArgs,
 
 	-- Properties of expressions
 	exprType, coreAltType,
@@ -71,6 +78,8 @@ import TysPrim
 import FastString
 import Maybes
 import Util
+import Data.Word
+import Data.Bits
 
 import GHC.Exts		-- For `xori` 
 \end{code}
@@ -85,14 +94,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
@@ -193,6 +201,10 @@ mkInlineMe e	   = Note InlineMe e
 
 
 \begin{code}
+mkCoerceI :: CoercionI -> CoreExpr -> CoreExpr
+mkCoerceI IdCo e = e
+mkCoerceI (ACo co) e = mkCoerce co e
+
 mkCoerce :: Coercion -> CoreExpr -> CoreExpr
 mkCoerce co (Cast expr co2)
   = ASSERT(let { (from_ty, _to_ty) = coercionKind co; 
@@ -258,6 +270,8 @@ mkAltExpr (DataAlt con) args inst_tys
   = mkConApp con (map Type inst_tys ++ varsToCoreExprs args)
 mkAltExpr (LitAlt lit) [] []
   = Lit lit
+mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt"
+mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT"
 
 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
 mkIfThenElse guard then_expr else_expr
@@ -312,6 +326,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}
 
 
@@ -604,8 +630,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 +657,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}
@@ -655,7 +671,7 @@ dataConRepInstPat   = dataConInstPat dataConRepArgTys (repeat (FSLIT("ipv")))
 dataConRepFSInstPat = dataConInstPat dataConRepArgTys
 dataConOrigInstPat  = dataConInstPat dc_arg_tys       (repeat (FSLIT("ipv")))
   where 
-    dc_arg_tys dc = map mkPredTy (dataConTheta dc) ++ dataConOrigArgTys dc
+    dc_arg_tys dc = map mkPredTy (dataConEqTheta dc) ++ map mkPredTy (dataConDictTheta dc) ++ dataConOrigArgTys dc
 	-- Remember to include the existential dictionaries
 
 dataConInstPat :: (DataCon -> [Type])      -- function used to find arg tys
@@ -671,9 +687,13 @@ dataConInstPat :: (DataCon -> [Type])      -- function used to find arg tys
 --
 --   co_tvs are intended to be used as binders for coercion args and the kinds
 --     of these vars have been instantiated by the inst_tys and the ex_tys
+--     The co_tvs include both GADT equalities (dcEqSpec) and 
+--     programmer-specified equalities (dcEqTheta)
 --
---   arg_ids are indended to be used as binders for value arguments, including
---     dicts, and their types have been instantiated with inst_tys and ex_tys
+--   arg_ids are indended to be used as binders for value arguments, 
+--     and their types have been instantiated with inst_tys and ex_tys
+--     The arg_ids include both dicts (dcDictTheta) and
+--     programmer-specified arguments (after rep-ing) (deRepArgTys)
 --
 -- Example.
 --  The following constructor T1
@@ -693,16 +713,17 @@ dataConInstPat :: (DataCon -> [Type])      -- function used to find arg tys
 --  where the double-primed variables are created with the FastStrings and
 --  Uniques given as fss and us
 dataConInstPat arg_fun fss uniqs con inst_tys 
-  = (ex_bndrs, co_bndrs, id_bndrs)
+  = (ex_bndrs, co_bndrs, arg_ids)
   where 
     univ_tvs = dataConUnivTyVars con
     ex_tvs   = dataConExTyVars con
     arg_tys  = arg_fun con
     eq_spec  = dataConEqSpec con
-    eq_preds = eqSpecPreds eq_spec
+    eq_theta = dataConEqTheta con
+    eq_preds = eqSpecPreds eq_spec ++ eq_theta
 
     n_ex = length ex_tvs
-    n_co = length eq_spec
+    n_co = length eq_preds
 
       -- split the Uniques and FastStrings
     (ex_uniqs, uniqs')   = splitAt n_ex uniqs
@@ -729,8 +750,8 @@ dataConInstPat arg_fun fss uniqs con inst_tys
          co_kind  = substTy subst (mkPredTy eq_pred)
 
       -- make value vars, instantiating types
-    mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (substTy subst ty) noSrcLoc
-    id_bndrs = zipWith3 mk_id_var id_uniqs id_fss arg_tys
+    mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (substTy subst ty) noSrcSpan
+    arg_ids = zipWith3 mk_id_var id_uniqs id_fss arg_tys
 
 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
 -- Returns (Just (dc, [x1..xn])) if the argument expression is 
@@ -1154,8 +1175,8 @@ eta_expand n us expr ty
 		--	coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
 
     	case splitNewTypeRepCo_maybe ty of {
- 	  Just(ty1,co) -> 
-              mkCoerce (mkSymCoercion co) (eta_expand n us (mkCoerce co expr) ty1) ;
+ 	  Just(ty1,co) -> mkCoerce (mkSymCoercion co) 
+				   (eta_expand n us (mkCoerce co expr) ty1) ;
  	  Nothing  -> 
 
 	-- We have an expression of arity > 0, but its type isn't a function
@@ -1351,44 +1372,48 @@ hashExpr :: CoreExpr -> Int
 -- 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 (1,emptyVarEnv) e)	-- Negative numbers kill UniqFM
+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 -> Int
+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)		      = hashLiteral lit
+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)	              = fast_hash_type env t
+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)	= hashLiteral lit
+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 -> Int
+fast_hash_type :: HashEnv -> Type -> Word32
 fast_hash_type env ty 
-  | Just tv <- getTyVar_maybe ty          = hashVar env tv
-  | Just (tc,_) <- splitTyConApp_maybe ty = hashName (tyConName tc)
-  | otherwise				  = 1
+  | 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 -> Int
-hashVar (_,env) v = lookupVarEnv env v `orElse` hashName (idName v)
+hashVar :: HashEnv -> Var -> Word32
+hashVar (_,env) v
+ = fromIntegral (lookupVarEnv env v `orElse` hashName (idName v))
 \end{code}
 
 %************************************************************************