[commit: ghc] wip/nested-cpr: Merge branch 'wip/nested-cpr' of git://git.haskell.org/ghc into wip/nested-cpr (e71635f)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/nested-cpr
Link       : http://ghc.haskell.org/trac/ghc/changeset/e71635f0a533ecffb48dfd36a771dede678a55aa/ghc

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

commit e71635f0a533ecffb48dfd36a771dede678a55aa
Merge: e765e10 052d78b
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Wed Dec 4 18:03:47 2013 +0000

    Merge branch 'wip/nested-cpr' of git://git.haskell.org/ghc into wip/nested-cpr
    
    Conflicts:
    	compiler/stranal/DmdAnal.lhs



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

e71635f0a533ecffb48dfd36a771dede678a55aa
 compiler/basicTypes/Demand.lhs |    8 ++++----
 compiler/stranal/DmdAnal.lhs   |   33 +++++++++++++++------------------
 2 files changed, 19 insertions(+), 22 deletions(-)

diff --cc compiler/stranal/DmdAnal.lhs
index a43e963,a029fff..342a760
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@@ -522,36 -521,39 +522,33 @@@ dmdAnalVarApp env dmd fun arg
          res_ty = foldl bothDmdType (DmdType emptyDmdEnv [] cpr_info) arg_tys
    = -- pprTrace "dmdAnalVarApp" (vcat [ ppr con, ppr args, ppr n_val_args, ppr cxt_ds
      --                                , ppr arg_tys, ppr cpr_info, ppr res_ty]) $
-     ( res_ty 
+     ( res_ty
      , foldl App (Var fun) args')
- 
-   | otherwise
-   = --pprTrace "dmdAnalVarApp" (vcat [ ppr fun, ppr args, ppr n_val_args
-     --                               , ppr dmd
-     --                               , ppr (mkCallDmdN n_val_args dmd)
-     --                               , ppr $ dmdTransform env fun (mkCallDmdN n_val_args dmd)
-     --                               , ppr $ completeApp env (dmdTransform env fun (mkCallDmdN n_val_args dmd), Var fun) args
-     --                               ])
-     completeApp env (dmdTransform env fun (mkCallDmdN n_val_args dmd), Var fun) args
    where
      n_val_args = valArgCount args
 -    cxt_ds = splitProdCleanDmd n_val_args dmd
 -    (arg_tys, args') = anal_con_args cxt_ds args
 +    cxt_ds = splitProdCleanDmd  n_val_args dmd
-     (arg_tys, arg_rets, args') = anal_args cxt_ds args
-         -- The constructor itself is lazy
++    (arg_tys, arg_rets, args') = anal_con_args cxt_ds args
+         -- The constructor itself is lazy, so we don't need to look at the
+         -- strictness signature on the data constructor. Instead just
+         -- propagate demand from the context into the constructor arguments
          -- See Note [Data-con worker strictness] in MkId
 -
 -    anal_con_args :: [Demand] -> [CoreExpr] -> ([DmdType], [CoreExpr])
 -    anal_con_args _ [] = ([],[])
 +  
-     anal_args :: [Demand] -> [CoreExpr] -> ([DmdType], [DmdResult], [CoreExpr])
-     anal_args _ [] = ([],[],[])
-     anal_args ds (arg : args)
++    anal_con_args :: [Demand] -> [CoreExpr] -> ([DmdType], [DmdResult], [CoreExpr])
++    anal_con_args _ [] = ([],[],[])
+     anal_con_args ds (arg : args)
 -      | isTypeArg arg
 -      , (arg_tys, args') <- anal_con_args ds args
 -      = (arg_tys, arg:args')
 +      | isTypeArg arg 
-       , (arg_tys, arg_rets, args') <- anal_args ds args
++      , (arg_tys, arg_rets, args') <- anal_con_args ds args
 +      = (arg_tys, arg_rets, arg:args')
-     anal_args (d:ds) (arg : args)
+     anal_con_args (d:ds) (arg : args)
 -      | (arg_ty,  arg')  <- dmdAnalArg env d arg
 -      , (arg_tys, args') <- anal_con_args ds args
 +      | (arg_ty, arg_ret, arg')  <- dmdAnalStar env (dmdTransformThunkDmd arg d) arg
-       , (arg_tys, arg_rets, args') <- anal_args ds args
++      , (arg_tys, arg_rets, args') <- anal_con_args ds args
        = --pprTrace "dmdAnalVarApp arg" (vcat [ ppr d, ppr arg, ppr arg_ty, ppr arg' ])
 -        (arg_ty:arg_tys, arg':args')
 +        (arg_ty:arg_tys, arg_ret:arg_rets, arg':args')
-     anal_args ds args = pprPanic "anal_args" (ppr args $$ ppr ds)
+     anal_con_args ds args = pprPanic "anal_con_args" (ppr args $$ ppr ds)
+ 
 -
 -dmdAnalVarApp env dmd fun args
 -  | otherwise  -- Not a saturated constructor
 -  = --pprTrace "dmdAnalVarApp" (vcat [ ppr fun, ppr args, ppr n_val_args
 -    --                               , ppr dmd
 -    --                               , ppr $ dmdTransform env fun (mkCallDmdN n_val_args dmd)
 -    --                               , ppr $ completeApp env (dmdTransform env fun (mkCallDmdN n_val_args dmd), Var fun) args
 -    --                               ])
++dmdAnalVarApp env dmd fun args -- Not a saturated constructor
++  = --pprTrace "dmdAnalVarApp" (vcat [ ppr fun, ppr args, ppr dmd ])
+     completeApp env (dmdTransform env fun (mkCallDmdN (valArgCount args) dmd), Var fun) args
  \end{code}
  
  %************************************************************************