[commit: ghc] ghc-8.0: UniqSupply: Use full range of machine word (b85dc18)

[git at git.haskell.org]

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

On branch  : ghc-8.0
Link       : http://ghc.haskell.org/trac/ghc/changeset/b85dc18f731d7cc4eb4deb973931ef93671292d6/ghc

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

commit b85dc18f731d7cc4eb4deb973931ef93671292d6
Author: Ben Gamari <bgamari.foss at gmail.com>
Date:   Thu Dec 15 18:57:26 2016 -0500

    UniqSupply: Use full range of machine word
    
    Currently uniques are 32-bits wide. 8 of these bits are for the unique
    class, leaving only 24 for the unique number itself. This seems
    dangerously small for a large project. Let's use the full range of the
    native machine word.
    
    We also add (now largely unnecessary) overflow check to ensure that the
    unique number doesn't overflow.
    
    Test Plan: Validate
    
    Reviewers: simonmar, austin, niteria
    
    Reviewed By: niteria
    
    Subscribers: mpickering, thomie
    
    Differential Revision: https://phabricator.haskell.org/D2844
    
    GHC Trac Issues: #12944
    
    (cherry picked from commit 0d213c18b6962bb65e2b3035a258dd3f5bf454dd)


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

b85dc18f731d7cc4eb4deb973931ef93671292d6
 compiler/Unique.h                 |  3 +++
 compiler/basicTypes/UniqSupply.hs |  6 ++++--
 compiler/basicTypes/Unique.hs     | 15 +++++++++++----
 compiler/cbits/genSym.c           | 25 +++++++++++++++++++++----
 4 files changed, 39 insertions(+), 10 deletions(-)

diff --git a/compiler/Unique.h b/compiler/Unique.h
new file mode 100644
index 0000000..a786d8f
--- /dev/null
+++ b/compiler/Unique.h
@@ -0,0 +1,3 @@
+#include "../includes/MachDeps.h"
+
+#define UNIQUE_BITS (WORD_SIZE_IN_BITS - 8)
diff --git a/compiler/basicTypes/UniqSupply.hs b/compiler/basicTypes/UniqSupply.hs
index 16734bc..6a6734f 100644
--- a/compiler/basicTypes/UniqSupply.hs
+++ b/compiler/basicTypes/UniqSupply.hs
@@ -3,7 +3,7 @@
 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 -}
 
-{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE CPP, UnboxedTuples #-}
 
 module UniqSupply (
         -- * Main data type
@@ -38,6 +38,8 @@ import Control.Monad
 import Data.Bits
 import Data.Char
 
+#include "Unique.h"
+
 {-
 ************************************************************************
 *                                                                      *
@@ -73,7 +75,7 @@ takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply)
 -- ^ Obtain the 'Unique' from this particular 'UniqSupply', and a new supply
 
 mkSplitUniqSupply c
-  = case ord c `shiftL` 24 of
+  = case ord c `shiftL` UNIQUE_BITS of
      mask -> let
         -- here comes THE MAGIC:
 
diff --git a/compiler/basicTypes/Unique.hs b/compiler/basicTypes/Unique.hs
index eddf265..0a4d1bd 100644
--- a/compiler/basicTypes/Unique.hs
+++ b/compiler/basicTypes/Unique.hs
@@ -8,6 +8,7 @@
 comparison key in the compiler.
 
 If there is any single operation that needs to be fast, it is @Unique@
+
 comparison.  Unsurprisingly, there is quite a bit of huff-and-puff
 directed to that end.
 
@@ -63,6 +64,7 @@ module Unique (
     ) where
 
 #include "HsVersions.h"
+#include "Unique.h"
 
 import BasicTypes
 import FastString
@@ -124,6 +126,11 @@ deriveUnique (MkUnique i) delta = mkUnique 'X' (i + delta)
 -- newTagUnique changes the "domain" of a unique to a different char
 newTagUnique u c = mkUnique c i where (_,i) = unpkUnique u
 
+-- | How many bits are devoted to the unique index (as opposed to the class
+-- character).
+uniqueMask :: Int
+uniqueMask = (1 `shiftL` UNIQUE_BITS) - 1
+
 -- pop the Char in the top 8 bits of the Unique(Supply)
 
 -- No 64-bit bugs here, as long as we have at least 32 bits. --JSM
@@ -136,15 +143,15 @@ mkUnique :: Char -> Int -> Unique       -- Builds a unique from pieces
 mkUnique c i
   = MkUnique (tag .|. bits)
   where
-    tag  = ord c `shiftL` 24
-    bits = i .&. 16777215 {-``0x00ffffff''-}
+    tag  = ord c `shiftL` UNIQUE_BITS
+    bits = i .&. uniqueMask
 
 unpkUnique (MkUnique u)
   = let
         -- as long as the Char may have its eighth bit set, we
         -- really do need the logical right-shift here!
-        tag = chr (u `shiftR` 24)
-        i   = u .&. 16777215 {-``0x00ffffff''-}
+        tag = chr (u `shiftR` UNIQUE_BITS)
+        i   = u .&. uniqueMask
     in
     (tag, i)
 
diff --git a/compiler/cbits/genSym.c b/compiler/cbits/genSym.c
index 70ea417..725a310 100644
--- a/compiler/cbits/genSym.c
+++ b/compiler/cbits/genSym.c
@@ -1,18 +1,35 @@
-
+#include <assert.h>
 #include "Rts.h"
+#include "Unique.h"
 
 static HsInt GenSymCounter = 0;
 static HsInt GenSymInc = 1;
 
+#define UNIQUE_MASK ((1ULL << UNIQUE_BITS) - 1)
+
+STATIC_INLINE void checkUniqueRange(HsInt u STG_UNUSED) {
+#if DEBUG
+    // Uh oh! We will overflow next time a unique is requested.
+    assert(h != UNIQUE_MASK);
+#endif
+}
+
 HsInt genSym(void) {
 #if defined(THREADED_RTS)
     if (n_capabilities == 1) {
-        return GenSymCounter = (GenSymCounter + GenSymInc) & 0xFFFFFF;
+        GenSymCounter = (GenSymCounter + GenSymInc) & UNIQUE_MASK;
+        checkUniqueRange(GenSymCounter);
+        return GenSymCounter;
     } else {
-        return atomic_inc((StgWord *)&GenSymCounter, GenSymInc) & 0xFFFFFF;
+        HsInt n = atomic_inc((StgWord *)&GenSymCounter, GenSymInc)
+          & UNIQUE_MASK;
+        checkUniqueRange(n);
+        return n;
     }
 #else
-    return GenSymCounter = (GenSymCounter + GenSymInc) & 0xFFFFFF;
+    GenSymCounter = (GenSymCounter + GenSymInc) & UNIQUE_MASK;
+    checkUniqueRange(GenSymCounter);
+    return GenSymCounter;
 #endif
 }