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

[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/229576f00283145730afd8c800a08c6a6452399f/ghc

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

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

    Comments and small refactor


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

229576f00283145730afd8c800a08c6a6452399f
 compiler/basicTypes/Demand.lhs |   13 +++++++------
 compiler/stranal/DmdAnal.lhs   |   25 ++++++++++++++-----------
 2 files changed, 21 insertions(+), 17 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index e195191..06ac324 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -555,7 +555,7 @@ splitFVs is_thunk rhs_fvs
 %*                                                                      *
 %************************************************************************
 
-This domain differst from JointDemand in the sense that pure absence
+This domain differs from JointDemand in the sense that pure absence
 is taken away, i.e., we deal *only* with non-absent demands.
 
 Note [Strict demands]
@@ -723,17 +723,18 @@ We have lubs, but not glbs; but that is ok.
 -- Constructed Product Result                                             
 ------------------------------------------------------------------------
 
+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
                | RetProd [DmdResult]  -- Returns a constructor from a product type
                                       --   We use RetProd [] to mean RetProd [top,...,top]
                | RetSum ConTag        -- Returns a constructor from a sum type with this tag
                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 )
 
 lubCPR :: CPRResult -> CPRResult -> CPRResult
 lubCPR (RetSum t1) (RetSum t2) 
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index c3e813c..0a84550 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -519,27 +519,30 @@ dmdAnalVarApp env dmd fun args
                                    , ppr arg_tys, ppr (Converges cpr_info), ppr res_ty]) $
     ( res_ty
     , foldl App (Var fun) args')
-
-  | otherwise
-  = 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_args cxt_ds args
+    (arg_tys, 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], [CoreExpr])
-    anal_args _ [] = ([],[])
-    anal_args ds (arg : args)
+    anal_con_args :: [Demand] -> [CoreExpr] -> ([DmdType], [CoreExpr])
+    anal_con_args _ [] = ([],[])
+    anal_con_args ds (arg : args)
       | isTyCoArg arg
-      , (arg_tys, args') <- anal_args ds args
+      , (arg_tys, args') <- anal_con_args ds args
       = (arg_tys, arg:args')
-    anal_args (d:ds) (arg : args)
+    anal_con_args (d:ds) (arg : args)
       | (arg_ty,  arg')  <- dmdAnalStar env (dmdTransformThunkDmd arg d) arg
-      , (arg_tys, args') <- anal_args ds args
+      , (arg_tys, args') <- anal_con_args ds args
       = (arg_ty:arg_tys, 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}
 
 %************************************************************************