X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUtils.lhs;h=6aa65838a4b490b48ece40b7882868795505f3d3;hb=273be06fa7cb1297284dbb553ecc9be7d07df6af;hp=e358be4439f67374964f37dc3aab1f4ab16ecfca;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git

diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index e358be4..6aa6583 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -11,7 +11,7 @@ module CoreUtils (
 	mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
 
 	-- Taking expressions apart
-	findDefault, findAlt, isDefaultAlt,
+	findDefault, findAlt, isDefaultAlt, mergeAlts,
 
 	-- Properties of expressions
 	exprType, coreAltType,
@@ -165,12 +165,6 @@ mkNote (SCC cc)	expr		   = mkSCC cc expr
 mkNote InlineMe expr		   = mkInlineMe expr
 mkNote note     expr		   = Note note expr
 #endif
-
--- Slide InlineCall in around the function
---	No longer necessary I think (SLPJ Apr 99)
--- mkNote InlineCall (App f a) = App (mkNote InlineCall f) a
--- mkNote InlineCall (Var v)   = Note InlineCall (Var v)
--- mkNote InlineCall expr      = expr
 \end{code}
 
 Drop trivial InlineMe's.  This is somewhat important, because if we have an unfolding
@@ -306,6 +300,18 @@ findAlt con alts
 isDefaultAlt :: CoreAlt -> Bool
 isDefaultAlt (DEFAULT, _, _) = True
 isDefaultAlt other	     = False
+
+---------------------------------
+mergeAlts :: [CoreAlt] -> [CoreAlt] -> [CoreAlt]
+-- Merge preserving order; alternatives in the first arg
+-- shadow ones in the second
+mergeAlts [] as2 = as2
+mergeAlts as1 [] = as1
+mergeAlts (a1:as1) (a2:as2)
+  = case a1 `cmpAlt` a2 of
+	LT -> a1 : mergeAlts as1      (a2:as2)
+	EQ -> a1 : mergeAlts as1      as2	-- Discard a2
+	GT -> a2 : mergeAlts (a1:as1) as2
 \end{code}
 
 
@@ -816,8 +822,9 @@ arityType (Var v)
 	--		False -> \(s:RealWorld) -> e
 	-- where foo has arity 1.  Then we want the state hack to
 	-- apply to foo too, so we can eta expand the case.
-    mk 0 tys | isBottomingId v  = ABot
-             | otherwise	= ATop
+    mk 0 tys | isBottomingId v			   = ABot
+             | (ty:tys) <- tys, isStateHackType ty = AFun True ATop
+	     | otherwise			   = ATop
     mk n (ty:tys) = AFun (isStateHackType ty) (mk (n-1) tys)
     mk n []       = AFun False		      (mk (n-1) [])
 
@@ -845,14 +852,14 @@ arityType (App f a)  	   = case arityType f of
 	--	f x y = case x of { (a,b) -> e }
 	-- The difference is observable using 'seq'
 arityType (Case scrut _ _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of
-				  xs@(AFun one_shot _) | one_shot -> xs
-				  xs | exprIsCheap scrut	  -> xs
-				     | otherwise	 	  -> ATop
+				    xs | exprIsCheap scrut	    -> xs
+				    xs@(AFun one_shot _) | one_shot -> AFun True ATop
+				    other	 	  	    -> ATop
 
 arityType (Let b e) = case arityType e of
-		        xs@(AFun one_shot _) | one_shot			      -> xs
 		        xs		     | all exprIsCheap (rhssOfBind b) -> xs
-					     | otherwise		      -> ATop
+		        xs@(AFun one_shot _) | one_shot			      -> AFun True ATop
+			other						      -> ATop
 
 arityType other = ATop
 
@@ -1094,7 +1101,6 @@ eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 && tcEqExprX (rnBndrs2 env vs1  vs2)
 
 eq_note env (SCC cc1)      (SCC cc2)      = cc1 == cc2
 eq_note env (Coerce t1 f1) (Coerce t2 f2) = tcEqTypeX env t1 t2 && tcEqTypeX env f1 f2
-eq_note env InlineCall     InlineCall     = True
 eq_note env (CoreNote s1)  (CoreNote s2)  = s1 == s2
 eq_note env other1	       other2	  = False
 \end{code}
@@ -1124,7 +1130,6 @@ exprSize (Type t)        = seqType t `seq` 1
 
 noteSize (SCC cc)       = cc `seq` 1
 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
-noteSize InlineCall     = 1
 noteSize InlineMe       = 1
 noteSize (CoreNote s)   = s `seq` 1  -- hdaume: core annotations