X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUtils.lhs;h=a43be02b5393006206c057ac590369e8ab18e5d3;hb=aee2068e034aca6ddaf6f20f85902137ecf718b7;hp=362fb5272b48625497db90b500f9bd896051544f;hpb=df95de0ba37cd137429e28821283372f63544784;p=ghc-hetmet.git

diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 362fb52..a43be02 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,
@@ -314,6 +314,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}
 
 
@@ -606,8 +618,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}
@@ -633,22 +645,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}