DmdAnal: Add a final, safe iteration

this fixes #12368.

It also refactors dmdFix a bit, removes some redundancies (such as
passing around an strictness signature right next to an id, when that id
is guaranteed to have been annotated with that strictness signature).

Note that when fixed-point iteration does not terminate, we
conservatively delete their strictness signatures (set them to nopSig).
But this loses the information on how its strict free variables are
used!

Lazily used variables already escape via lazy_fvs. We ensure that in the
case of an aborted fixed-point iteration, also the strict variables are
put there (with a conservative demand of topDmd).

Differential Revision: https://phabricator.haskell.org/D2392

5 files changed, 128 insertions, 81 deletions

diff --git a/compiler/basicTypes/Demand.hs b/compiler/basicTypes/Demand.hs
index 8dc7f3b895..2ada6b37b9 100644
--- a/compiler/basicTypes/Demand.hs
+++ b/compiler/basicTypes/Demand.hs
@@ -36,7 +36,9 @@ module Demand (
         appIsBottom, isBottomingSig, pprIfaceStrictSig,
         trimCPRInfo, returnsCPR_maybe,
         StrictSig(..), mkStrictSig, mkClosedStrictSig, nopSig, botSig, cprProdSig,
-        isTopSig, hasDemandEnvSig, splitStrictSig, increaseStrictSigArity,
+        isTopSig, hasDemandEnvSig,
+        splitStrictSig, strictSigDmdEnv,
+        increaseStrictSigArity,
 
         seqDemand, seqDemandList, seqDmdType, seqStrictSig,
 
@@ -1682,6 +1684,9 @@ isTopSig (StrictSig ty) = isTopDmdType ty
 hasDemandEnvSig :: StrictSig -> Bool
 hasDemandEnvSig (StrictSig (DmdType env _ _)) = not (isEmptyVarEnv env)
 
+strictSigDmdEnv :: StrictSig -> DmdEnv
+strictSigDmdEnv (StrictSig (DmdType env _ _)) = env
+
 isBottomingSig :: StrictSig -> Bool
 -- True if the signature diverges or throws an exception
 isBottomingSig (StrictSig (DmdType _ _ res)) = isBotRes res
diff --git a/compiler/basicTypes/VarEnv.hs b/compiler/basicTypes/VarEnv.hs
index 6e22417de8..146a2fce5f 100644
--- a/compiler/basicTypes/VarEnv.hs
+++ b/compiler/basicTypes/VarEnv.hs
@@ -12,7 +12,8 @@ module VarEnv (
         elemVarEnv,
         extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnv_Directly,
         extendVarEnvList,
-        plusVarEnv, plusVarEnv_C, plusVarEnv_CD, alterVarEnv,
+        plusVarEnv, plusVarEnv_C, plusVarEnv_CD, plusVarEnvList,
+        alterVarEnv,
         delVarEnvList, delVarEnv, delVarEnv_Directly,
         minusVarEnv, intersectsVarEnv,
         lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv,
@@ -435,6 +436,7 @@ extendVarEnv_C    :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a
 extendVarEnv_Acc  :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b
 extendVarEnv_Directly :: VarEnv a -> Unique -> a -> VarEnv a
 plusVarEnv        :: VarEnv a -> VarEnv a -> VarEnv a
+plusVarEnvList    :: [VarEnv a] -> VarEnv a
 extendVarEnvList  :: VarEnv a -> [(Var, a)] -> VarEnv a
 
 lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a
@@ -474,6 +476,7 @@ delVarEnv        = delFromUFM
 minusVarEnv      = minusUFM
 intersectsVarEnv e1 e2 = not (isEmptyVarEnv (e1 `intersectUFM` e2))
 plusVarEnv       = plusUFM
+plusVarEnvList   = plusUFMList
 lookupVarEnv     = lookupUFM
 filterVarEnv     = filterUFM
 lookupWithDefaultVarEnv = lookupWithDefaultUFM
diff --git a/compiler/stranal/DmdAnal.hs b/compiler/stranal/DmdAnal.hs
index 44d2d200fb..e2a1dc4493 100644
--- a/compiler/stranal/DmdAnal.hs
+++ b/compiler/stranal/DmdAnal.hs
@@ -62,10 +62,10 @@ dmdAnalTopBind :: AnalEnv
                -> CoreBind
                -> (AnalEnv, CoreBind)
 dmdAnalTopBind sigs (NonRec id rhs)
-  = (extendAnalEnv TopLevel sigs id sig, NonRec id2 rhs2)
+  = (extendAnalEnv TopLevel sigs id2 (idStrictness id2), NonRec id2 rhs2)
   where
-    (  _, _, _,   rhs1) = dmdAnalRhsLetDown TopLevel Nothing sigs             id rhs
-    (sig, _, id2, rhs2) = dmdAnalRhsLetDown TopLevel Nothing (nonVirgin sigs) id rhs1
+    ( _, _,   rhs1) = dmdAnalRhsLetDown TopLevel Nothing sigs             id rhs
+    ( _, id2, rhs2) = dmdAnalRhsLetDown TopLevel Nothing (nonVirgin sigs) id rhs1
         -- Do two passes to improve CPR information
         -- See Note [CPR for thunks]
         -- See Note [Optimistic CPR in the "virgin" case]
@@ -284,10 +284,11 @@ dmdAnal' env dmd (Let (NonRec id rhs) body)
 dmdAnal' env dmd (Let (NonRec id rhs) body)
   = (body_ty2, Let (NonRec id2 rhs') body')
   where
-    (sig, lazy_fv, id1, rhs') = dmdAnalRhsLetDown NotTopLevel Nothing env id rhs
-    (body_ty, body')          = dmdAnal (extendAnalEnv NotTopLevel env id sig) dmd body
-    (body_ty1, id2)           = annotateBndr env body_ty id1
-    body_ty2                  = addLazyFVs body_ty1 lazy_fv
+    (lazy_fv, id1, rhs') = dmdAnalRhsLetDown NotTopLevel Nothing env id rhs
+    env1                 = extendAnalEnv NotTopLevel env id1 (idStrictness id1)
+    (body_ty, body')     = dmdAnal env1 dmd body
+    (body_ty1, id2)      = annotateBndr env body_ty id1
+    body_ty2             = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleasheable free variables]
 
         -- If the actual demand is better than the vanilla call
         -- demand, you might think that we might do better to re-analyse
@@ -307,7 +308,7 @@ dmdAnal' env dmd (Let (Rec pairs) body)
         (env', lazy_fv, pairs') = dmdFix NotTopLevel env pairs
         (body_ty, body')        = dmdAnal env' dmd body
         body_ty1                = deleteFVs body_ty (map fst pairs)
-        body_ty2                = addLazyFVs body_ty1 lazy_fv
+        body_ty2                = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleasheable free variables]
     in
     body_ty2 `seq`
     (body_ty2,  Let (Rec pairs') body')
@@ -479,55 +480,53 @@ dmdTransform env var dmd
 
 -- Recursive bindings
 dmdFix :: TopLevelFlag
-       -> AnalEnv               -- Does not include bindings for this binding
+       -> AnalEnv                            -- Does not include bindings for this binding
        -> [(Id,CoreExpr)]
-       -> (AnalEnv, DmdEnv,
-           [(Id,CoreExpr)])     -- Binders annotated with stricness info
+       -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with stricness info
 
 dmdFix top_lvl env orig_pairs
-  = (updSigEnv env (sigEnv final_env), lazy_fv, pairs')
-     -- Return to original virgin state, keeping new signatures
+  = loop 1 initial_pairs
   where
-    bndrs        = map fst orig_pairs
-    initial_env = addInitialSigs top_lvl env bndrs
-    (final_env, lazy_fv, pairs') = loop 1 initial_env orig_pairs
-
-    loop :: Int
-         -> AnalEnv                     -- Already contains the current sigs
-         -> [(Id,CoreExpr)]
-         -> (AnalEnv, DmdEnv, [(Id,CoreExpr)])
-    loop n env pairs
-      = -- pprTrace "dmd loop" (ppr n <+> ppr bndrs $$ ppr env) $
-        loop' n env pairs
-
-    loop' n env pairs
-      | found_fixpoint
-      = (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
-      = -- 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
+    bndrs = map fst orig_pairs
+
+    -- See Note [Initialising strictness]
+    initial_pairs | ae_virgin env = [(setIdStrictness id botSig, rhs) | (id, rhs) <- orig_pairs ]
+
+                  | otherwise     = orig_pairs
+
+    -- If fixed-point iteration does not yield a result we use this instead
+    -- See Note [Safe abortion in the fixed-point iteration]
+    abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)])
+    abort = (env, lazy_fv', zapped_pairs)
+      where (lazy_fv, pairs') = step True (zapIdStrictness orig_pairs)
+            -- Note [Lazy and unleasheable free variables]
+            non_lazy_fvs = plusVarEnvList $ map (strictSigDmdEnv . idStrictness . fst) pairs'
+            lazy_fv'     = lazy_fv `plusVarEnv` mapVarEnv (const topDmd) non_lazy_fvs
+            zapped_pairs = zapIdStrictness pairs'
+
+    -- The fixed-point varies the idStrictness field of the binders, and terminates if that
+    -- annotation does not change any more.
+    loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)])
+    loop n pairs
+      | found_fixpoint = (final_anal_env, lazy_fv, pairs')
+      | n == 10        = abort
+      | otherwise      = loop (n+1) pairs'
+      where
+        found_fixpoint    = map (idStrictness . fst) pairs' == map (idStrictness . fst) pairs
+        first_round       = n == 1
+        (lazy_fv, pairs') = step first_round pairs
+        final_anal_env    = extendAnalEnvs top_lvl env (map fst pairs')
 
-      | otherwise
-      = loop (n+1) (nonVirgin env') pairs'
+    step :: Bool -> [(Id, CoreExpr)] -> (DmdEnv, [(Id, CoreExpr)])
+    step first_round pairs = (lazy_fv, pairs')
       where
-        found_fixpoint = all (same_sig (sigEnv env) (sigEnv env')) bndrs
+        -- In all but the first iteration, delete the virgin flag
+        start_env | first_round = env
+                  | otherwise   = nonVirgin env
+
+        start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyDmdEnv)
 
-        ((env',lazy_fv), pairs') = mapAccumL my_downRhs (env, emptyDmdEnv) pairs
+        ((_,lazy_fv), pairs') = mapAccumL my_downRhs start pairs
                 -- mapAccumL: 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
@@ -535,23 +534,39 @@ dmdFix top_lvl env orig_pairs
         my_downRhs (env, lazy_fv) (id,rhs)
           = ((env', lazy_fv'), (id', rhs'))
           where
-            (sig, lazy_fv1, id', rhs') = dmdAnalRhsLetDown top_lvl (Just bndrs) env id rhs
-            lazy_fv'                   = plusVarEnv_C bothDmd lazy_fv lazy_fv1
-            env'                       = extendAnalEnv top_lvl env id sig
+            (lazy_fv1, id', rhs') = dmdAnalRhsLetDown top_lvl (Just bndrs) env id rhs
+            lazy_fv'              = plusVarEnv_C bothDmd lazy_fv lazy_fv1
+            env'                  = extendAnalEnv top_lvl env id (idStrictness id')
+
+
+    zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]
+    zapIdStrictness pairs = [(setIdStrictness id nopSig, rhs) | (id, rhs) <- pairs ]
+
+{-
+Note [Safe abortion in the fixed-point iteration]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Fixed-point iteration may fail to terminate. But we cannot simply give up and
+return the environment and code unchanged! We still need to do one additional
+round, for two reasons:
+
+ * To get information on used free variables (both lazy and strict!)
+   (see Note [Lazy and unleasheable free variables])
+ * To ensure that all expressions have been traversed at least once, and any left-over
+   strictness annotations have been updated.
 
-    same_sig sigs sigs' var = lookup sigs var == lookup sigs' var
-    lookup sigs var = case lookupVarEnv sigs var of
-                        Just (sig,_) -> sig
-                        Nothing      -> pprPanic "dmdFix" (ppr var)
+This final iteration does not add the variables to the strictness signature
+environment, which effectively assigns them 'nopSig' (see "getStrictness")
 
+-}
 
 -- Trivial RHS
 -- See Note [Demand analysis for trivial right-hand sides]
 dmdAnalTrivialRhs ::
     AnalEnv -> Id -> CoreExpr -> Var ->
-    (StrictSig, VarEnv Demand, Id, CoreExpr)
+    (DmdEnv, Id, CoreExpr)
 dmdAnalTrivialRhs env id rhs fn
-  = (fn_str, fn_fv, set_idStrictness env id fn_str, rhs)
+  = (fn_fv, set_idStrictness env id fn_str, rhs)
   where
     fn_str = getStrictness env fn
     fn_fv | isLocalId fn = unitVarEnv fn topDmd
@@ -579,7 +594,7 @@ dmdAnalTrivialRhs env id rhs fn
 dmdAnalRhsLetDown :: TopLevelFlag
            -> Maybe [Id]   -- Just bs <=> recursive, Nothing <=> non-recursive
            -> AnalEnv -> Id -> CoreExpr
-           -> (StrictSig, DmdEnv, Id, CoreExpr)
+           -> (DmdEnv, Id, CoreExpr)
 -- Process the RHS of the binding, add the strictness signature
 -- to the Id, and augment the environment with the signature as well.
 dmdAnalRhsLetDown top_lvl rec_flag env id rhs
@@ -587,7 +602,7 @@ dmdAnalRhsLetDown top_lvl rec_flag env id rhs
   = dmdAnalTrivialRhs env id rhs fn
 
   | otherwise
-  = (sig_ty, lazy_fv, id', mkLams bndrs' body')
+  = (lazy_fv, id', mkLams bndrs' body')
   where
     (bndrs, body)    = collectBinders rhs
     env_body         = foldl extendSigsWithLam env bndrs
@@ -604,12 +619,12 @@ dmdAnalRhsLetDown top_lvl rec_flag env id rhs
                  Nothing            -> cleanEvalDmd
                  Just (dc, _, _, _) -> cleanEvalProdDmd (dataConRepArity dc)
 
-    -- See Note [Lazy and unleashable free variables]
     -- See Note [Aggregated demand for cardinality]
     rhs_fv1 = case rec_flag of
                 Just bs -> reuseEnv (delVarEnvList rhs_fv bs)
                 Nothing -> rhs_fv
 
+    -- See Note [Lazy and unleashable free variables]
     (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv1
 
     rhs_res'  = trimCPRInfo trim_all trim_sums rhs_res
@@ -946,7 +961,7 @@ error stub, but which has RULES, you may want it not to be eliminated
 in favour of error!
 
 Note [Lazy and unleasheable free variables]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We put the strict and once-used FVs in the DmdType of the Id, so
 that at its call sites we unleash demands on its strict fvs.
 An example is 'roll' in imaginary/wheel-sieve2
@@ -974,9 +989,32 @@ Incidentally, here's a place where lambda-lifting h would
 lose the cigar --- we couldn't see the joint strictness in t/x
 
         ON THE OTHER HAND
+
 We don't want to put *all* the fv's from the RHS into the
-DmdType, because that makes fixpointing very slow --- the
-DmdType gets full of lazy demands that are slow to converge.
+DmdType. Because
+
+ * it makes the strictness signatures larger, and hence slows down fixpointing
+
+and
+
+ * it is useless information at the call site anyways:
+   For lazy, used-many times fv's we will never get any better result than
+   that, no matter how good the actual demand on the function at the call site
+   is (unless it is always absent, but then the whole binder is useless).
+
+Therefore we exclude lazy multiple-used fv's from the environment in the
+DmdType.
+
+But now the signature lies! (Missing variables are assumed to be absent.) To
+make up for this, the code that analyses the binding keeps the demand on those
+variable separate (usually called "lazy_fv") and adds it to the demand of the
+whole binding later.
+
+What if we decide _not_ to store a strictness signature for a binding at all, as
+we do when aborting a fixed-point iteration? The we risk losing the information
+that the strict variables are being used. In that case, we take all free variables
+mentioned in the (unsound) strictness signature, conservatively approximate the
+demand put on them (topDmd), and add that to the "lazy_fv" returned by "dmdFix".
 
 
 Note [Lamba-bound unfoldings]
@@ -1037,11 +1075,14 @@ emptyAnalEnv dflags fam_envs
 emptySigEnv :: SigEnv
 emptySigEnv = emptyVarEnv
 
-sigEnv :: AnalEnv -> SigEnv
-sigEnv = ae_sigs
+-- | Extend an environment with the strictness IDs attached to the id
+extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv
+extendAnalEnvs top_lvl env vars
+  = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars }
 
-updSigEnv :: AnalEnv -> SigEnv -> AnalEnv
-updSigEnv env sigs = env { ae_sigs = sigs }
+extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv
+extendSigEnvs top_lvl sigs vars
+  = extendVarEnvList sigs [ (var, (idStrictness var, top_lvl)) | var <- vars]
 
 extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> StrictSig -> AnalEnv
 extendAnalEnv top_lvl env var sig
@@ -1059,15 +1100,6 @@ getStrictness env fn
   | Just (sig, _) <- lookupSigEnv env fn = sig
   | otherwise                            = nopSig
 
-addInitialSigs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv
--- See Note [Initialising strictness]
-addInitialSigs top_lvl env@(AE { ae_sigs = sigs, ae_virgin = virgin }) ids
-  = env { ae_sigs = extendVarEnvList sigs [ (id, (init_sig id, top_lvl))
-                                          | id <- ids ] }
-  where
-    init_sig | virgin    = \_ -> botSig
-             | otherwise = idStrictness
-
 nonVirgin :: AnalEnv -> AnalEnv
 nonVirgin env = env { ae_virgin = False }
 
diff --git a/compiler/utils/UniqFM.hs b/compiler/utils/UniqFM.hs
index 244969cc91..be5da8373b 100644
--- a/compiler/utils/UniqFM.hs
+++ b/compiler/utils/UniqFM.hs
@@ -49,6 +49,7 @@ module UniqFM (
         plusUFM,
         plusUFM_C,
         plusUFM_CD,
+        plusUFMList,
         minusUFM,
         intersectUFM,
         intersectUFM_C,
@@ -71,6 +72,8 @@ module UniqFM (
 import Unique           ( Uniquable(..), Unique, getKey )
 import Outputable
 
+import Data.List (foldl')
+
 import qualified Data.IntMap as M
 import qualified Data.IntSet as S
 import Data.Typeable
@@ -214,6 +217,9 @@ plusUFM_CD f (UFM xm) dx (UFM ym) dy
       (M.map (\y -> dx `f` y))
       xm ym
 
+plusUFMList :: [UniqFM elt] -> UniqFM elt
+plusUFMList = foldl' plusUFM emptyUFM
+
 minusUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1
 minusUFM (UFM x) (UFM y) = UFM (M.difference x y)
 
diff --git a/testsuite/tests/stranal/should_run/all.T b/testsuite/tests/stranal/should_run/all.T
index 6846c8281c..d3d4aaff9d 100644
--- a/testsuite/tests/stranal/should_run/all.T
+++ b/testsuite/tests/stranal/should_run/all.T
@@ -12,4 +12,5 @@ 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, [''])
+test('T12368a', exit_code(1), compile_and_run, [''])