diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2015-07-23 12:23:22 +0100 |
---|---|---|
committer | Simon Peyton Jones <simonpj@microsoft.com> | 2015-07-23 13:59:21 +0100 |
commit | 7ec07e4027826ad92cf651798cc4b5b9eea34a18 (patch) | |
tree | c07b6de518e025c619825b0af9575dfa2a86c1dd | |
parent | 4c8e69e0c09bfee989b747ba4028686f48cf8aa1 (diff) | |
download | haskell-7ec07e4027826ad92cf651798cc4b5b9eea34a18.tar.gz |
Slight refactoring to the fix for #4012
Add CoreSyn.chooseOrphanAnchor, and use it
-rw-r--r-- | compiler/coreSyn/CoreSyn.hs | 17 | ||||
-rw-r--r-- | compiler/specialise/Rules.hs | 7 | ||||
-rw-r--r-- | 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 c641d88f65..fedf1d73ec 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 f1288ccc64..65c3058344 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 db8f531a58..e93d7073c8 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] |