diff --git a/D2844.patch b/D2844.patch new file mode 100644 index 0000000..e9869e0 --- /dev/null +++ b/D2844.patch @@ -0,0 +1,135 @@ +Index: ghc-8.0.1/compiler/Unique.h +=================================================================== +--- /dev/null ++++ ghc-8.0.1/compiler/Unique.h +@@ -0,0 +1,3 @@ ++#include "../includes/MachDeps.h" ++ ++#define UNIQUE_BITS (WORD_SIZE_IN_BITS - 8) +Index: ghc-8.0.1/compiler/basicTypes/UniqSupply.hs +=================================================================== +--- ghc-8.0.1.orig/compiler/basicTypes/UniqSupply.hs ++++ ghc-8.0.1/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 -> (Uni + -- ^ 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: + +Index: ghc-8.0.1/compiler/basicTypes/Unique.hs +=================================================================== +--- ghc-8.0.1.orig/compiler/basicTypes/Unique.hs ++++ ghc-8.0.1/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. + +@@ -62,6 +63,7 @@ module Unique ( + ) where + + #include "HsVersions.h" ++#include "Unique.h" + + import BasicTypes + import FastString +@@ -123,6 +125,11 @@ deriveUnique (MkUnique i) delta = mkUniq + -- 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 +@@ -135,15 +142,15 @@ mkUnique :: Char -> Int -> Unique + 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) + +Index: ghc-8.0.1/compiler/cbits/genSym.c +=================================================================== +--- ghc-8.0.1.orig/compiler/cbits/genSym.c ++++ ghc-8.0.1/compiler/cbits/genSym.c +@@ -1,18 +1,35 @@ +- ++#include + #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 + } +