[commit: ghc] master: Verify that known-key uniques fit in interface file (6fecb2a)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/6fecb2a4dec6d1a4bfb5655ef5fc2a3e475954a4/ghc

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

commit 6fecb2a4dec6d1a4bfb5655ef5fc2a3e475954a4
Author: Ben Gamari <bgamari.foss at gmail.com>
Date:   Thu Dec 15 19:00:00 2016 -0500

    Verify that known-key uniques fit in interface file
    
    Here we introduce a debug check asserting that all uniques in
    knownKeyNames will fit in the space allowed in the interface file's
    symbol encoding.
    
    Test Plan: Validate
    
    Reviewers: austin
    
    Subscribers: thomie
    
    Differential Revision: https://phabricator.haskell.org/D2845


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

6fecb2a4dec6d1a4bfb5655ef5fc2a3e475954a4
 compiler/basicTypes/Unique.hs | 10 ++++++++++
 compiler/iface/BinIface.hs    |  4 +++-
 compiler/prelude/PrelInfo.hs  |  5 +++++
 3 files changed, 18 insertions(+), 1 deletion(-)

diff --git a/compiler/basicTypes/Unique.hs b/compiler/basicTypes/Unique.hs
index a6ac670..f93a4b1 100644
--- a/compiler/basicTypes/Unique.hs
+++ b/compiler/basicTypes/Unique.hs
@@ -36,6 +36,7 @@ module Unique (
         newTagUnique,                   -- Used in CgCase
         initTyVarUnique,
         nonDetCmpUnique,
+        isValidKnownKeyUnique,          -- Used in PrelInfo.knownKeyNamesOkay
 
         -- ** Making built-in uniques
 
@@ -157,6 +158,15 @@ unpkUnique (MkUnique u)
     in
     (tag, i)
 
+-- | The interface file symbol-table encoding assumes that known-key uniques fit
+-- in 30-bits; verify this.
+--
+-- See Note [Symbol table representation of names] in BinIface for details.
+isValidKnownKeyUnique :: Unique -> Bool
+isValidKnownKeyUnique u =
+    case unpkUnique u of
+      (c, x) -> ord c < 0xff && x <= (1 `shiftL` 22)
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index 3de647d..ad1e845 100644
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -293,7 +293,9 @@ serialiseName bh name _ = do
 --  00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx
 --   A normal name. x is an index into the symbol table
 --  10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy
---   A known-key name. x is the Unique's Char, y is the int part
+--   A known-key name. x is the Unique's Char, y is the int part. We assume that
+--   all known-key uniques fit in this space. This is asserted by
+--   PrelInfo.knownKeyNamesOkay.
 --
 -- During serialization we check for known-key things using isKnownKeyName.
 -- During deserialization we use lookupKnownKeyName to get from the unique back
diff --git a/compiler/prelude/PrelInfo.hs b/compiler/prelude/PrelInfo.hs
index b9eb9da..471b61e 100644
--- a/compiler/prelude/PrelInfo.hs
+++ b/compiler/prelude/PrelInfo.hs
@@ -46,6 +46,7 @@ module PrelInfo (
 #include "HsVersions.h"
 
 import KnownUniques
+import Unique           ( isValidKnownKeyUnique )
 
 import ConLike          ( ConLike(..) )
 import THNames          ( templateHaskellNames )
@@ -158,6 +159,10 @@ knownKeyNames
 -- | Check the known-key names list of consistency.
 knownKeyNamesOkay :: [Name] -> Maybe String
 knownKeyNamesOkay all_names
+  | ns@(_:_) <- filter (not . isValidKnownKeyUnique . getUnique) all_names
+  = Just $ "    Out-of-range known-key uniques: ["
+        ++ intercalate ", " (map (occNameString . nameOccName) ns) ++
+         "]"
   | null badNamesPairs
   = Nothing
   | otherwise