[commit: ghc] wip/12368: DmdAnal: Add a final, safe iteration (a267da1)

[git at git.haskell.org]

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

On branch  : wip/12368
Link       : http://ghc.haskell.org/trac/ghc/changeset/a267da1c7fbaa4dac86a7cb5a7483fb6e2f5c446/ghc

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

commit a267da1c7fbaa4dac86a7cb5a7483fb6e2f5c446
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Thu Jul 7 11:23:48 2016 +0200

    DmdAnal: Add a final, safe iteration
    
    this fixes #12368.


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

a267da1c7fbaa4dac86a7cb5a7483fb6e2f5c446
 compiler/basicTypes/Demand.hs            | 15 +++++++++++++--
 compiler/stranal/DmdAnal.hs              | 21 ++++++++++++---------
 testsuite/tests/stranal/should_run/all.T |  2 +-
 3 files changed, 26 insertions(+), 12 deletions(-)

diff --git a/compiler/basicTypes/Demand.hs b/compiler/basicTypes/Demand.hs
index 8dc7f3b..1849acc 100644
--- a/compiler/basicTypes/Demand.hs
+++ b/compiler/basicTypes/Demand.hs
@@ -35,7 +35,8 @@ module Demand (
         vanillaCprProdRes, cprSumRes,
         appIsBottom, isBottomingSig, pprIfaceStrictSig,
         trimCPRInfo, returnsCPR_maybe,
-        StrictSig(..), mkStrictSig, mkClosedStrictSig, nopSig, botSig, cprProdSig,
+        StrictSig(..), mkStrictSig, mkClosedStrictSig,
+        nopSig, botSig, toTopSig, cprProdSig,
         isTopSig, hasDemandEnvSig, splitStrictSig, increaseStrictSigArity,
 
         seqDemand, seqDemandList, seqDmdType, seqStrictSig,
@@ -1261,11 +1262,18 @@ emptyDmdEnv = emptyVarEnv
 -- nopDmdType is the demand of doing nothing
 -- (lazy, absent, no CPR information, no termination information).
 -- Note that it is ''not'' the top of the lattice (which would be "may use everything"),
--- so it is (no longer) called topDmd
+-- so it is (no longer) called topDmdType
 nopDmdType, botDmdType :: DmdType
 nopDmdType = DmdType emptyDmdEnv [] topRes
 botDmdType = DmdType emptyDmdEnv [] botRes
 
+-- This converts a demand type to the least useful (most conservative) type
+-- that mentions the same free variables. It takes the role of a top element,
+-- which we do not have, since a top element would have to mention all variables
+-- in the DmdEnv
+toTopDmdType :: DmdType -> DmdType
+toTopDmdType (DmdType env _ _) = DmdType (mapVarEnv (const topDmd) env) [] topRes
+
 cprProdDmdType :: Arity -> DmdType
 cprProdDmdType arity
   = DmdType emptyDmdEnv [] (vanillaCprProdRes arity)
@@ -1690,6 +1698,9 @@ nopSig, botSig :: StrictSig
 nopSig = StrictSig nopDmdType
 botSig = StrictSig botDmdType
 
+toTopSig :: StrictSig -> StrictSig
+toTopSig (StrictSig ty) = StrictSig (toTopDmdType ty)
+
 cprProdSig :: Arity -> StrictSig
 cprProdSig arity = StrictSig (cprProdDmdType arity)
 
diff --git a/compiler/stranal/DmdAnal.hs b/compiler/stranal/DmdAnal.hs
index 53144ff..9928e17 100644
--- a/compiler/stranal/DmdAnal.hs
+++ b/compiler/stranal/DmdAnal.hs
@@ -475,26 +475,22 @@ dmdFix top_lvl env orig_pairs
         loop' n env pairs
 
     loop' n env pairs
-      | found_fixpoint
+      | found_fixpoint || n > 10
       = (env', lazy_fv, pairs')
                 -- Note: return 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
+      | n == 10
       = -- pprTrace "dmdFix loop" (ppr n <+> (vcat
         --                 [ text "Sigs:" <+> ppr [ (id,lookupVarEnv (sigEnv env) id,
         --                                              lookupVarEnv (sigEnv env') id)
         --                                          | (id,_) <- pairs],
         --                   text "env:" <+> ppr env,
         --                   text "binds:" <+> pprCoreBinding (Rec pairs)]))
-        (env, 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
+        loop (n+1) (addPessimisticSigs env bndrs) pairs'
+        -- We are not going to find a fix point any time soon. So do one final round
+        -- of analysis with safe assumptions about the strictness signatures
 
       | otherwise
       = loop (n+1) (nonVirgin env') pairs'
@@ -1009,6 +1005,13 @@ addInitialSigs top_lvl env@(AE { ae_sigs = sigs, ae_virgin = virgin }) ids
     init_sig | virgin    = \_ -> botSig
              | otherwise = idStrictness
 
+addPessimisticSigs :: AnalEnv -> [Id] -> AnalEnv
+addPessimisticSigs env@(AE { ae_sigs = sigs }) ids
+  = env { ae_sigs = extendVarEnvList sigs new_sigs }
+  where
+    new_sigs = [ (id, (toTopSig sig, top_lvl))
+               | id <- ids, let Just (sig, top_lvl) = lookupSigEnv env id ]
+
 nonVirgin :: AnalEnv -> AnalEnv
 nonVirgin env = env { ae_virgin = False }
 
diff --git a/testsuite/tests/stranal/should_run/all.T b/testsuite/tests/stranal/should_run/all.T
index 6846c82..5b976f1 100644
--- a/testsuite/tests/stranal/should_run/all.T
+++ b/testsuite/tests/stranal/should_run/all.T
@@ -12,4 +12,4 @@ test('T10148', normal, compile_and_run, [''])
 test('T10218', normal, compile_and_run, [''])
 test('T11076', normal, multimod_compile_and_run, ['T11076.hs', 'T11076_prim.cmm'])
 test('T11555a', normal, compile_and_run, [''])
-test('T12368', [ exit_code(1), expect_broken(12368) ], compile_and_run, [''])
+test('T12368', exit_code(1), compile_and_run, [''])