X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fstranal%2FWorkWrap.lhs;h=d587894ac3c64acb4a8c91d8ef1fd739e73e691f;hb=a24ede81b6ddb6e5dde72d947437baf319968ff9;hp=159dd8f95129c5e80e6ebc7aa0bdb6bed73610a6;hpb=566075c3369dbaefd7fec9b0fde2eb11f521185a;p=ghc-hetmet.git

diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs
index 159dd8f..d587894 100644
--- a/ghc/compiler/stranal/WorkWrap.lhs
+++ b/ghc/compiler/stranal/WorkWrap.lhs
@@ -12,22 +12,26 @@ import CoreSyn
 import CoreUnfold	( certainlyWillInline )
 import CoreLint		( showPass, endPass )
 import CoreUtils	( exprType, exprIsValue )
-import Id		( Id, idType, isOneShotLambda,
+import Id		( Id, idType, isOneShotLambda, 
 			  setIdNewStrictness, mkWorkerId,
 			  setIdWorkerInfo, setInlinePragma,
 			  idInfo )
+import MkId		( lazyIdKey, lazyIdUnfolding )
 import Type		( Type )
 import IdInfo		( WorkerInfo(..), arityInfo,
 			  newDemandInfo, newStrictnessInfo, unfoldingInfo, inlinePragInfo
 			)
-import NewDemand        ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..), Keepity(..),
-			  mkTopDmdType, isBotRes, returnsCPR, topSig
+import NewDemand        ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..), 
+			  Demands(..), mkTopDmdType, isBotRes, returnsCPR, topSig, isAbsent
 			)
 import UniqSupply	( UniqSupply, initUs_, returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
+import Unique		( hasKey )
 import BasicTypes	( RecFlag(..), isNonRec, Activation(..) )
+import VarEnv		( isEmptyVarEnv )
 import Maybes		( orElse )
 import CmdLineOpts
 import WwLib
+import Util		( lengthIs, notNull )
 import Outputable
 \end{code}
 
@@ -125,9 +129,16 @@ matching by looking for strict arguments of the correct type.
 \begin{code}
 wwExpr :: CoreExpr -> UniqSM CoreExpr
 
-wwExpr e@(Type _)   = returnUs e
-wwExpr e@(Var _)    = returnUs e
-wwExpr e@(Lit _)    = returnUs e
+wwExpr e@(Type _)   	      = returnUs e
+wwExpr e@(Lit _)    	      = returnUs e
+wwExpr e@(Note InlineMe expr) = returnUs e
+	-- Don't w/w inside InlineMe's
+
+wwExpr e@(Var v)
+  | v `hasKey` lazyIdKey = returnUs lazyIdUnfolding
+  | otherwise            = returnUs e
+	-- Inline 'lazy' after strictness analysis
+	-- (but not inside InlineMe's)
 
 wwExpr (Lam binder expr)
   = wwExpr expr			`thenUs` \ new_expr ->
@@ -200,33 +211,45 @@ tryWW is_rec fn_id rhs
 	--	fw = \ab -> (__inline (\x -> E)) (a,b)
 	-- and the original __inline now vanishes, so E is no longer
 	-- inside its __inline wrapper.  Death!  Disaster!
-  = returnUs [ (fn_id, rhs) ]
+  = returnUs [ (new_fn_id, rhs) ]
 
-  | is_thunk && worthSplittingThunk fn_dmd res_info
-  = ASSERT( isNonRec is_rec )	-- The thunk must be non-recursive
-    splitThunk fn_id rhs
+  | is_thunk && worthSplittingThunk maybe_fn_dmd res_info
+  = ASSERT2( isNonRec is_rec, ppr new_fn_id )	-- The thunk must be non-recursive
+    splitThunk new_fn_id rhs
 
   | is_fun && worthSplittingFun wrap_dmds res_info
-  = splitFun fn_id fn_info wrap_dmds res_info inline_prag rhs
+  = splitFun new_fn_id fn_info wrap_dmds res_info inline_prag rhs
 
   | otherwise
-  = returnUs [ (fn_id, rhs) ]
+  = returnUs [ (new_fn_id, rhs) ]
 
   where
-    fn_info   	= idInfo fn_id
-    fn_dmd    	= newDemandInfo fn_info
-    unfolding 	= unfoldingInfo fn_info
-    inline_prag = inlinePragInfo fn_info
+    fn_info   	 = idInfo fn_id
+    maybe_fn_dmd = newDemandInfo fn_info
+    unfolding 	 = unfoldingInfo fn_info
+    inline_prag  = inlinePragInfo fn_info
+    maybe_sig    = newStrictnessInfo 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
-
-    StrictSig (DmdType _ wrap_dmds res_info) = strict_sig
-
-    is_fun    = not (null wrap_dmds)
+    StrictSig (DmdType env wrap_dmds res_info) = strict_sig
+
+	-- new_fn_id has the DmdEnv zapped.  
+	--	(a) it is never used again
+	--	(b) it wastes space
+	--	(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` 
+				     StrictSig (mkTopDmdType wrap_dmds res_info)
+
+    is_fun    = notNull wrap_dmds
     is_thunk  = not is_fun && not (exprIsValue rhs)
 
 ---------------------
 splitFun fn_id fn_info wrap_dmds res_info inline_prag rhs
-  = WARN( arity /= length wrap_dmds, ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) )
+  = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) )
 	-- The arity should match the signature
     mkWwBodies fun_ty wrap_dmds res_info one_shots 	`thenUs` \ (work_demands, wrap_fn, work_fn) ->
     getUniqueUs						`thenUs` \ work_uniq ->
@@ -342,23 +365,19 @@ worthSplittingFun ds res
 	-- [We don't do reboxing now, but in general it's better to pass 
 	--  an unboxed thing to f, and have it reboxed in the error cases....]
   where
-    worth_it Abs	= True	-- Absent arg
-    worth_it (Seq _ ds) = True	-- Arg to evaluate
-    worth_it other	= False
+    worth_it Abs	      = True	-- Absent arg
+    worth_it (Eval (Prod ds)) = True	-- Product arg to evaluate
+    worth_it other	      = False
 
-worthSplittingThunk :: Demand		-- Demand on the thunk
+worthSplittingThunk :: Maybe Demand	-- Demand on the thunk
 		    -> DmdResult	-- CPR info for the thunk
 		    -> Bool
-worthSplittingThunk dmd res
-  = worth_it dmd || returnsCPR res
+worthSplittingThunk maybe_dmd res
+  = worth_it maybe_dmd || returnsCPR res
   where
 	-- Split if the thing is unpacked
-    worth_it (Seq Defer ds) = False
-    worth_it (Seq _     ds) = any not_abs ds
-    worth_it other	    = False
-
-    not_abs Abs   = False
-    not_abs other = True
+    worth_it (Just (Eval (Prod ds))) = not (all isAbsent ds)
+    worth_it other	   	     = False
 \end{code}