[commit: ghc] new-demand-to-merge: Make sure that we analyse at least once, even with absent or bottom demands. (1aef13c)

Simon Peyton Jones simonpj at microsoft.com
Wed Jan 16 14:38:44 CET 2013


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

On branch  : new-demand-to-merge

http://hackage.haskell.org/trac/ghc/changeset/1aef13c1e8856e6ce075d5264a4809be4e7f08a1

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

commit 1aef13c1e8856e6ce075d5264a4809be4e7f08a1
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Wed Jan 16 13:38:27 2013 +0000

    Make sure that we analyse at least once, even with absent or bottom demands.
    
    See Note [Always analyse in virgin pass]

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

 compiler/stranal/DmdAnal.lhs |   96 ++++++++++++++++++++++++++++--------------
 1 files changed, 64 insertions(+), 32 deletions(-)

diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index e2927a8..d23457a 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -85,32 +85,64 @@ dmdAnalTopBind dflags sigs (Rec pairs)
 %*									*
 %************************************************************************
 
+Note [Ensure demand is strict]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's important not to analyse e with a lazy demand because
+a) When we encounter   case s of (a,b) -> 
+	we demand s with U(d1d2)... but if the overall demand is lazy
+	that is wrong, and we'd need to reduce the demand on s,
+	which is inconvenient
+b) More important, consider
+	f (let x = R in x+x), where f is lazy
+   We still want to mark x as demanded, because it will be when we
+   enter the let.  If we analyse f's arg with a Lazy demand, we'll
+   just mark x as Lazy
+c) The application rule wouldn't be right either
+   Evaluating (f x) in a L demand does *not* cause
+   evaluation of f in a C(L) demand!
+
+Note [Always analyse in virgin pass]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Tricky point: make sure that we analyse in the 'virgin' pass. Consider
+   rec { f acc x True  = f (...rec { g y = ...g... }...)
+         f acc x False = acc }
+In the virgin pass for 'f' we'll give 'f' a very strict (bottom) type.
+That might mean that we analyse the sub-expression containing the 
+E = "...rec g..." stuff in a bottom demand.  Suppose we *didn't analyse*
+E, but just retuned botType.  
+
+Then in the *next* (non-virgin) iteration for 'f', we might analyse E
+in a weaker demand, and that will trigger doing a fixpoint iteration
+for g.  But *because it's not the virgin pass* we won't start g's
+iteration at bottom.  Disaster.  (This happened in $sfibToList' of 
+nofib/spectral/fibheaps.)
+
+So in the virgin pass we make sure that we do analyse the expression
+at least once, to initialise its signatures.
+
 \begin{code}
-dmdAnal :: DynFlags -> AnalEnv -> Demand -> CoreExpr -> (DmdType, CoreExpr)
+evalDmdAnal :: DynFlags -> AnalEnv -> CoreExpr -> (DmdType, CoreExpr)
+-- See Note [Ensure demand is strict]
+evalDmdAnal dflags env e
+  | (res_ty, e') <- dmdAnal dflags env evalDmd e
+  = (deferType res_ty, e')
+
+simpleDmdAnal :: DynFlags -> AnalEnv -> DmdType -> CoreExpr -> (DmdType, CoreExpr)
+simpleDmdAnal dflags env res_ty e
+  | ae_virgin env -- See Note [Always analyse in virgin pass]
+  , (_discarded_res_ty, e') <- dmdAnal dflags env evalDmd e
+  = (res_ty, e')
+  | otherwise
+  = (res_ty, e)
 
+dmdAnal :: DynFlags -> AnalEnv -> Demand -> CoreExpr -> (DmdType, CoreExpr)
 dmdAnal dflags env dmd e 
-  | isBot dmd  = (botDmdType, e)
-  | isAbs dmd  = (topDmdType, e)
-  | not (isStrictDmd dmd)
-  = let (res_ty, e') = dmdAnal dflags env evalDmd e
-    in  -- compute as with a strict demand, return with a lazy demand
-    (deferType res_ty, e')
-	-- It's important not to analyse e with a lazy demand because
-	-- a) When we encounter   case s of (a,b) -> 
-	--	we demand s with U(d1d2)... but if the overall demand is lazy
-	--	that is wrong, and we'd need to reduce the demand on s,
-	--	which is inconvenient
-	-- b) More important, consider
-	--	f (let x = R in x+x), where f is lazy
-	--    We still want to mark x as demanded, because it will be when we
-	--    enter the let.  If we analyse f's arg with a Lazy demand, we'll
-	--    just mark x as Lazy
-	-- c) The application rule wouldn't be right either
-	--    Evaluating (f x) in a L demand does *not* cause
-	--    evaluation of f in a C(L) demand!
-
-dmdAnal _ _ _ (Lit lit) = (topDmdType, Lit lit)
-dmdAnal _ _ _ (Type ty) = (topDmdType, Type ty)	-- Doesn't happen, in fact
+  | isBot dmd  		  = simpleDmdAnal dflags env botDmdType e
+  | isAbs dmd  		  = simpleDmdAnal dflags env topDmdType e
+  | not (isStrictDmd dmd) = evalDmdAnal   dflags env            e
+
+dmdAnal _ _ _ (Lit lit)     = (topDmdType, Lit lit)
+dmdAnal _ _ _ (Type ty)     = (topDmdType, Type ty)	-- Doesn't happen, in fact
 dmdAnal _ _ _ (Coercion co) = (topDmdType, Coercion co)
 
 dmdAnal _ env dmd (Var var)
@@ -154,14 +186,14 @@ dmdAnal dflags env dmd (App fun arg)	-- Non-type arguments
 	(arg_ty, arg') 	  = dmdAnal dflags env arg_dmd arg
 	(arg_dmd, res_ty) = splitDmdTy fun_ty
     in
-    pprTrace "dmdAnal:app" (vcat
-         [ text "dmd =" <+> ppr dmd
-         , text "expr =" <+> ppr (App fun arg)
-         , text "fun dmd_ty =" <+> ppr fun_ty
-         , text "arg dmd =" <+> ppr arg_dmd
-         , text "arg dmd_ty =" <+> ppr arg_ty
-         , text "res dmd_ty =" <+> ppr res_ty
-         , text "overall res dmd_ty =" <+> ppr (res_ty `both` arg_ty) ])
+--    pprTrace "dmdAnal:app" (vcat
+--         [ text "dmd =" <+> ppr dmd
+--         , text "expr =" <+> ppr (App fun arg)
+--         , text "fun dmd_ty =" <+> ppr fun_ty
+--         , text "arg dmd =" <+> ppr arg_dmd
+--         , text "arg dmd_ty =" <+> ppr arg_ty
+--         , text "res dmd_ty =" <+> ppr res_ty
+--         , text "overall res dmd_ty =" <+> ppr (res_ty `both` arg_ty) ])
     (res_ty `both` arg_ty, App fun' arg')
 
 dmdAnal dflags env dmd (Lam var body)
@@ -401,7 +433,7 @@ dmdFix dflags top_lvl env orig_pairs
 	 -> [(Id,CoreExpr)] 		
 	 -> (SigEnv, DmdEnv, [(Id,CoreExpr)])
     loop n env pairs
-      = pprTrace "dmd loop" (ppr n <+> ppr bndrs $$ ppr env) $
+      = -- pprTrace "dmd loop" (ppr n <+> ppr bndrs $$ ppr env) $
         loop' n env pairs
 
     loop' n env pairs





More information about the ghc-commits mailing list