X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreUnfold.lhs;h=247e969fdefd4b5b1cc1f746b6e874b3a12cb3f9;hp=37eede1e4eec080e2e6cdaab1b7a88a6ed5ff66a;hb=5eb1c77c795f92ed0f4c8023847e9d4be1a4fd0d;hpb=12899612693163154531da3285ec99c1c8ca2226

diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs
index 37eede1..247e969 100644
--- a/ghc/compiler/coreSyn/CoreUnfold.lhs
+++ b/ghc/compiler/coreSyn/CoreUnfold.lhs
@@ -43,13 +43,12 @@ import CoreUtils	( coreExprType )
 import CostCentre	( ccMentionsId )
 import Id		( idType, getIdArity,  isBottomingId, 
 			  SYN_IE(IdSet), GenId{-instances-} )
-import PrimOp		( fragilePrimOp, PrimOp(..) )
+import PrimOp		( primOpCanTriggerGC, fragilePrimOp, PrimOp(..) )
 import IdInfo		( arityMaybe, bottomIsGuaranteed )
 import Literal		( isNoRepLit, isLitLitLit )
 import Pretty
-import PrimOp		( primOpCanTriggerGC, PrimOp(..) )
 import TyCon		( tyConFamilySize )
-import Type		( getAppDataTyConExpandingDicts )
+import Type		( maybeAppDataTyConExpandingDicts )
 import UniqSet		( emptyUniqSet, unitUniqSet, mkUniqSet,
 			  addOneToUniqSet, unionUniqSets
 			)
@@ -148,6 +147,7 @@ mkFormSummary expr
   where
     go n (Lit _)	= ASSERT(n==0) ValueForm
     go n (Con _ _)      = ASSERT(n==0) ValueForm
+    go n (Prim _ _)	= OtherForm
     go n (SCC _ e)      = go n e
     go n (Coerce _ _ e) = go n e
     go n (Let _ e)      = OtherForm
@@ -229,10 +229,16 @@ calcUnfoldingGuidance scc_s_OK bOMB_OUT_SIZE expr
 			(length val_binders)
 			(map discount_for val_binders)
 			size
-	       discount_for b | b `is_elem` cased_args = tyConFamilySize tycon
-			      | otherwise	       = 0
-			      where
-				(tycon, _, _) = getAppDataTyConExpandingDicts (idType b)
+
+	       discount_for b
+	         | is_data && b `is_elem` cased_args = tyConFamilySize tycon
+		 | otherwise = 0
+		 where
+		   (is_data, tycon)
+		     = --trace "CoreUnfold.getAppDataTyConExpandingDicts:1" $ 
+			case (maybeAppDataTyConExpandingDicts (idType b)) of
+			  Nothing       -> (False, panic "discount")
+			  Just (tc,_,_) -> (True,  tc)
 	   in
 	   -- pprTrace "calcUnfold:" (ppAbove (ppr PprDebug uf) (ppr PprDebug expr))
 	   uf
@@ -307,7 +313,7 @@ sizeExpr scc_s_OK bOMB_OUT_SIZE args expr
     ------------
     size_up_alts scrut_ty (AlgAlts alts deflt)
       = foldr (addSize . size_alg_alt) (size_up_deflt deflt) alts
-		`addSizeN` (tyConFamilySize tycon)
+		`addSizeN` (if is_data then tyConFamilySize tycon else 1{-??-})
 	-- NB: we charge N for an alg. "case", where N is
 	-- the number of constructors in the thing being eval'd.
 	-- (You'll eventually get a "discount" of N if you
@@ -316,8 +322,11 @@ sizeExpr scc_s_OK bOMB_OUT_SIZE args expr
 	size_alg_alt (con,args,rhs) = size_up rhs
 	    -- Don't charge for args, so that wrappers look cheap
 
-	(tycon, _, _) = --trace "CoreUnfold.getAppDataTyConExpandingDicts" $ 
-			getAppDataTyConExpandingDicts scrut_ty
+	(is_data,tycon)
+	  = --trace "CoreUnfold.getAppDataTyConExpandingDicts:2" $ 
+	    case (maybeAppDataTyConExpandingDicts scrut_ty) of
+	      Nothing       -> (False, panic "size_up_alts")
+	      Just (tc,_,_) -> (True, tc)
 
     size_up_alts _ (PrimAlts alts deflt)
       = foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts
@@ -345,7 +354,6 @@ sizeExpr scc_s_OK bOMB_OUT_SIZE args expr
     sizeZero  = Just (0, [])
     sizeOne   = Just (1, [])
     sizeN n   = Just (n, [])
-    sizeVar v = Just (0, [v])
 
     addSizeN Nothing _ = Nothing
     addSizeN (Just (n, xs)) m