X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fstranal%2FWorkWrap.lhs;h=4e7a494bc990c869e8b2eecff994ac672677c627;hp=772a8623f3259761a040a51c1fe2b39d04ddf2d3;hb=2662dbc5b2c30fc11ccb99e7f9b2dba794d680ba;hpb=9060e51e4773bdff1829d17e3f7c42edb910d805

diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs
index 772a862..4e7a494 100644
--- a/compiler/stranal/WorkWrap.lhs
+++ b/compiler/stranal/WorkWrap.lhs
@@ -7,22 +7,20 @@
 module WorkWrap ( wwTopBinds, mkWrapper ) where
 
 import CoreSyn
-import CoreUnfold	( certainlyWillInline )
-import CoreUtils	( exprType, exprIsHNF, mkInlineMe )
+import CoreUnfold	( certainlyWillInline, mkInlineRule, mkWwInlineRule )
+import CoreUtils	( exprType, exprIsHNF )
 import CoreArity	( exprArity )
 import Var
-import Id		( Id, idType, isOneShotLambda, idUnfolding,
-			  setIdNewStrictness, mkWorkerId,
-			  setIdWorkerInfo, setInlineActivation,
-			  setIdArity, idInfo )
-import MkId		( lazyIdKey, lazyIdUnfolding )
+import Id		( idType, isOneShotLambda, idUnfolding,
+			  setIdStrictness, mkWorkerId,
+			  setInlineActivation, setIdUnfolding,
+			  setIdArity )
 import Type		( Type )
 import IdInfo
-import NewDemand        ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..), 
+import Demand           ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..), 
 			  Demands(..), mkTopDmdType, isBotRes, returnsCPR, topSig, isAbsent
 			)
 import UniqSupply
-import Unique		( hasKey )
 import BasicTypes	( RecFlag(..), isNonRec, isNeverActive,
                           Activation, inlinePragmaActivation )
 import VarEnv		( isEmptyVarEnv )
@@ -107,16 +105,9 @@ matching by looking for strict arguments of the correct type.
 \begin{code}
 wwExpr :: CoreExpr -> UniqSM CoreExpr
 
-wwExpr e@(Type _)          = return e
-wwExpr e@(Lit _)           = return e
-wwExpr e@(Note InlineMe _) = return e
-	-- Don't w/w inside InlineMe's
-
-wwExpr e@(Var v)
-  | v `hasKey` lazyIdKey = return lazyIdUnfolding
-  | otherwise            = return e
-	-- HACK alert: Inline 'lazy' after strictness analysis
-	-- (but not inside InlineMe's)
+wwExpr e@(Type {}) = return e
+wwExpr e@(Lit  {}) = return e
+wwExpr e@(Var  {}) = return e
 
 wwExpr (Lam binder expr)
   = Lam binder <$> wwExpr expr
@@ -165,7 +156,10 @@ The only reason this is monadised is for the unique supply.
 Note [Don't w/w inline things (a)]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 It's very important to refrain from w/w-ing an INLINE function
-If we do so by mistake we transform
+because the wrapepr will then overwrite the InlineRule unfolding.
+
+It was wrong with the old InlineMe Note too: if we do so by mistake 
+we transform
 	f = __inline (\x -> E)
 into
 	f = __inline (\x -> case x of (a,b) -> fw E)
@@ -231,12 +225,12 @@ tryWW is_rec fn_id rhs
 
   where
     fn_info   	 = idInfo fn_id
-    maybe_fn_dmd = newDemandInfo fn_info
+    maybe_fn_dmd = demandInfo fn_info
     inline_act   = inlinePragmaActivation (inlinePragInfo fn_info)
 
 	-- In practice it always will have a strictness 
 	-- signature, even if it's a uninformative one
-    strict_sig  = newStrictnessInfo fn_info `orElse` topSig
+    strict_sig  = strictnessInfo fn_info `orElse` topSig
     StrictSig (DmdType env wrap_dmds res_info) = strict_sig
 
 	-- new_fn_id has the DmdEnv zapped.  
@@ -245,21 +239,29 @@ tryWW is_rec fn_id rhs
 	--	(c) it becomes incorrect as things are cloned, because
 	--	    we don't push the substitution into it
     new_fn_id | isEmptyVarEnv env = fn_id
-	      | otherwise	  = fn_id `setIdNewStrictness` 
+	      | otherwise	  = fn_id `setIdStrictness` 
 				     StrictSig (mkTopDmdType wrap_dmds res_info)
 
     is_fun    = notNull wrap_dmds
     is_thunk  = not is_fun && not (exprIsHNF rhs)
 
 ---------------------
-checkSize :: Id -> CoreExpr -> UniqSM [(Id,CoreExpr)] -> UniqSM [(Id,CoreExpr)]
+checkSize :: Id -> CoreExpr
+	  -> UniqSM [(Id,CoreExpr)] -> UniqSM [(Id,CoreExpr)]
  -- See Note [Don't w/w inline things (a) and (b)]
 checkSize fn_id rhs thing_inside
-  | certainlyWillInline unfolding = return [ (fn_id, mkInlineMe rhs) ]
+  | isStableUnfolding unfolding	   -- For DFuns and INLINE things, leave their
+  = return [ (fn_id, rhs) ]	   -- unfolding unchanged; but still attach 
+    	     	     	  	   -- strictness info to the Id	
+
+  | certainlyWillInline unfolding
+  = return [ (fn_id `setIdUnfolding` inline_rule, rhs) ]
 		-- Note [Don't w/w inline things (b)]
+
   | otherwise = thing_inside
   where
     unfolding = idUnfolding fn_id
+    inline_rule = mkInlineRule InlUnSat rhs (unfoldingArity unfolding)
 
 ---------------------
 splitFun :: Id -> IdInfo -> [Demand] -> DmdResult -> Activation -> Expr Var
@@ -281,7 +283,7 @@ splitFun fn_id fn_info wrap_dmds res_info inline_act rhs
 				-- can't think of a compelling reason. (In ptic, INLINE things are 
 				-- not w/wd). However, the RuleMatchInfo is not transferred since
                                 -- it does not make sense for workers to be constructorlike.
-			`setIdNewStrictness` StrictSig (mkTopDmdType work_demands work_res_info)
+			`setIdStrictness` StrictSig (mkTopDmdType work_demands work_res_info)
 				-- Even though we may not be at top level, 
 				-- it's ok to give it an empty DmdEnv
                         `setIdArity` (exprArity work_rhs)
@@ -289,7 +291,7 @@ splitFun fn_id fn_info wrap_dmds res_info inline_act rhs
                                 -- arity is consistent with the demand type goes through
 
 	wrap_rhs = wrap_fn work_id
-	wrap_id  = fn_id `setIdWorkerInfo` HasWorker work_id arity
+	wrap_id  = fn_id `setIdUnfolding` mkWwInlineRule work_id wrap_rhs arity
 
     ; return ([(work_id, work_rhs), (wrap_id, wrap_rhs)]) })
 	-- Worker first, because wrapper mentions it