[project @ 1996-06-26 10:26:00 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 9266898..06f4be4 100644 (file)
--- a/ghc/compiler/coreSyn/CoreUnfold.lhs
+++ b/ghc/compiler/coreSyn/CoreUnfold.lhs
@@ -20,17 +20,17 @@ module CoreUnfold (
        FormSummary(..),
 
        mkFormSummary,
-       mkGenForm,
+       mkGenForm, mkLitForm, mkConForm,
+       whnfDetails,
        mkMagicUnfolding,
-       modifyUnfoldingDetails,
        calcUnfoldingGuidance,
        mentionedInUnfolding
     ) where
 
-import Ubiq
-import IdLoop   -- for paranoia checking;
+IMP_Ubiq()
+IMPORT_DELOOPER(IdLoop)         -- for paranoia checking;
                 -- and also to get mkMagicUnfoldingFun
-import PrelLoop  -- for paranoia checking
+IMPORT_DELOOPER(PrelLoop)  -- for paranoia checking
 
 import Bag             ( emptyBag, unitBag, unionBags, Bag )
 import BinderInfo      ( oneTextualOcc, oneSafeOcc )
@@ -41,17 +41,17 @@ import CgCompInfo   ( uNFOLDING_CHEAP_OP_COST,
 import CoreSyn
 import CoreUtils       ( coreExprType, manifestlyWHNF )
 import CostCentre      ( ccMentionsId )
-import Id              ( IdSet(..), GenId{-instances-} )
+import Id              ( SYN_IE(IdSet), GenId{-instances-} )
 import IdInfo          ( bottomIsGuaranteed )
 import Literal         ( isNoRepLit, isLitLitLit )
 import Pretty
 import PrimOp          ( primOpCanTriggerGC, PrimOp(..) )
 import TyCon           ( tyConFamilySize )
-import Type            ( getAppDataTyCon )
+import Type            ( getAppDataTyConExpandingDicts )
 import UniqSet         ( emptyUniqSet, unitUniqSet, mkUniqSet,
                          addOneToUniqSet, unionUniqSets
                        )
-import Usage           ( UVar(..) )
+import Usage           ( SYN_IE(UVar) )
 import Util            ( isIn, panic )
 
 whatsMentionedInId = panic "whatsMentionedInId (CoreUnfold)"
@@ -70,16 +70,9 @@ getMentionedTyConsAndClassesFromType = panic "getMentionedTyConsAndClassesFromTy
 data UnfoldingDetails
   = NoUnfoldingDetails
 
-  | LitForm
-       Literal
-
   | OtherLitForm
        [Literal]               -- It is a literal, but definitely not one of these
 
-  | ConForm
-       Id                      -- The constructor
-       [CoreArg]               -- Value arguments; NB OutArgs, already cloned
-
   | OtherConForm
        [Id]                    -- It definitely isn't one of these constructors
                                -- This captures the situation in the default branch of
@@ -97,10 +90,6 @@ data UnfoldingDetails
 
 
   | GenForm
-       Bool                    -- True <=> At most one textual occurrence of the
-                               --              binder in its scope, *or*
-                               --              if we are happy to duplicate this
-                               --              binding.
        FormSummary             -- Tells whether the template is a WHNF or bottom
        TemplateOutExpr         -- The template
        UnfoldingGuidance       -- Tells about the *size* of the template.
@@ -140,6 +129,12 @@ mkFormSummary si expr
   -- | manifestlyBottom expr  = BottomForm
 
   | otherwise = OtherForm
+
+whnfDetails :: UnfoldingDetails -> Bool                -- True => thing is evaluated
+whnfDetails (GenForm WhnfForm _ _) = True
+whnfDetails (OtherLitForm _)      = True
+whnfDetails (OtherConForm _)      = True
+whnfDetails other                 = False
 \end{code}
 
 \begin{code}
@@ -191,46 +186,25 @@ instance Outputable UnfoldingGuidance where
 
 %************************************************************************
 %*                                                                     *
-\subsection{@mkGenForm@ and @modifyUnfoldingDetails@}
+\subsection{@mkGenForm@ and friends}
 %*                                                                     *
 %************************************************************************
 
 \begin{code}
-mkGenForm :: Bool              -- Ok to Dup code down different case branches,
-                               -- because of either a flag saying so,
-                               -- or alternatively the object is *SMALL*
-         -> BinderInfo         --
-         -> FormSummary
+mkGenForm :: FormSummary
          -> TemplateOutExpr    -- Template
          -> UnfoldingGuidance  -- Tells about the *size* of the template.
          -> UnfoldingDetails
 
-mkGenForm safe_to_dup occ_info WhnfForm template guidance
-  = GenForm (oneTextualOcc safe_to_dup occ_info) WhnfForm template guidance
+mkGenForm = GenForm
 
-mkGenForm safe_to_dup occ_info form_summary template guidance
-  | oneSafeOcc safe_to_dup occ_info    -- Non-WHNF with only safe occurrences
-  = GenForm True form_summary template guidance
+-- two shorthand variants:
+mkLitForm lit      = mk_go_for_it (Lit lit)
+mkConForm con args = mk_go_for_it (Con con args)
 
-  | otherwise                          -- Not a WHNF, many occurrences
-  = NoUnfoldingDetails
+mk_go_for_it expr = mkGenForm WhnfForm expr UnfoldAlways
 \end{code}
 
-\begin{code}
-modifyUnfoldingDetails
-       :: Bool         -- OK to dup
-       -> BinderInfo   -- New occurrence info for the thing
-       -> UnfoldingDetails
-       -> UnfoldingDetails
-
-modifyUnfoldingDetails ok_to_dup occ_info
-       (GenForm only_one form_summary template guidance)
-  | only_one  = mkGenForm ok_to_dup occ_info form_summary template guidance
-
-modifyUnfoldingDetails ok_to_dup occ_info other = other
-\end{code}
-
-
 %************************************************************************
 %*                                                                     *
 \subsection[calcUnfoldingGuidance]{Calculate ``unfolding guidance'' for an expression}
@@ -289,6 +263,8 @@ sizeExpr scc_s_OK bOMB_OUT_SIZE args expr
     size_up (SCC lbl body)
       = if scc_s_OK then size_up body else Nothing
 
+    size_up (Coerce _ _ body) = size_up body           -- Coercions cost nothing
+
     size_up (Con con args) = -- 1 + # of val args
                             sizeN (1 + numValArgs args)
     size_up (Prim op args) = sizeN op_cost -- NB: no charge for PrimOp args
@@ -340,7 +316,7 @@ 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, _, _) = getAppDataTyCon scrut_ty
+       (tycon, _, _) = trace "CoreUnfold.getAppDataTyConExpandingDicts" $ getAppDataTyConExpandingDicts scrut_ty
 
     size_up_alts _ (PrimAlts alts deflt)
       = foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts
@@ -582,6 +558,8 @@ ment_expr (SCC cc expr)
     )
     `thenUf_` ment_expr expr
 
+ment_expr (Coerce _ _ _) = panic "ment_expr:Coerce"
+
 -------------
 ment_ty ty
   = let
@@ -739,6 +717,8 @@ ppr_uf_Expr in_scopes (SCC cc body)
   = ASSERT(not (noCostCentreAttached cc))
     ASSERT(not (currentOrSubsumedCosts cc))
     ppBesides [ppStr "_scc_ { ", ppStr (showCostCentre ppr_Unfolding False{-not as string-} cc), ppStr " } ",  ppr_uf_Expr in_scopes body]
+
+ppr_uf_Expr in_scopes (Coerce _ _ _) = panic "ppr_uf_Expr:Coerce"
 \end{code}
 
 \begin{code}