[commit: ghc] wip/nested-cpr: Comments and small refactor (43c2a05)

[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/43c2a059b28b1f307421d2b8f357b0ab28655aed/ghc

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

commit 43c2a059b28b1f307421d2b8f357b0ab28655aed
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Wed Dec 4 16:00:24 2013 +0000

    Comments and small refactor


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

43c2a059b28b1f307421d2b8f357b0ab28655aed
 compiler/basicTypes/Demand.lhs |    8 ++++----
 compiler/stranal/DmdAnal.lhs   |   31 ++++++++++++++-----------------
 2 files changed, 18 insertions(+), 21 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index bb2e215..b0c7f01 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -725,16 +725,16 @@ We have lubs, but not glbs; but that is ok.
 -- Constructed Product Result                                             
 ------------------------------------------------------------------------
 
-data CPRResult = NoCPR                      -- Top of the lattice
-               | RetCon ConTag [DmdResult]  -- Returns a constructor from a data type
-               deriving( Eq, Show )
-
 data DmdResult = Diverges              -- Definitely diverges
                | Converges CPRResult   -- Definitely converges 
                | Dunno CPRResult       -- Might diverge or converge, but in the latter case the
                                        -- result shape is described by CPRResult
                deriving( Eq, Show ) 
 
+data CPRResult = NoCPR                      -- Top of the lattice
+               | RetCon ConTag [DmdResult]  -- Returns a constructor from a data type
+               deriving( Eq, Show )
+
 lubCPR :: CPRResult -> CPRResult -> CPRResult
 lubCPR (RetCon ct1 ds1) (RetCon ct2 ds2) 
   | ct1 == ct2
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index dc346b3..633cf32 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -524,34 +524,31 @@ dmdAnalVarApp env dmd fun args
     --                                , ppr arg_tys, ppr cpr_info, ppr 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, arg_rets, args') = anal_args cxt_ds args
+    (arg_tys, arg_rets, args') = anal_con_args cxt_ds args
         -- The constructor itself is lazy
         -- See Note [Data-con worker strictness] in MkId
   
-    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, 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_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_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
+  = --pprTrace "dmdAnalVarApp" (vcat [ ppr fun, ppr args
+    --                               , ppr $ completeApp env (dmdTransform env fun (mkCallDmdN n_val_args dmd), Var fun) args
+    --                               ])
+    completeApp env (dmdTransform env fun (mkCallDmdN (valArgCount args) dmd), Var fun) args
 \end{code}
 
 %************************************************************************