import update from devel:languages:haskell:lts:7
OBS-URL: https://build.opensuse.org/package/show/devel:languages:haskell/ghc?expand=0&rev=233
This commit is contained in:
Peter Simons
Git OBS Bridge
parent
e3b9e6ba9f
commit
5dacd8b967
135
D2844.patch
Normal file
135
D2844.patch
Normal file
@ -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 <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
|
||||||
|
}
|
||||||
|
|
||||||
Loading…
x
Reference in New Issue
Block a user