TH: support raw bytes literals (#14741)

GHC represents String literals as ByteString internally for efficiency
reasons. However, until now it wasn't possible to efficiently create
large string literals with TH (e.g. to embed a file in a binary, cf #14741):
TH code had to unpack the bytes into a [Word8] that GHC then had to re-pack
into a ByteString.

This patch adds the possibility to efficiently create a "string" literal
from raw bytes. We get the following compile times for different sizes
of TH created literals:

|| Size || Before || After  || Gain ||
|| 30K  || 2.307s || 2.299  || 0%   ||
|| 3M   || 3.073s || 2.400s || 21%  ||
|| 30M  || 8.517s || 3.390s || 60%  ||

Ticket #14741 can be fixed if the original code uses this new TH feature.

3 files changed, 30 insertions, 0 deletions

diff --git a/testsuite/tests/th/T14741.hs b/testsuite/tests/th/T14741.hs
new file mode 100644
index 0000000000..3e27bb4996
--- /dev/null
+++ b/testsuite/tests/th/T14741.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE MagicHash #-}
+
+import Language.Haskell.TH.Lib
+import Data.Word
+import Foreign.ForeignPtr
+import Foreign.Marshal.Array
+import GHC.Exts
+import System.Mem
+import Control.Monad.IO.Class
+import GHC.CString
+
+ptr :: Ptr ()
+ptr = Ptr $(do
+   -- create a buffer containing the "Hello World!" string
+   let xs = [72,101,108,108,111,32,87,111,114,108,100,33] :: [Word8]
+   fp <- liftIO $ mallocForeignPtrArray 25
+   liftIO $ withForeignPtr fp $ \p -> do
+      pokeArray p xs
+   -- create a "Bytes" literal with an offset and size to only include "World"
+   let bys = mkBytes fp 6 5
+   liftIO performGC -- check that the GC doesn't release our buffer too early
+   litE (bytesPrimL bys))
+
+main :: IO ()
+main = do
+  let s = case ptr of Ptr addr -> unpackNBytes# addr 5#
+  putStrLn s
diff --git a/testsuite/tests/th/T14741.stdout b/testsuite/tests/th/T14741.stdout
new file mode 100644
index 0000000000..216e97ce08
--- /dev/null
+++ b/testsuite/tests/th/T14741.stdout
@@ -0,0 +1 @@
+World
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 70070a4687..c9f2065c7a 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -472,3 +472,4 @@ test('T16183', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T16195', normal, multimod_compile, ['T16195.hs', '-v0'])
 test('T16293b', normal, compile, [''])
 test('T16326_TH', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
+test('T14741', normal, compile_and_run, [''])