[project @ 1997-03-14 07:52:06 by simonpj]

[ghc-hetmet.git] / ghc / compiler / simplCore / SimplVar.lhs

diff --git a/ghc/compiler/simplCore/SimplVar.lhs b/ghc/compiler/simplCore/SimplVar.lhs
index 4e4ef55..99f3e4c 100644 (file)
--- a/ghc/compiler/simplCore/SimplVar.lhs
+++ b/ghc/compiler/simplCore/SimplVar.lhs
@@ -13,19 +13,19 @@ module SimplVar (
 IMP_Ubiq(){-uitous-}
 IMPORT_DELOOPER(SmplLoop)              ( simplExpr )
 
-import CgCompInfo      ( uNFOLDING_USE_THRESHOLD,
+import Constants       ( uNFOLDING_USE_THRESHOLD,
                          uNFOLDING_CON_DISCOUNT_WEIGHT
                        )
 import CmdLineOpts     ( switchIsOn, SimplifierSwitch(..) )
 import CoreSyn
-import CoreUnfold      ( Unfolding(..), UnfoldingGuidance(..), SimpleUnfolding(..),
+import CoreUnfold      ( Unfolding(..), UfExpr, RdrName, UnfoldingGuidance(..), SimpleUnfolding(..),
                          FormSummary,
-                         smallEnoughToInline )
-import BinderInfo      ( BinderInfo, noBinderInfo, okToInline )
+                         okToInline, smallEnoughToInline )
+import BinderInfo      ( BinderInfo, noBinderInfo )
 
 import CostCentre      ( CostCentre, noCostCentreAttached )
 import Id              ( idType, getIdInfo, getIdUnfolding, getIdSpecialisation,
-                         GenId{-instance Outputable-}
+                         idMustBeINLINEd, GenId{-instance Outputable-}
                        )
 import SpecEnv         ( SpecEnv, lookupSpecEnv )
 import IdInfo          ( DeforestInfo(..) )
@@ -33,11 +33,10 @@ import Literal              ( isNoRepLit )
 import MagicUFs                ( applyMagicUnfoldingFun, MagicUnfoldingFun )
 import PprStyle                ( PprStyle(..) )
 import PprType         ( GenType{-instance Outputable-} )
-import Pretty          ( ppBesides, ppStr )
+--import Pretty                ( ppBesides, ppStr )
 import SimplEnv
 import SimplMonad
 import TyCon           ( tyConFamilySize )
-import Type            ( isPrimType, getAppDataTyConExpandingDicts, maybeAppDataTyConExpandingDicts )
 import Util            ( pprTrace, assertPanic, panic )
 import Maybes          ( maybeToBool )
 \end{code}
@@ -59,9 +58,25 @@ completeVar env var args
 
   | not do_deforest &&
     maybeToBool maybe_unfolding_info &&
-    (always_inline || (ok_to_inline && not essential_unfoldings_only)) && 
+    (not essential_unfoldings_only || idMustBeINLINEd var) && 
+    ok_to_inline &&
+       -- If "essential_unfolds_only" is true we do no inlinings at all,
+       -- EXCEPT for things that absolutely have to be done
+       -- (see comments with idMustBeINLINEd)
+       --
+       -- Need to be careful: the RHS of INLINE functions is protected against inlining
+       -- by essential_unfoldings_only being set true; we must not inline workers back into
+       -- wrappers, even thouth the former have an unfold-always guidance.
     costCentreOk (getEnclosingCC env) (getEnclosingCC unfold_env)
   = tick UnfoldingDone `thenSmpl_`
+#ifdef DEBUG
+--    simplCount               `thenSmpl` \ n ->
+--    (if n > 3000 then
+--     pprTrace "Ticks > 3000 and unfolding" (ppr PprDebug var)
+--    else
+--     id
+--    )
+#endif
     simplExpr unfold_env unf_template args
 
   | maybeToBool maybe_specialisation
@@ -86,10 +101,17 @@ completeVar env var args
        ---------- Unfolding stuff
     maybe_unfolding_info 
        = case (lookupOutIdEnv env var, unfolding_from_id) of
+
             (Just (_, occ_info, OutUnfolding enc_cc unf), _)
                -> Just (occ_info, setEnclosingCC env enc_cc, unf)      
+
             (Just (_, occ_info, InUnfolding env_unf unf), _)
-               -> Just (occ_info, combineSimplEnv env env_unf, unf)    
+               -> Just (occ_info, env_unf, unf)        
+--                     This combineSimplEnv is WRONG.  InUnfoldings are used for
+--                     recursive decls, and we're relying on using the old unfold enf
+--                     to avoid getting outselves in a loop!
+--             -> Just (occ_info, combineSimplEnv env env_unf, unf)    
+
             (_, CoreUnfolding unf)
                -> Just (noBinderInfo, env, unf)
 
@@ -111,19 +133,16 @@ completeVar env var args
     ok_to_inline             = okToInline form 
                                           occ_info
                                           small_enough
-    small_enough = smallEnoughToInline con_disc unf_thresh arg_evals guidance
+    small_enough = smallEnoughToInline arg_evals guidance
     arg_evals = [is_evald arg | arg <- args, isValArg arg]
   
     is_evald (VarArg v) = isEvaluated (lookupRhsInfo env v)
     is_evald (LitArg l) = True
 
-    con_disc   = getSimplIntSwitch sw_chkr SimplUnfoldingConDiscount
-    unf_thresh = getSimplIntSwitch sw_chkr SimplUnfoldingUseThreshold
-
 #if OMIT_DEFORESTER
     do_deforest = False
 #else
-    do_deforest = case (getInfo (getIdInfo var)) of { DoDeforest -> True; _ -> False }
+    do_deforest = case (getDeforestInfo (getIdInfo var)) of { DoDeforest -> True; _ -> False }
 #endif