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

5 files changed, 173 insertions, 7 deletions

diff --git a/compiler/basicTypes/VarEnv.hs b/compiler/basicTypes/VarEnv.hs
index 424edcafe7..8051721f33 100644
--- a/compiler/basicTypes/VarEnv.hs
+++ b/compiler/basicTypes/VarEnv.hs
@@ -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
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 5506078004..45dcaa99cc 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -467,6 +467,7 @@ Library
         Stream
         StringBuffer
         UniqFM
+        UniqDFM
         UniqSet
         Util
         Vectorise.Builtins.Base
diff --git a/compiler/ghc.mk b/compiler/ghc.mk
index 5883b8a3c0..26e22b4840 100644
--- a/compiler/ghc.mk
+++ b/compiler/ghc.mk
@@ -580,6 +580,7 @@ compiler_stage2_dll0_MODULES = \
 	TysWiredIn \
 	Unify \
 	UniqFM \
+	UniqDFM \
 	UniqSet \
 	UniqSupply \
 	Unique \
diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs
index 1cfa351125..a56739bf4b 100644
--- a/compiler/typecheck/TcEvidence.hs
+++ b/compiler/typecheck/TcEvidence.hs
@@ -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
diff --git a/compiler/utils/UniqDFM.hs b/compiler/utils/UniqDFM.hs
new file mode 100644
index 0000000000..5f6554ed6c
--- /dev/null
+++ b/compiler/utils/UniqDFM.hs
@@ -0,0 +1,118 @@
+{-
+(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 ]