import update from devel:languages:haskell:lts:7

OBS-URL: https://build.opensuse.org/package/show/devel:languages:haskell/ghc?expand=0&rev=233
2016-12-18 13:43:23 +00:00 · 2016-12-18 13:43:23 +00:00 · 5dacd8b967
commit 5dacd8b967
parent e3b9e6ba9f
1 changed files with 135 additions and 0 deletions
--- a/D2844.patch
+++ 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 <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
+ }
+