X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FTidyPgm.lhs;h=a03098322ba18b6928dbfd98f39df054c5bf893c;hp=98ab1d9314937aeef42eedc54f8a8f92e495fe15;hb=9e6ca39b5e90b7a4acc755e3e95cc3ef60940070;hpb=d4f4391a030e683572eee01291cc8bc6203dbf5d

diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 98ab1d9..a030983 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -20,7 +20,7 @@ import CoreMonad
 import CoreUtils
 import Rules
 import CoreArity	( exprArity, exprBotStrictness_maybe )
-import Class		( classSelIds )
+import Class		( classAllSelIds )
 import VarEnv
 import VarSet
 import Var
@@ -37,6 +37,7 @@ import TcType
 import DataCon
 import TyCon
 import Module
+import Packages( isDllName )
 import HscTypes
 import Maybes
 import UniqSupply
@@ -300,7 +301,7 @@ tidyProgram hsc_env  (ModGuts { mg_module = mod, mg_exports = exports,
   = do	{ let { dflags     = hsc_dflags hsc_env
 	      ; omit_prags = dopt Opt_OmitInterfacePragmas dflags
 	      ; expose_all = dopt Opt_ExposeAllUnfoldings  dflags
-	      ; th	   = dopt Opt_TemplateHaskell      dflags
+	      ; th	   = xopt Opt_TemplateHaskell      dflags
               }
 	; showPass dflags CoreTidy
 
@@ -454,7 +455,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
@@ -560,7 +561,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
@@ -709,16 +710,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
@@ -1087,11 +1095,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
@@ -1132,12 +1140,12 @@ CAF list to keep track of non-collectable CAFs.
 \begin{code}
 hasCafRefs  :: PackageId -> VarEnv Var -> Arity -> CoreExpr -> CafInfo
 hasCafRefs this_pkg p arity expr 
-  | is_caf || mentions_cafs 
-                            = MayHaveCafRefs
+  | is_caf || mentions_cafs = MayHaveCafRefs
   | otherwise 		    = NoCafRefs
  where
   mentions_cafs = isFastTrue (cafRefs p expr)
-  is_caf = not (arity > 0 || rhsIsStatic this_pkg expr)
+  is_dynamic_name = isDllName this_pkg 
+  is_caf = not (arity > 0 || rhsIsStatic is_dynamic_name expr)
 
   -- NB. we pass in the arity of the expression, which is expected
   -- to be calculated by exprArity.  This is because exprArity