[commit: ghc] new-demand: fixes in worker-wrapper transform (b9be5f9)

[Ilya Sergey]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : new-demand

http://hackage.haskell.org/trac/ghc/changeset/b9be5f924319aaf001327d4b437ca8d4475c3e0d

>---------------------------------------------------------------

commit b9be5f924319aaf001327d4b437ca8d4475c3e0d
Author: Ilya Sergey <Ilya.Sergey at cs.kuleuven.be>
Date:   Thu Jul 19 15:49:47 2012 +0100

    fixes in worker-wrapper transform

>---------------------------------------------------------------

 compiler/stranal/NewDmdAnal.lhs |    2 +-
 compiler/stranal/StrCompare.lhs |   12 ++++++------
 compiler/stranal/WorkWrap.lhs   |    9 ++++++---
 compiler/stranal/WwLib.lhs      |   10 ++++++----
 4 files changed, 19 insertions(+), 14 deletions(-)

diff --git a/compiler/stranal/NewDmdAnal.lhs b/compiler/stranal/NewDmdAnal.lhs
index 4d8c222..0d80617 100644
--- a/compiler/stranal/NewDmdAnal.lhs
+++ b/compiler/stranal/NewDmdAnal.lhs
@@ -871,7 +871,7 @@ extendSigsWithLam :: AnalEnv -> Id -> AnalEnv
 extendSigsWithLam env id
   | ae_virgin env        = extendAnalEnv NotTopLevel env id cprSig
        -- See Note [Optimistic CPR in the "virgin" case]
-  | isStrictDmd dmd_info
+  | isProdDmd dmd_info
   , Just(tc) <- tc_mb
   , isProductTyCon tc    = extendAnalEnv NotTopLevel env id cprSig
        -- See Note [Initial CPR for strict binders]
diff --git a/compiler/stranal/StrCompare.lhs b/compiler/stranal/StrCompare.lhs
index 4d49fb1..1858737 100644
--- a/compiler/stranal/StrCompare.lhs
+++ b/compiler/stranal/StrCompare.lhs
@@ -59,16 +59,16 @@ traverseBinds better acc binds
 record :: Maybe Bool -> Acc -> Id -> Acc
 record better acc id
   | old' == new                      = acc
-  | Just b <- better
-  , b && (new `pre` old')            = rdoc : acc
+  | Just True <- better
     -- new results are strictly better
-  | Just b <- better          
-  , (not b) && (old' `pre` new)      = rdoc : acc
-      -- new results are strictly worse
+  , (new `pre` old')                 = rdoc : acc
+  | Just False <- better          
+     -- new results are strictly worse
+  , (old' `pre` new)                 = rdoc : acc
   | Nothing <- better          
+      -- uncomparable results
   , not (old' `pre` new || new `pre` old')
                                      = rdoc : acc 
-      -- uncomparable results
   | otherwise                        = acc
   where
       name                 = varName id
diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs
index de81b7a..bd1641e 100644
--- a/compiler/stranal/WorkWrap.lhs
+++ b/compiler/stranal/WorkWrap.lhs
@@ -287,9 +287,10 @@ tryWW dflags 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 `setIdStrictness` 
-				     StrictSig (mkTopDmdType wrap_dmds res_info)
+	      | otherwise	  = fn_id `setIdStrictness`    sig
+                                          `nd_setIdStrictness` (toNewDmdSig sig)
 
+    sig       = StrictSig (mkTopDmdType wrap_dmds res_info)
     is_fun    = notNull wrap_dmds
     is_thunk  = not is_fun && not (exprIsHNF rhs)
 
@@ -341,7 +342,8 @@ splitFun dflags fn_id fn_info wrap_dmds res_info rhs
 				-- not w/wd). However, the RuleMatchInfo is not transferred since
                                 -- it does not make sense for workers to be constructorlike.
 
-			`setIdStrictness` StrictSig (mkTopDmdType work_demands work_res_info)
+			`setIdStrictness` sig
+                        `nd_setIdStrictness` (toNewDmdSig sig)
 				-- Even though we may not be at top level, 
 				-- it's ok to give it an empty DmdEnv
 
@@ -349,6 +351,7 @@ splitFun dflags fn_id fn_info wrap_dmds res_info rhs
                                 -- Set the arity so that the Core Lint check that the 
                                 -- arity is consistent with the demand type goes through
 
+        sig       = StrictSig (mkTopDmdType work_demands work_res_info)
 	wrap_rhs  = wrap_fn work_id
 	wrap_prag = InlinePragma { inl_inline = Inline
                                  , inl_sat    = Nothing
diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs
index 0ed650b..62e8b3a 100644
--- a/compiler/stranal/WwLib.lhs
+++ b/compiler/stranal/WwLib.lhs
@@ -17,13 +17,13 @@ module WwLib ( mkWwBodies, mkWWstr, mkWorkerArgs ) where
 
 import CoreSyn
 import CoreUtils	( exprType )
-import Id		( Id, idType, mkSysLocal, idDemandInfo, setIdDemandInfo,
+import Id		( Id, idType, mkSysLocal, idDemandInfo, setIdDemandInfo, nd_setIdDemandInfo,
 			  isOneShotLambda, setOneShotLambda, setIdUnfolding,
                           setIdInfo
 			)
 import IdInfo		( vanillaIdInfo )
 import DataCon
-import Demand		( Demand(..), DmdResult(..), Demands(..) ) 
+import Demand		( Demand(..), DmdResult(..), Demands(..), toNewDmd ) 
 import MkCore		( mkRuntimeErrorApp, aBSENT_ERROR_ID )
 import MkId		( realWorldPrimId, voidArgId, 
                           mkUnpackCase, mkProductBox )
@@ -298,7 +298,8 @@ applyToVars vars fn = mkVarApps fn vars
 
 mk_wrap_arg :: Unique -> Type -> Demand -> Bool -> Id
 mk_wrap_arg uniq ty dmd one_shot 
-  = set_one_shot one_shot (setIdDemandInfo (mkSysLocal (fsLit "w") uniq ty) dmd)
+  = set_one_shot one_shot ((mkSysLocal (fsLit "w") uniq ty) `setIdDemandInfo`    dmd
+                                                            `nd_setIdDemandInfo` (toNewDmd dmd))
   where
     set_one_shot True  id = setOneShotLambda id
     set_one_shot False id = id
@@ -405,7 +406,8 @@ mkWWstr_one dflags arg
 	-- If the wrapper argument is a one-shot lambda, then
 	-- so should (all) the corresponding worker arguments be
 	-- This bites when we do w/w on a case join point
-    set_worker_arg_info worker_arg demand = set_one_shot (setIdDemandInfo worker_arg demand)
+    set_worker_arg_info worker_arg demand = set_one_shot (worker_arg `setIdDemandInfo` demand
+                                                                     `nd_setIdDemandInfo` (toNewDmd demand))
 
     set_one_shot | isOneShotLambda arg = setOneShotLambda
 		 | otherwise	       = \x -> x