[commit: ghc] master: Slight refactoring to the fix for #4012 (7ec07e4)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/7ec07e4027826ad92cf651798cc4b5b9eea34a18/ghc

>---------------------------------------------------------------

commit 7ec07e4027826ad92cf651798cc4b5b9eea34a18
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Thu Jul 23 12:23:22 2015 +0100

    Slight refactoring to the fix for #4012
    
    Add CoreSyn.chooseOrphanAnchor, and use it


>---------------------------------------------------------------

7ec07e4027826ad92cf651798cc4b5b9eea34a18
 compiler/coreSyn/CoreSyn.hs  | 17 ++++++++++++++++-
 compiler/specialise/Rules.hs |  7 ++-----
 compiler/types/InstEnv.hs    | 18 ++++--------------
 3 files changed, 22 insertions(+), 20 deletions(-)

diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs
index c641d88..fedf1d7 100644
--- a/compiler/coreSyn/CoreSyn.hs
+++ b/compiler/coreSyn/CoreSyn.hs
@@ -68,7 +68,7 @@ module CoreSyn (
         deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs,
 
         -- * Orphanhood
-        IsOrphan(..), isOrphan, notOrphan,
+        IsOrphan(..), isOrphan, notOrphan, chooseOrphanAnchor,
 
         -- * Core rule data types
         CoreRule(..), RuleBase,
@@ -723,6 +723,21 @@ notOrphan :: IsOrphan -> Bool
 notOrphan NotOrphan{} = True
 notOrphan _ = False
 
+chooseOrphanAnchor :: [Name] -> IsOrphan
+-- Something (rule, instance) is relate to all the Names in this
+-- list. Choose one of them to be an "anchor" for the orphan.  We make
+-- the choice deterministic to avoid gratuitious changes in the ABI
+-- hash (Trac #4012).  Specficially, use lexicographic comparison of
+-- OccName rather than comparing Uniques
+--
+-- NB: 'minimum' use Ord, and (Ord OccName) works lexicographically
+--
+chooseOrphanAnchor local_names
+  | null local_names = IsOrphan
+  | otherwise        = NotOrphan (minimum occs)
+  where
+    occs = map nameOccName local_names
+
 instance Binary IsOrphan where
     put_ bh IsOrphan = putByte bh 0
     put_ bh (NotOrphan n) = do
diff --git a/compiler/specialise/Rules.hs b/compiler/specialise/Rules.hs
index f1288cc..65c3058 100644
--- a/compiler/specialise/Rules.hs
+++ b/compiler/specialise/Rules.hs
@@ -45,7 +45,7 @@ import Id
 import IdInfo           ( SpecInfo( SpecInfo ) )
 import VarEnv
 import VarSet
-import Name             ( Name, NamedThing(..), nameIsLocalOrFrom, nameOccName )
+import Name             ( Name, NamedThing(..), nameIsLocalOrFrom )
 import NameSet
 import NameEnv
 import Unify            ( ruleMatchTyX, MatchEnv(..) )
@@ -185,10 +185,7 @@ mkRule this_mod is_auto is_local name act fn bndrs args rhs
         -- it deterministic. This chooses the one with minimal OccName
         -- as opposed to uniq value.
     local_lhs_names = filter (nameIsLocalOrFrom this_mod) lhs_names
-    anchor = minimum $ map nameOccName local_lhs_names
-    orph = case local_lhs_names of
-             (_ : _) -> NotOrphan anchor
-             []      -> IsOrphan
+    orph = chooseOrphanAnchor local_lhs_names
 
 --------------
 roughTopNames :: [CoreExpr] -> [Maybe Name]
diff --git a/compiler/types/InstEnv.hs b/compiler/types/InstEnv.hs
index db8f531..e93d707 100644
--- a/compiler/types/InstEnv.hs
+++ b/compiler/types/InstEnv.hs
@@ -29,7 +29,7 @@ module InstEnv (
 
 #include "HsVersions.h"
 
-import CoreSyn (IsOrphan(..), isOrphan, notOrphan)
+import CoreSyn ( IsOrphan(..), isOrphan, notOrphan, chooseOrphanAnchor )
 import Module
 import Class
 import Var
@@ -234,19 +234,9 @@ mkLocalInstance dfun oflag tvs cls tys
     mb_ns | null fds   = [choose_one arg_names]
           | otherwise  = map do_one fds
     do_one (_ltvs, rtvs) = choose_one [ns | (tv,ns) <- cls_tvs `zip` arg_names
-                                          , not (tv `elem` rtvs)]
-
-    -- Since instance declarations get eventually attached to one of the types
-    -- from the definition when compiling the ABI hash, we should make
-    -- it deterministic. This chooses the one with minimal OccName
-    -- as opposed to uniq value.
-    choose_one :: [NameSet] -> IsOrphan
-    choose_one nss = case local_names of
-                       []      -> IsOrphan
-                       (_ : _) -> NotOrphan anchor
-      where
-      local_names = nameSetElems (unionNameSets nss)
-      anchor = minimum $ map nameOccName local_names
+                                            , not (tv `elem` rtvs)]
+
+    choose_one nss = chooseOrphanAnchor (nameSetElems (unionNameSets nss))
 
 mkImportedInstance :: Name
                    -> [Maybe Name]