[project @ 1996-07-25 20:43:49 by partain]

[ghc-hetmet.git] / ghc / compiler / coreSyn / CoreUnfold.lhs

diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs
index 37eede1..247e969 100644 (file)
--- 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