Implement INLINABLE pragma

[ghc-hetmet.git] / compiler / main / TidyPgm.lhs

diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 4c01bc5..7d04563 100644 (file)
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -18,8 +18,9 @@ import CoreFVs
 import CoreTidy
 import CoreMonad
 import CoreUtils
+import Rules
 import CoreArity       ( exprArity, exprBotStrictness_maybe )
-import Class           ( classSelIds )
+import Class           ( classAllSelIds )
 import VarEnv
 import VarSet
 import Var
@@ -38,11 +39,11 @@ import TyCon
 import Module
 import HscTypes
 import Maybes
-import ErrUtils
 import UniqSupply
 import Outputable
 import FastBool hiding ( fastOr )
 import Util
+import FastString
 
 import Data.List       ( sortBy )
 import Data.IORef      ( IORef, readIORef, writeIORef )
@@ -133,7 +134,7 @@ mkBootModDetails :: HscEnv -> [AvailInfo] -> NameEnv TyThing
                  -> [Instance] -> [FamInstEnv.FamInst] -> IO ModDetails
 mkBootModDetails hsc_env exports type_env insts fam_insts
   = do { let dflags = hsc_dflags hsc_env 
-       ; showPass dflags "Tidy [hoot] type env"
+       ; showPass dflags CoreTidy
 
        ; let { insts'     = tidyInstances globaliseAndTidyId insts
              ; dfun_ids   = map instanceDFunId insts'
@@ -301,7 +302,7 @@ tidyProgram hsc_env  (ModGuts { mg_module = mod, mg_exports = exports,
              ; expose_all = dopt Opt_ExposeAllUnfoldings  dflags
              ; th         = dopt Opt_TemplateHaskell      dflags
               }
-       ; showPass dflags "Tidy Core"
+       ; showPass dflags CoreTidy
 
        ; let { implicit_binds = getImplicitBinds type_env }
 
@@ -342,7 +343,15 @@ tidyProgram hsc_env  (ModGuts { mg_module = mod, mg_exports = exports,
              ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)
              }
 
-       ; endPass dflags "Tidy Core" Opt_D_dump_simpl all_tidy_binds tidy_rules
+       ; endPass dflags CoreTidy all_tidy_binds tidy_rules
+
+         -- If the endPass didn't print the rules, but ddump-rules is on, print now
+       ; dumpIfSet (dopt Opt_D_dump_rules dflags 
+                     && (not (dopt Opt_D_dump_simpl dflags))) 
+                   CoreTidy
+                    (ptext (sLit "rules"))
+                    (pprRulesForUser tidy_rules)
+
         ; let dir_imp_mods = moduleEnvKeys dir_imps
 
        ; return (CgGuts { cg_module   = mod, 
@@ -445,7 +454,7 @@ mustExposeTyCon exports tc
   | isEnumerationTyCon tc      -- For an enumeration, exposing the constructors
   = True                       -- won't lead to the need for further exposure
                                -- (This includes data types with no constructors.)
-  | isOpenTyCon tc             -- Open type family
+  | isFamilyTyCon tc           -- Open type family
   = True
 
   | otherwise                  -- Newtype, datatype
@@ -551,7 +560,7 @@ getImplicitBinds type_env
   = map get_defn (concatMap implicit_ids (typeEnvElts type_env))
   where
     implicit_ids (ATyCon tc)  = mapCatMaybes dataConWrapId_maybe (tyConDataCons tc)
-    implicit_ids (AClass cls) = classSelIds cls
+    implicit_ids (AClass cls) = classAllSelIds cls
     implicit_ids _            = []
     
     get_defn :: Id -> CoreBind
@@ -700,16 +709,23 @@ addExternal expose_all id = (new_needed_ids, show_unfold)
     mb_unfold_ids :: Maybe (IdSet, [Id])       -- Nothing => don't unfold
     mb_unfold_ids = case unfoldingInfo idinfo of
                      CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src, uf_guidance = guide } 
-                       | show_unfolding src guide
-                       -> Just (exprFvsInOrder unf_rhs)
-                     DFunUnfolding _ ops -> Just (exprsFvsInOrder ops)
-                     _                   -> Nothing
+                                           | show_unfolding src guide
+                                           -> Just (unf_ext_ids src unf_rhs)
+                     DFunUnfolding _ _ ops -> Just (exprsFvsInOrder ops)
+                     _                     -> Nothing
+                  where
+                    unf_ext_ids (InlineWrapper v) _ = (unitVarSet v, [v])
+                    unf_ext_ids _           unf_rhs = exprFvsInOrder unf_rhs
+                   -- For a wrapper, externalise the wrapper id rather than the
+                   -- fvs of the rhs.  The two usually come down to the same thing
+                   -- but I've seen cases where we had a wrapper id $w but a
+                   -- rhs where $w had been inlined; see Trac #3922
 
     show_unfolding unf_source unf_guidance
        =  expose_all        -- 'expose_all' says to expose all 
                             -- unfoldings willy-nilly
 
-       || isInlineRuleSource unf_source             -- Always expose things whose 
+       || isStableSource unf_source         -- Always expose things whose 
                                                     -- source is an inline rule
 
        || not (bottoming_fn     -- No need to inline bottom functions
@@ -1078,11 +1094,11 @@ tidyTopIdInfo rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info
 
 ------------ Unfolding  --------------
 tidyUnfolding :: TidyEnv -> CoreExpr -> Maybe StrictSig -> Unfolding -> Unfolding
-tidyUnfolding tidy_env _ _ (DFunUnfolding con ids)
-  = DFunUnfolding con (map (tidyExpr tidy_env) ids)
+tidyUnfolding tidy_env _ _ (DFunUnfolding ar con ids)
+  = DFunUnfolding ar con (map (tidyExpr tidy_env) ids)
 tidyUnfolding tidy_env tidy_rhs strict_sig
               unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })
-  | isInlineRuleSource src
+  | isStableSource src
   = unf { uf_tmpl = tidyExpr tidy_env unf_rhs,            -- Preserves OccInfo
          uf_src  = tidyInl tidy_env src }
   | otherwise