Commit a5cb27f3 authored by niteria's avatar niteria Committed by Ben Gamari
Browse files

Make type-class dictionary let binds deterministic

When generating dictionary let binds in dsTcEvBinds we may
end up generating them in arbitrary order according to Unique order.

Consider:

```
let $dEq = GHC.Classes.$fEqInt in
let $$dNum = GHC.Num.$fNumInt in ...
```

vs

```
let $dNum = GHC.Num.$fNumInt in
let $dEq = GHC.Classes.$fEqInt in ...
```

The way this change fixes it is by using `UniqDFM` - a type of
deterministic finite maps of things keyed on `Unique`s. This way when
you pull out evidence variables corresponding to type-class dictionaries
they are in deterministic order.

Currently it's the order of insertion and the way it's implemented is by
tagging the values with the time of insertion.

Test Plan:
I've added a new test case to reproduce the issue.
./validate

Reviewers: ezyang, simonmar, austin, simonpj, bgamari

Reviewed By: simonmar, simonpj, bgamari

Subscribers: thomie

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

GHC Trac Issues: #4012
parent fce758c5
......@@ -22,6 +22,15 @@ module VarEnv (
filterVarEnv, filterVarEnv_Directly, restrictVarEnv,
partitionVarEnv,
-- * Deterministic Var environments (maps)
DVarEnv,
-- ** Manipulating these environments
emptyDVarEnv,
extendDVarEnv,
lookupDVarEnv,
foldDVarEnv,
-- * The InScopeSet type
InScopeSet,
......@@ -52,6 +61,7 @@ import OccName
import Var
import VarSet
import UniqFM
import UniqDFM
import Unique
import Util
import Maybes
......@@ -447,3 +457,21 @@ modifyVarEnv_Directly mangle_fn env key
= case (lookupUFM_Directly env key) of
Nothing -> env
Just xx -> addToUFM_Directly env key (mangle_fn xx)
-- Deterministic VarEnv
-- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need
-- DVarEnv.
type DVarEnv elt = UniqDFM elt
emptyDVarEnv :: DVarEnv a
emptyDVarEnv = emptyUDFM
extendDVarEnv :: DVarEnv a -> Var -> a -> DVarEnv a
extendDVarEnv = addToUDFM
lookupDVarEnv :: DVarEnv a -> Var -> Maybe a
lookupDVarEnv = lookupUDFM
foldDVarEnv :: (a -> b -> b) -> b -> DVarEnv a -> b
foldDVarEnv = foldUDFM
......@@ -467,6 +467,7 @@ Library
Stream
StringBuffer
UniqFM
UniqDFM
UniqSet
Util
Vectorise.Builtins.Base
......
......@@ -580,6 +580,7 @@ compiler_stage2_dll0_MODULES = \
TysWiredIn \
Unify \
UniqFM \
UniqDFM \
UniqSet \
UniqSupply \
Unique \
......
......@@ -672,26 +672,44 @@ instance Data.Data TcEvBinds where
-----------------
newtype EvBindMap
= EvBindMap {
ev_bind_varenv :: VarEnv EvBind
ev_bind_varenv :: DVarEnv EvBind
} -- Map from evidence variables to evidence terms
-- We use @DVarEnv@ here to get deterministic ordering when we
-- turn it into a Bag.
-- If we don't do that, when we generate let bindings for
-- dictionaries in dsTcEvBinds they will be generated in random
-- order.
--
-- For example:
--
-- let $dEq = GHC.Classes.$fEqInt in
-- let $$dNum = GHC.Num.$fNumInt in ...
--
-- vs
--
-- let $dNum = GHC.Num.$fNumInt in
-- let $dEq = GHC.Classes.$fEqInt in ...
--
-- See Note [Deterministic UniqFM] in UniqDFM for explanation why
-- @UniqFM@ can lead to nondeterministic order.
emptyEvBindMap :: EvBindMap
emptyEvBindMap = EvBindMap { ev_bind_varenv = emptyVarEnv }
emptyEvBindMap = EvBindMap { ev_bind_varenv = emptyDVarEnv }
extendEvBinds :: EvBindMap -> EvBind -> EvBindMap
extendEvBinds bs ev_bind
= EvBindMap { ev_bind_varenv = extendVarEnv (ev_bind_varenv bs)
(eb_lhs ev_bind)
ev_bind }
= EvBindMap { ev_bind_varenv = extendDVarEnv (ev_bind_varenv bs)
(eb_lhs ev_bind)
ev_bind }
lookupEvBind :: EvBindMap -> EvVar -> Maybe EvBind
lookupEvBind bs = lookupVarEnv (ev_bind_varenv bs)
lookupEvBind bs = lookupDVarEnv (ev_bind_varenv bs)
evBindMapBinds :: EvBindMap -> Bag EvBind
evBindMapBinds = foldEvBindMap consBag emptyBag
foldEvBindMap :: (EvBind -> a -> a) -> a -> EvBindMap -> a
foldEvBindMap k z bs = foldVarEnv k z (ev_bind_varenv bs)
foldEvBindMap k z bs = foldDVarEnv k z (ev_bind_varenv bs)
-----------------
-- All evidence is bound by EvBinds; no side effects
......
{-
(c) Bartosz Nitka, Facebook, 2015
UniqDFM: Specialised deterministic finite maps, for things with @Uniques@.
Basically, the things need to be in class @Uniquable@, and we use the
@getUnique@ method to grab their @Uniques@.
This is very similar to @UniqFM@, the major difference being that the order of
folding is not dependent on @Unique@ ordering, giving determinism.
Currently the ordering is determined by insertion order.
See Note [Unique Determinism] in Unique for explanation why @Unique@ ordering
is not deterministic.
-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -Wall #-}
module UniqDFM (
-- * Unique-keyed deterministic mappings
UniqDFM, -- abstract type
-- ** Manipulating those mappings
emptyUDFM,
addToUDFM,
lookupUDFM,
foldUDFM,
eltsUDFM,
udfmToList,
) where
import FastString
import Unique ( Uniquable(..), Unique, getKey )
import Outputable
import qualified Data.IntMap as M
import Data.Typeable
import Data.Data
import Data.List (sortBy)
import Data.Function (on)
-- Note [Deterministic UniqFM]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Normal @UniqFM@ when you turn it into a list will use
-- Data.IntMap.toList function that returns the elements in the order of
-- the keys. The keys in @UniqFM@ are always @Uniques@, so you end up with
-- with a list ordered by @Uniques@.
-- The order of @Uniques@ is known to be not stable across rebuilds.
-- See Note [Unique Determinism] in Unique.
-- There's more than one way to implement this. The implementation here tags
-- every value with the insertion time that can later be used to sort the
-- values when asked to convert to a list.
--
-- An alternative would be to have
--
-- data UniqDFM ele = UDFM (M.IntMap ele) [ele]
--
-- where the list determines the order. This makes deletion tricky as we'd
-- only accumulate elements in that list, but makes merging easier as you
-- don't have to renumber everything.
-- I've tested both approaches by replacing UniqFM and the cost was about
-- the same for both. We don't need merging nor deletion yet, but when we
-- do it might be worth to reevaluate the trade-offs here.
data TaggedVal val = TaggedVal val {-# UNPACK #-} !Int
deriving (Data, Typeable)
taggedFst :: TaggedVal val -> val
taggedFst (TaggedVal v _) = v
taggedSnd :: TaggedVal val -> Int
taggedSnd (TaggedVal _ i) = i
instance Eq val => Eq (TaggedVal val) where
(TaggedVal v1 _) == (TaggedVal v2 _) = v1 == v2
instance Functor TaggedVal where
fmap f (TaggedVal val i) = TaggedVal (f val) i
data UniqDFM ele = UDFM !(M.IntMap (TaggedVal ele)) {-# UNPACK #-} !Int
deriving (Data, Typeable, Functor)
emptyUDFM :: UniqDFM elt
emptyUDFM = UDFM M.empty 0
addToUDFM :: Uniquable key => UniqDFM elt -> key -> elt -> UniqDFM elt
addToUDFM (UDFM m i) k v =
UDFM (M.insert (getKey $ getUnique k) (TaggedVal v i) m) (i + 1)
lookupUDFM :: Uniquable key => UniqDFM elt -> key -> Maybe elt
lookupUDFM (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey $ getUnique k) m
foldUDFM :: (elt -> a -> a) -> a -> UniqDFM elt -> a
foldUDFM k z m = foldr k z (eltsUDFM m)
eltsUDFM :: UniqDFM elt -> [elt]
eltsUDFM (UDFM m _i) =
map taggedFst $ sortBy (compare `on` taggedSnd) $ M.elems m
udfmToList :: UniqDFM elt -> [(Unique, elt)]
udfmToList (UDFM m _i) =
[ (getUnique k, taggedFst v)
| (k, v) <- sortBy (compare `on` (taggedSnd . snd)) $ M.toList m ]
-- Output-ery
instance Outputable a => Outputable (UniqDFM a) where
ppr ufm = pprUniqDFM ppr ufm
pprUniqDFM :: (a -> SDoc) -> UniqDFM a -> SDoc
pprUniqDFM ppr_elt ufm
= brackets $ fsep $ punctuate comma $
[ ppr uq <+> ptext (sLit ":->") <+> ppr_elt elt
| (uq, elt) <- udfmToList ufm ]
module A () where
-- This checks that the order of dictionary binds doesn't depend on the
-- order of Uniques.
-- Consider succ from Enum, it requires Num Int and Eq Int. The order of
-- let binds used to depend on the order of Uniques. Consider:
--
-- let $dEq = GHC.Classes.$fEqInt in
-- let $$dNum = GHC.Num.$fNumInt in ...
--
-- vs
--
-- let $dNum = GHC.Num.$fNumInt in
-- let $dEq = GHC.Classes.$fEqInt in ...
data B = C
deriving (Enum)
f :: Int -> Int
f n
| n >= 0 = 0
| otherwise = 0
TOP=../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
TEST_HC_OPTS_NO_RECOMP = $(filter-out -fforce-recomp,$(TEST_HC_OPTS))
determ003:
$(RM) A.hi A.o
'$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -O A.hs
$(CP) A.hi A.normal.hi
$(RM) A.hi A.o
'$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -O -dinitial-unique=16777215 -dunique-increment=-1 A.hs
diff A.hi A.normal.hi
test('determ003',
extra_clean(['A.o', 'A.hi', 'A.normal.hi']),
run_command,
['$MAKE -s --no-print-directory determ003'])
[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