[commit: ghc] wip/12368: DmdAnal: When aborting fixed-point-iteration, do not forget strict variables (924d210)
git at git.haskell.org
git at git.haskell.org
Fri Jul 22 12:27:57 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/12368
Link : http://ghc.haskell.org/trac/ghc/changeset/924d2102b8ee3de3d4a93274bdb0ea3918ac5008/ghc
>---------------------------------------------------------------
commit 924d2102b8ee3de3d4a93274bdb0ea3918ac5008
Author: Joachim Breitner <mail at joachim-breitner.de>
Date: Fri Jul 22 14:24:58 2016 +0200
DmdAnal: When aborting fixed-point-iteration, do not forget strict variables
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. This patch ensures
that in the case of an aborted fixed-point iteration, also the strict
variables are put there (with a conservative demand of topDmd).
>---------------------------------------------------------------
924d2102b8ee3de3d4a93274bdb0ea3918ac5008
compiler/basicTypes/Demand.hs | 7 ++++++-
compiler/basicTypes/VarEnv.hs | 5 ++++-
compiler/stranal/DmdAnal.hs | 15 +++++++++++++--
compiler/utils/UniqFM.hs | 6 ++++++
testsuite/tests/stranal/should_run/all.T | 2 +-
5 files changed, 30 insertions(+), 5 deletions(-)
diff --git a/compiler/basicTypes/Demand.hs b/compiler/basicTypes/Demand.hs
index 8dc7f3b..2ada6b3 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 92b6cc7..f02a426 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,
@@ -422,6 +423,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
@@ -461,6 +463,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 d6e02a9..22e1faa 100644
--- a/compiler/stranal/DmdAnal.hs
+++ b/compiler/stranal/DmdAnal.hs
@@ -495,8 +495,12 @@ dmdFix top_lvl env 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, zapIdStrictness pairs')
+ 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.
@@ -544,7 +548,7 @@ 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
+ * 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.
@@ -983,6 +987,7 @@ 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
* it makes the strictness signatures, and hence slows down
@@ -996,6 +1001,12 @@ absent.) To make up for this, the code that analyses the binding keeps the deman
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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/utils/UniqFM.hs b/compiler/utils/UniqFM.hs
index 244969c..be5da83 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 fb678b4..d3d4aaf 100644
--- a/testsuite/tests/stranal/should_run/all.T
+++ b/testsuite/tests/stranal/should_run/all.T
@@ -13,4 +13,4 @@ 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), compile_and_run, [''])
-test('T12368a', [expect_broken(12368), exit_code(1)], compile_and_run, [''])
+test('T12368a', exit_code(1), compile_and_run, [''])
More information about the ghc-commits
mailing list