X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Fstranal%2FWorkWrap.lhs;h=f407691db92d2f27485bc6ca2b874b74d30a5019;hb=e195ea859d2d4227c478a3b5e1e9ac20b086b0c7;hp=b12d05b4b1b3ac789c68085f08ff0c06c342390f;hpb=d254a44b8392ff0a4327f1916ef921887ce78769;p=ghc-hetmet.git

diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs
index b12d05b..f407691 100644
--- a/ghc/compiler/stranal/WorkWrap.lhs
+++ b/ghc/compiler/stranal/WorkWrap.lhs
@@ -12,10 +12,11 @@ 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
@@ -24,6 +25,7 @@ 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 )
@@ -127,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 ->
@@ -149,10 +158,10 @@ wwExpr (Let bind expr)
     wwExpr expr			`thenUs` \ new_expr ->
     returnUs (mkLets intermediate_bind new_expr)
 
-wwExpr (Case expr binder alts)
+wwExpr (Case expr binder ty alts)
   = wwExpr expr				`thenUs` \ new_expr ->
     mapUs ww_alt alts			`thenUs` \ new_alts ->
-    returnUs (Case new_expr binder new_alts)
+    returnUs (Case new_expr binder ty new_alts)
   where
     ww_alt (con, binders, rhs)
       =	wwExpr rhs			`thenUs` \ new_rhs ->
@@ -202,38 +211,37 @@ 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 maybe_fn_dmd res_info
-  = ASSERT( isNonRec is_rec )	-- The thunk must be non-recursive
-    splitThunk fn_id' rhs
+  = 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
     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 env wrap_dmds res_info) = strict_sig
 
-	-- fn_id' has the DmdEnv zapped.  
+	-- 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
-    fn_id' | isEmptyVarEnv env = fn_id
-	   | otherwise	       = fn_id `setIdNewStrictness` 
-				   StrictSig (mkTopDmdType wrap_dmds res_info)
+    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)