[commit: ghc] master: Make abstractVars deterministic in SetLevel (6393dd8)
git at git.haskell.org
git at git.haskell.org
Sun Nov 22 23:10:43 UTC 2015
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/6393dd8e437f68856b2e7889e576ed1bfb0a9678/ghc
>---------------------------------------------------------------
commit 6393dd8e437f68856b2e7889e576ed1bfb0a9678
Author: Bartosz Nitka <niteria at gmail.com>
Date: Sun Nov 22 23:42:30 2015 +0100
Make abstractVars deterministic in SetLevel
This fixes a non-determinism bug where depending on the order
of uniques allocated, the type variables would be in a different order
when abstracted for the purpose of lifting out an expression.
Test Plan:
I've added a new testcase that reproduces the problem
./validate
Reviewers: simonmar, austin, bgamari, simonpj
Reviewed By: simonpj
Subscribers: nomeata, thomie
Differential Revision: https://phabricator.haskell.org/D1504
GHC Trac Issues: #4012
>---------------------------------------------------------------
6393dd8e437f68856b2e7889e576ed1bfb0a9678
compiler/coreSyn/CoreFVs.hs | 1 +
compiler/coreSyn/MkCore.hs | 11 ++---
compiler/simplCore/SetLevels.hs | 27 ++++++-----
testsuite/tests/determinism/typecheck/A.hs | 52 ++++++++++++++++++++++
.../determinism/{determ002 => typecheck}/Makefile | 6 +--
.../determinism/{determ003 => typecheck}/all.T | 4 +-
.../determ005.stdout} | 0
7 files changed, 80 insertions(+), 21 deletions(-)
diff --git a/compiler/coreSyn/CoreFVs.hs b/compiler/coreSyn/CoreFVs.hs
index 39a1599..0533038 100644
--- a/compiler/coreSyn/CoreFVs.hs
+++ b/compiler/coreSyn/CoreFVs.hs
@@ -22,6 +22,7 @@ module CoreFVs (
-- * Free variables of Rules, Vars and Ids
varTypeTyVars,
+ varTypeTyVarsAcc,
idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars,
idFreeVarsAcc,
idRuleVars, idRuleRhsVars, stableUnfoldingVars,
diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs
index 8670e21..b1d535f 100644
--- a/compiler/coreSyn/MkCore.hs
+++ b/compiler/coreSyn/MkCore.hs
@@ -80,10 +80,10 @@ import BasicTypes
import Util
import Pair
import DynFlags
-
-import Data.Char ( ord )
import Data.List
import Data.Ord
+
+import Data.Char ( ord )
#if __GLASGOW_HASKELL__ < 709
import Data.Word ( Word )
#endif
@@ -97,13 +97,14 @@ infixl 4 `mkCoreApp`, `mkCoreApps`
* *
************************************************************************
-}
-
sortQuantVars :: [Var] -> [Var]
-- Sort the variables (KindVars, TypeVars, and Ids)
-- into order: Kind, then Type, then Id
-sortQuantVars = sortBy (comparing withCategory)
+-- It is a deterministic sort, meaining it doesn't look at the values of
+-- Uniques. For explanation why it's important See Note [Unique Determinism]
+-- in Unique.
+sortQuantVars = sortBy (comparing category)
where
- withCategory v = (category v, v)
category :: Var -> Int
category v
| isKindVar v = 1
diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs
index d37a62d..2f98007 100644
--- a/compiler/simplCore/SetLevels.hs
+++ b/compiler/simplCore/SetLevels.hs
@@ -998,19 +998,24 @@ abstractVars :: Level -> LevelEnv -> DVarSet -> [OutVar]
-- Find the variables in fvs, free vars of the target expresion,
-- whose level is greater than the destination level
-- These are the ones we are going to abstract out
+ --
+ -- Note that to get reproducible builds, the variables need to be
+ -- abstracted in deterministic order, not dependent on the values of
+ -- Uniques. This is achieved by using DVarSets, deterministic free
+ -- variable computation and deterministic sort.
+ -- See Note [Unique Determinism] in Unique for explanation of why
+ -- Uniques are not deterministic.
abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs
- = map zap $ uniq $ sortQuantVars
+ = map zap $ sortQuantVars $ uniq
[out_var | out_fv <- dVarSetElems (substDVarSet subst in_fvs)
- , out_var <- varSetElems (close out_fv)
+ , out_var <- dVarSetElems (close out_fv)
, abstract_me out_var ]
-- NB: it's important to call abstract_me only on the OutIds the
-- come from substDVarSet (not on fv, which is an InId)
where
uniq :: [Var] -> [Var]
- -- Remove adjacent duplicates; the sort will have brought them together
- uniq (v1:v2:vs) | v1 == v2 = uniq (v2:vs)
- | otherwise = v1 : uniq (v2:vs)
- uniq vs = vs
+ -- Remove duplicates, preserving order
+ uniq = dVarSetElems . mkDVarSet
abstract_me v = case lookupVarEnv lvl_env v of
Just lvl -> dest_lvl `ltLvl` lvl
@@ -1024,11 +1029,11 @@ abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs
setIdInfo v vanillaIdInfo
| otherwise = v
- close :: Var -> VarSet -- Close over variables free in the type
- -- Result includes the input variable itself
- close v = foldVarSet (unionVarSet . close)
- (unitVarSet v)
- (varTypeTyVars v)
+ close :: Var -> DVarSet -- Close over variables free in the type
+ -- Result includes the input variable itself
+ close v = foldDVarSet (unionDVarSet . close)
+ (unitDVarSet v)
+ (runFVDSet $ varTypeTyVarsAcc v)
type LvlM result = UniqSM result
diff --git a/testsuite/tests/determinism/typecheck/A.hs b/testsuite/tests/determinism/typecheck/A.hs
new file mode 100644
index 0000000..50b3ab1
--- /dev/null
+++ b/testsuite/tests/determinism/typecheck/A.hs
@@ -0,0 +1,52 @@
+module A (
+ ) where
+
+-- This reproduces the issue where type variables would be lifted out in
+-- different orders. Compare:
+--
+-- lvl =
+-- \ (@ (c :: * -> *)) (@ (t :: * -> *)) ->
+-- undefined
+-- @ ((forall d. Data d => c (t d))
+-- -> Maybe (c Node))
+-- (some Callstack thing)
+--
+-- $cdataCast1 =
+-- \ (@ (c :: * -> *)) (@ (t :: * -> *)) _ [Occ=Dead] ->
+-- lvl @ c @ t
+--
+-- vs
+--
+-- lvl =
+-- \ (@ (t :: * -> *)) (@ (c :: * -> *)) ->
+-- undefined
+-- @ ((forall d. Data d => c (t d))
+-- -> Maybe (c Node))
+-- (some Callstack thing)
+--
+-- $cdataCast1 =
+-- \ (@ (c :: * -> *)) (@ (t :: * -> *)) _ [Occ=Dead] ->
+-- lvl @ t @ c
+
+import Data.Data
+
+data Node = Node (Maybe Int) [Node]
+
+instance Data Node where
+
+ gfoldl = gfoldl
+ gunfold = gunfold
+ toConstr = toConstr
+ dataTypeOf = dataTypeOf
+
+ dataCast1 = undefined
+ dataCast2 = dataCast2
+
+ gmapT = gmapT
+ gmapQl = gmapQl
+ gmapQr = gmapQr
+ gmapQ = gmapQ
+ gmapQi = gmapQi
+ gmapM = gmapM
+ gmapMp = gmapMp
+ gmapMo = gmapMo
diff --git a/testsuite/tests/determinism/determ002/Makefile b/testsuite/tests/determinism/typecheck/Makefile
similarity index 57%
copy from testsuite/tests/determinism/determ002/Makefile
copy to testsuite/tests/determinism/typecheck/Makefile
index d94a1c2..f95bfc5 100644
--- a/testsuite/tests/determinism/determ002/Makefile
+++ b/testsuite/tests/determinism/typecheck/Makefile
@@ -4,10 +4,10 @@ include $(TOP)/mk/test.mk
TEST_HC_OPTS_NO_RECOMP = $(filter-out -fforce-recomp,$(TEST_HC_OPTS))
-determ002:
+determ005:
$(RM) A.hi A.o
- '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) A.hs
+ '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -O A.hs
$(CP) A.hi A.old.hi
$(RM) A.o
- '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) A.hs
+ '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -dinitial-unique=16777206 -dunique-increment=-1 -O A.hs
diff A.hi A.old.hi
diff --git a/testsuite/tests/determinism/determ003/all.T b/testsuite/tests/determinism/typecheck/all.T
similarity index 50%
copy from testsuite/tests/determinism/determ003/all.T
copy to testsuite/tests/determinism/typecheck/all.T
index c00544d..5696cef 100644
--- a/testsuite/tests/determinism/determ003/all.T
+++ b/testsuite/tests/determinism/typecheck/all.T
@@ -1,4 +1,4 @@
-test('determ003',
+test('determ005',
extra_clean(['A.o', 'A.hi', 'A.normal.hi']),
run_command,
- ['$MAKE -s --no-print-directory determ003'])
+ ['$MAKE -s --no-print-directory determ005'])
diff --git a/testsuite/tests/determinism/determ002/determ002.stdout b/testsuite/tests/determinism/typecheck/determ005.stdout
similarity index 100%
copy from testsuite/tests/determinism/determ002/determ002.stdout
copy to testsuite/tests/determinism/typecheck/determ005.stdout
More information about the ghc-commits
mailing list