X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplUtils.lhs;h=7a5b96b3524aa2033157281ec7a8cc7aeb79da59;hb=1cf8d965aeb55701efa47dace761c4d673c06987;hp=972c0e5810c3dea9d2507c8f3e8c89885d0a8284;hpb=367e603d0136436e783ff9ed610809bf87376262;p=ghc-hetmet.git

diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 972c0e5..7a5b96b 100644
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -10,7 +10,7 @@ module SimplUtils (
 
 	-- Inlining,
 	preInlineUnconditionally, postInlineUnconditionally, 
-	activeInline, activeRule, 
+	activeUnfolding, activeUnfInRule, activeRule, 
         simplEnvForGHCi, simplEnvForRules, updModeForInlineRules,
 
 	-- The continuation type
@@ -40,7 +40,7 @@ import CoreUnfold
 import Name
 import Id
 import Var	( isCoVar )
-import NewDemand
+import Demand
 import SimplMonad
 import Type	hiding( substTy )
 import Coercion ( coercionKind )
@@ -334,7 +334,7 @@ mkArgInfo fun rules n_val_args call_cont
     vanilla_discounts, arg_discounts :: [Int]
     vanilla_discounts = repeat 0
     arg_discounts = case idUnfolding fun of
-			CoreUnfolding {uf_guidance = UnfoldIfGoodArgs {ug_args = discounts}}
+			CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_args = discounts}}
 			      -> discounts ++ vanilla_discounts
 			_     -> vanilla_discounts
 
@@ -342,7 +342,7 @@ mkArgInfo fun rules n_val_args call_cont
     vanilla_stricts  = repeat False
 
     arg_stricts
-      = case splitStrictSig (idNewStrictness fun) of
+      = case splitStrictSig (idStrictness fun) of
 	  (demands, result_info)
 		| not (demands `lengthExceeds` n_val_args)
 		-> 	-- Enough args, use the strictness given.
@@ -739,12 +739,12 @@ postInlineUnconditionally
     -> Unfolding
     -> Bool
 postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding
-  | not active		   = False
-  | isLoopBreaker occ_info = False	-- If it's a loop-breaker of any kind, don't inline
+  | not active		        = False
+  | isLoopBreaker occ_info      = False	-- If it's a loop-breaker of any kind, don't inline
 					-- because it might be referred to "earlier"
-  | isExportedId bndr      = False
-  | isInlineRule unfolding = False	-- Note [InlineRule and postInlineUnconditionally]
-  | exprIsTrivial rhs 	   = True
+  | isExportedId bndr           = False
+  | isStableUnfolding unfolding = False	-- Note [InlineRule and postInlineUnconditionally]
+  | exprIsTrivial rhs 	        = True
   | otherwise
   = case occ_info of
 	-- The point of examining occ_info here is that for *non-values* 
@@ -757,7 +757,8 @@ postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding
 	--	case v of
 	--	   True  -> case x of ...
 	--	   False -> case x of ...
-	-- I'm not sure how important this is in practice
+	-- This is very important in practice; e.g. wheel-seive1 doubles 
+	-- in allocation if you miss this out
       OneOcc in_lam _one_br int_cxt	-- OneOcc => no code-duplication issue
 	->     smallEnoughToInline unfolding	-- Small enough to dup
 			-- ToDo: consider discount on smallEnoughToInline if int_cxt is true
@@ -810,27 +811,56 @@ postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding
 		   SimplPhase n _ -> isActive n act
     act = idInlineActivation bndr
 
-activeInline :: SimplEnv -> OutId -> Bool
-activeInline env id
-  | isNonRuleLoopBreaker (idOccInfo id)	  -- Things with an INLINE pragma may have 
-    			 	          -- an unfolding *and* be a loop breaker
-  = False				  -- (maybe the knot is not yet untied)
-  | otherwise
+activeUnfolding :: SimplEnv -> IdUnfoldingFun
+activeUnfolding env
+  = case getMode env of
+      SimplGently { sm_inline = False } -> active_unfolding_minimal
+      SimplGently { sm_inline = True  } -> active_unfolding_gentle
+      SimplPhase n _                    -> active_unfolding n
+
+activeUnfInRule :: SimplEnv -> IdUnfoldingFun
+-- When matching in RULE, we want to "look through" an unfolding
+-- if *rules* are on, even if *inlinings* are not.  A notable example
+-- is DFuns, which really we want to match in rules like (op dfun)
+-- in gentle mode.
+activeUnfInRule env
   = case getMode env of
-      SimplGently { sm_inline = inlining_on } 
-         -> inlining_on && isEarlyActive act
-	-- See Note [Gentle mode]
-
-	-- NB: we used to have a second exception, for data con wrappers.
-	-- On the grounds that we use gentle mode for rule LHSs, and 
-	-- they match better when data con wrappers are inlined.
-	-- But that only really applies to the trivial wrappers (like (:)),
-	-- and they are now constructed as Compulsory unfoldings (in MkId)
-	-- so they'll happen anyway.
-
-      SimplPhase n _ -> isActive n act
+      SimplGently { sm_rules = False } -> active_unfolding_minimal
+      SimplGently { sm_rules = True  } -> active_unfolding_gentle
+      SimplPhase n _                   -> active_unfolding n
+
+active_unfolding_minimal :: IdUnfoldingFun
+-- Compuslory unfoldings only
+-- Ignore SimplGently, because we want to inline regardless;
+-- the Id has no top-level binding at all
+--
+-- NB: we used to have a second exception, for data con wrappers.
+-- On the grounds that we use gentle mode for rule LHSs, and 
+-- they match better when data con wrappers are inlined.
+-- But that only really applies to the trivial wrappers (like (:)),
+-- and they are now constructed as Compulsory unfoldings (in MkId)
+-- so they'll happen anyway.
+active_unfolding_minimal id
+  | isCompulsoryUnfolding unf = unf
+  | otherwise                 = NoUnfolding
   where
-    act = idInlineActivation id
+    unf = realIdUnfolding id	-- Never a loop breaker
+
+active_unfolding_gentle :: IdUnfoldingFun
+-- Anything that is early-active
+-- See Note [Gentle mode]
+active_unfolding_gentle id
+  | isEarlyActive (idInlineActivation id) = idUnfolding id
+  | otherwise                             = NoUnfolding
+      -- idUnfolding checks for loop-breakers
+      -- Things with an INLINE pragma may have 
+      -- an unfolding *and* be a loop breaker  
+      -- (maybe the knot is not yet untied)
+
+active_unfolding :: CompilerPhase -> IdUnfoldingFun
+active_unfolding n id
+  | isActive n (idInlineActivation id) = idUnfolding id
+  | otherwise                          = NoUnfolding
 
 activeRule :: DynFlags -> SimplEnv -> Maybe (Activation -> Bool)
 -- Nothing => No rules at all