[commit: ghc] new-demand: argument unwrapping refined in worker-wrapper transform (5917db4)

[Ilya Sergey]

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

On branch  : new-demand

http://hackage.haskell.org/trac/ghc/changeset/5917db44684657949c0ad69b03acdb4c08f07376

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

commit 5917db44684657949c0ad69b03acdb4c08f07376
Author: Ilya Sergey <Ilya.Sergey at cs.kuleuven.be>
Date:   Tue Jul 31 13:35:13 2012 +0100

    argument unwrapping refined in worker-wrapper transform

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

 compiler/basicTypes/NewDemand.lhs |    6 +++---
 compiler/stranal/NewDmdAnal.lhs   |    4 ++--
 compiler/stranal/NewWwLib.lhs     |   33 ++++++++++++++++++++++++++++-----
 3 files changed, 33 insertions(+), 10 deletions(-)

diff --git a/compiler/basicTypes/NewDemand.lhs b/compiler/basicTypes/NewDemand.lhs
index a4bfa3d..42f03c1 100644
--- a/compiler/basicTypes/NewDemand.lhs
+++ b/compiler/basicTypes/NewDemand.lhs
@@ -397,7 +397,7 @@ isStrictDmd (JD {strd = x}) = x /= top
 
 isProdUsage :: Demand -> Bool
 isProdUsage (JD {absd = (UProd _)}) = True
--- isProdUsage (JD {absd = Used})      = True
+isProdUsage (JD {absd = Used})      = True
 isProdUsage _                       = False
 
 isUsedDmd :: Demand -> Bool
@@ -492,9 +492,9 @@ replicateDmd n (JD {strd=x, absd=y}) = zipWith mkJointDmd (replicateStrDmd n x)
 
 -- Check whether is a product demand
 isProdDmd :: Demand -> Bool
---isProdDmd (JD Str a) | isUsed a  = True
 isProdDmd (JD {strd = SProd _})     = True
-isProdDmd _                        = False
+isProdDmd (JD {absd = UProd _})     = True
+isProdDmd _                         = False
 
 isPolyDmd :: Demand -> Bool
 isPolyDmd (JD {strd=a, absd=b}) = isPolyStrDmd a && isPolyAbsDmd b
diff --git a/compiler/stranal/NewDmdAnal.lhs b/compiler/stranal/NewDmdAnal.lhs
index cb7d073..de9c74b 100644
--- a/compiler/stranal/NewDmdAnal.lhs
+++ b/compiler/stranal/NewDmdAnal.lhs
@@ -872,8 +872,8 @@ extendSigsWithLam env id
   | ae_virgin env        = extendAnalEnv NotTopLevel env id cprSig
        -- See Note [Optimistic CPR in the "virgin" case]
   | isStrictDmd dmd_info
-  -- , Just tycon <- tyConAppTyCon_maybe (idType id)
-  -- , isProductTyCon tycon
+  , Just tycon <- tyConAppTyCon_maybe (idType id)
+  , isProductTyCon tycon
   , isProdUsage dmd_info = extendAnalEnv NotTopLevel env id cprSig
        -- See Note [Initial CPR for strict binders]
   | otherwise            = env
diff --git a/compiler/stranal/NewWwLib.lhs b/compiler/stranal/NewWwLib.lhs
index 0298d6e..57e7247 100644
--- a/compiler/stranal/NewWwLib.lhs
+++ b/compiler/stranal/NewWwLib.lhs
@@ -341,6 +341,25 @@ mkWWstr dflags (arg : args) = do
     (args2, wrap_fn2, work_fn2) <- mkWWstr dflags args
     return (args1 ++ args2, wrap_fn1 . wrap_fn2, work_fn1 . work_fn2)
 
+\end{code}
+
+Note [Unpacking arguments with product and polymorphic demands]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The argument is unpacked in a case if it has a product type and has a
+strict and used demand put on it. I.e., arguments, with demands such
+as the following ones:
+
+<S,U(U, L)>
+<S(L,S),U>
+
+will be unpacked. Moreover, for argumentsm whose demand is <S,U> or
+<S,H>, we take an advantage of the polymorphic nature of S and U and
+replicate the enclosed demand correspondingly (see definition of
+replicateDmd).
+
+
+\begin{code}
 ----------------------
 -- mkWWstr_one wrap_arg = (work_args, wrap_fn, work_fn)
 --   *  wrap_fn assumes wrap_arg is in scope,
@@ -361,11 +380,15 @@ mkWWstr_one dflags arg
       JD {absd=Abs} | Just work_fn <- mk_absent_let dflags arg
           -> return ([], nop_fn, work_fn)
 
-	-- Unpack case
-      d | isProdDmd d && isUsedDmd d 
+	-- Unpack case, 
+        -- see note [Unpacking arguments with product and polymorphic demands]
+      d | isStrictDmd d && isUsedDmd d
+        , isProdDmd d || isPolyDmd d
 	, Just (_arg_tycon, _tycon_arg_tys, data_con, inst_con_arg_tys) 
-		<- deepSplitProductType_maybe (idType arg)
-        , cs <- splitProdDmd d
+             <- deepSplitProductType_maybe (idType arg)
+        , cs <- if isProdDmd d then splitProdDmd d
+                  --  otherwise is polymorphic demand   
+                else replicateDmd (length inst_con_arg_tys) d 
 	-> do uniqs <- getUniquesM
 	      let
 	        unpk_args      = zipWith mk_ww_local uniqs inst_con_arg_tys
@@ -379,7 +402,7 @@ mkWWstr_one dflags arg
 
 	-- `seq` demand; evaluate in wrapper in the hope
 	-- of dropping seqs in the worker
-      JD {strd=Str, absd=UHead}
+      JD {strd=Str, absd=a} | isUsed a
 	-> let
 		arg_w_unf = arg `setIdUnfolding` evaldUnfolding
 		-- Tell the worker arg that it's sure to be evaluated