[project @ 2002-11-14 10:25:26 by simonmar]

[ghc-hetmet.git] / ghc / compiler / stranal / DmdAnal.lhs

diff --git a/ghc/compiler/stranal/DmdAnal.lhs b/ghc/compiler/stranal/DmdAnal.lhs
index 5320305..063a288 100644 (file)
--- a/ghc/compiler/stranal/DmdAnal.lhs
+++ b/ghc/compiler/stranal/DmdAnal.lhs
@@ -23,12 +23,12 @@ import TyCon                ( isProductTyCon, isRecursiveTyCon )
 import Id              ( Id, idType, idInlinePragma,
                          isDataConId, isGlobalId, idArity,
 #ifdef OLD_STRICTNESS
-                         idDemandInfo,  idStrictness, idCprInfo,
+                         idDemandInfo,  idStrictness, idCprInfo, idName,
 #endif
                          idNewStrictness, idNewStrictness_maybe,
                          setIdNewStrictness, idNewDemandInfo,
                          idNewDemandInfo_maybe,
-                         setIdNewDemandInfo, idName 
+                         setIdNewDemandInfo
                        )
 #ifdef OLD_STRICTNESS
 import IdInfo          ( newStrictnessFromOld, newDemand )
@@ -270,18 +270,18 @@ dmdAnal sigs dmd (Let (NonRec id rhs) body)
        (body_ty1, id2)               = annotateBndr body_ty id1
        body_ty2                      = addLazyFVs body_ty1 lazy_fv
     in
-#ifdef DEBUG
-       -- If the actual demand is better than the vanilla
-       -- demand, we might do better to re-analyse with the
-       -- stronger demand.
-    (let vanilla_dmd = vanillaCall (idArity id)
-        actual_dmd  = idNewDemandInfo id2
-     in
-     if actual_dmd `betterDemand` vanilla_dmd && actual_dmd /= vanilla_dmd then
-       pprTrace "dmdLet: better demand" (ppr id <+> vcat [text "vanilla" <+> ppr vanilla_dmd,
-                                                          text "actual" <+> ppr actual_dmd])
-     else \x -> x)
-#endif
+       -- If the actual demand is better than the vanilla call
+       -- demand, you might think that we might do better to re-analyse 
+       -- the RHS with the stronger demand.
+       -- But (a) That seldom happens, because it means that *every* path in 
+       --         the body of the let has to use that stronger demand
+       -- (b) It often happens temporarily in when fixpointing, because
+       --     the recursive function at first seems to place a massive demand.
+       --     But we don't want to go to extra work when the function will
+       --     probably iterate to something less demanding.  
+       -- In practice, all the times the actual demand on id2 is more than
+       -- the vanilla call demand seem to be due to (b).  So we don't
+       -- bother to re-analyse the RHS.
     (body_ty2, Let (NonRec id2 rhs') body')    
 
 dmdAnal sigs dmd (Let (Rec pairs) body) 
@@ -334,19 +334,27 @@ dmdFix top_lvl sigs orig_pairs
         -> [(Id,CoreExpr)]             
         -> (SigEnv, DmdEnv, [(Id,CoreExpr)])
     loop n sigs pairs
-      | all (same_sig sigs sigs') bndrs 
+      | found_fixpoint
       = (sigs', lazy_fv, pairs')
                -- Note: use pairs', not pairs.   pairs' is the result of 
                -- processing the RHSs with sigs (= sigs'), whereas pairs 
                -- is the result of processing the RHSs with the *previous* 
                -- iteration of sigs.
-      | n >= 10       = pprTrace "dmdFix loop" (ppr n <+> (vcat 
+
+      | n >= 10  = pprTrace "dmdFix loop" (ppr n <+> (vcat 
                                [ text "Sigs:" <+> ppr [(id,lookup sigs id, lookup sigs' id) | (id,_) <- pairs],
                                  text "env:" <+> ppr (ufmToList sigs),
                                  text "binds:" <+> pprCoreBinding (Rec pairs)]))
-                             (emptySigEnv, emptyDmdEnv, orig_pairs)    -- Safe output
+                             (emptySigEnv, lazy_fv, orig_pairs)        -- Safe output
+                       -- The lazy_fv part is really important!  orig_pairs has no strictness
+                       -- info, including nothing about free vars.  But if we have
+                       --      letrec f = ....y..... in ...f...
+                       -- where 'y' is free in f, we must record that y is mentioned, 
+                       -- otherwise y will get recorded as absent altogether
+
       | otherwise    = loop (n+1) sigs' pairs'
       where
+       found_fixpoint = all (same_sig sigs sigs') bndrs 
                -- Use the new signature to do the next pair
                -- The occurrence analyser has arranged them in a good order
                -- so this can significantly reduce the number of iterations needed
@@ -845,7 +853,7 @@ argDemand (Defer d) = lazyDmd
 argDemand (Eval ds) = Eval (mapDmds argDemand ds)
 argDemand (Box Bot) = evalDmd
 argDemand (Box d)   = box (argDemand d)
-argDemand Bot      = Abs       -- Don't pass args that are consumed by bottom/err
+argDemand Bot      = Abs       -- Don't pass args that are consumed (only) by bottom
 argDemand d        = d
 \end{code}