Commit 6393dd8e authored by niteria's avatar niteria Committed by Ben Gamari

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
parent 3df9563e
......@@ -22,6 +22,7 @@ module CoreFVs (
-- * Free variables of Rules, Vars and Ids
varTypeTyVars,
varTypeTyVarsAcc,
idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars,
idFreeVarsAcc,
idRuleVars, idRuleRhsVars, stableUnfoldingVars,
......
......@@ -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
......
......@@ -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
......
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
TOP=../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
TEST_HC_OPTS_NO_RECOMP = $(filter-out -fforce-recomp,$(TEST_HC_OPTS))
determ005:
$(RM) A.hi A.o
'$(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) -dinitial-unique=16777206 -dunique-increment=-1 -O A.hs
diff A.hi A.old.hi
test('determ005',
extra_clean(['A.o', 'A.hi', 'A.normal.hi']),
run_command,
['$MAKE -s --no-print-directory determ005'])
[1 of 1] Compiling A ( A.hs, A.o )
[1 of 1] Compiling A ( A.hs, A.o )
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment