X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Fmain%2FTidyPgm.lhs;h=d8bacd853ede619dbfb1a72dad90a826036f6315;hb=63e3a41126771e71c44705480c2bde7043a41df3;hp=8f3a52086dcf4845a54024d656bc914a565c8b9e;hpb=2662dbc5b2c30fc11ccb99e7f9b2dba794d680ba;p=ghc-hetmet.git

diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 8f3a520..d8bacd8 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -310,6 +310,8 @@ tidyProgram hsc_env  (ModGuts { mg_module = mod, mg_exports = exports,
                                    binds implicit_binds imp_rules
 
         ; let { ext_rules = findExternalRules omit_prags binds imp_rules unfold_env }
+	        -- Glom together imp_rules and rules currently attached to binders
+		-- Then pick just the ones we need to expose
 		-- See Note [Which rules to expose]
 
 	; let { (tidy_env, tidy_binds)
@@ -684,7 +686,7 @@ addExternal expose_all id = (new_needed_ids, show_unfold)
                        (varSetElems spec_ids) -- XXX non-det ordering
 
     idinfo	   = idInfo id
-    dont_inline	   = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo))
+    never_active   = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo))
     loop_breaker   = isNonRuleLoopBreaker (occInfo idinfo)
     bottoming_fn   = isBottomingSig (strictnessInfo idinfo `orElse` topSig)
     spec_ids	   = specInfoFreeVars (specInfo idinfo)
@@ -697,16 +699,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_guidance = guide } 
-			| expose_all ||	     -- expose_all says to expose all 
-			  	     	     -- unfoldings willy-nilly
-                          not (bottoming_fn	 -- No need to inline bottom functions
-			    || dont_inline	 -- Or ones that say not to
-			    || loop_breaker	 -- Or that are loop breakers
-			    || neverUnfoldGuidance guide)
+		      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
+		      _                   -> Nothing
+
+    show_unfolding unf_source unf_guidance
+       =  expose_all 	     -- 'expose_all' says to expose all 
+			     -- unfoldings willy-nilly
+
+       || isInlineRuleSource unf_source	     -- Always expose things whose 
+       	  		     		     -- source is an inline rule
+
+       || not (bottoming_fn	 -- No need to inline bottom functions
+	   || never_active	 -- Or ones that say not to
+	   || loop_breaker	 -- Or that are loop breakers
+	   || neverUnfoldGuidance unf_guidance)
 
 -- We want a deterministic free-variable list.  exprFreeVars gives us
 -- a VarSet, which is in a non-deterministic order when converted to a
@@ -981,21 +990,24 @@ tidyTopPair show_unfold rhs_tidy_env caf_info name' (bndr, rhs)
     -- the RHS is bottom, it should jolly well be exposed
     _bottom_exposed = case exprBotStrictness_maybe rhs of
                         Nothing         -> True
-                        Just (arity, _) -> appIsBottom str arity
+                        Just (arity, _) -> appIsBottom str_sig arity
         where
-          str = strictnessInfo idinfo `orElse` topSig
-
-    bndr1   = mkGlobalId details name' ty' idinfo'
-    details = idDetails bndr	-- Preserve the IdDetails
-    ty'	    = tidyTopType (idType bndr)
-    rhs1    = tidyExpr rhs_tidy_env rhs
-    idinfo  = idInfo bndr
-    idinfo' = tidyTopIdInfo (isExternalName name')
+
+
+    bndr1    = mkGlobalId details name' ty' idinfo'
+    details  = idDetails bndr	-- Preserve the IdDetails
+    ty'	     = tidyTopType (idType bndr)
+    rhs1     = tidyExpr rhs_tidy_env rhs
+    idinfo   = idInfo bndr
+    unf_info = unfoldingInfo idinfo
+    str_sig  = strictnessInfo idinfo `orElse` topSig
+    is_bot   = isBottomingSig str_sig
+    idinfo'  = tidyTopIdInfo (isExternalName name')
 			    idinfo unfold_info
 			    arity caf_info 
                             (occInfo idinfo)
 
-    unfold_info | show_unfold = tidyUnfolding rhs_tidy_env rhs1 (unfoldingInfo idinfo)
+    unfold_info | show_unfold = tidyUnfolding rhs_tidy_env rhs1 is_bot unf_info
 		| otherwise   = noUnfolding
     -- NB: do *not* expose the worker if show_unfold is off,
     --     because that means this thing is a loop breaker or
@@ -1063,20 +1075,21 @@ tidyTopIdInfo is_external idinfo unfold_info arity caf_info occ_info
 
 
 ------------ Unfolding  --------------
-tidyUnfolding :: TidyEnv -> CoreExpr -> Unfolding -> Unfolding
-tidyUnfolding tidy_env _ unf@(CoreUnfolding { uf_tmpl = rhs 
-	      	       	 		    , uf_guidance = guide@(InlineRule {}) })
-  = unf { uf_tmpl     = tidyExpr tidy_env rhs, 	   -- Preserves OccInfo
-	  uf_guidance = guide { ir_info = tidyInl tidy_env (ir_info guide) } }
-tidyUnfolding tidy_env _ (DFunUnfolding con ids)
+tidyUnfolding :: TidyEnv -> CoreExpr -> Bool -> Unfolding -> Unfolding
+tidyUnfolding tidy_env _ _ (DFunUnfolding con ids)
   = DFunUnfolding con (map (tidyExpr tidy_env) ids)
-tidyUnfolding _ tidy_rhs (CoreUnfolding {})
-  = mkTopUnfolding tidy_rhs
-tidyUnfolding _ _ unf = unf
-
-tidyInl :: TidyEnv -> InlineRuleInfo -> InlineRuleInfo
-tidyInl tidy_env (InlWrapper w) = InlWrapper (tidyVarOcc tidy_env w)
-tidyInl _        inl_info       = inl_info
+tidyUnfolding tidy_env tidy_rhs is_bottoming
+              unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })
+  | isInlineRuleSource src
+  = unf { uf_tmpl = tidyExpr tidy_env unf_rhs, 	   -- Preserves OccInfo
+	  uf_src  = tidyInl tidy_env src }
+  | otherwise
+  = mkTopUnfolding is_bottoming tidy_rhs
+tidyUnfolding _ _ _ unf = unf
+
+tidyInl :: TidyEnv -> UnfoldingSource -> UnfoldingSource
+tidyInl tidy_env (InlineWrapper w) = InlineWrapper (tidyVarOcc tidy_env w)
+tidyInl _        inl_info          = inl_info
 \end{code}
 
 %************************************************************************