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.

6 files changed, 51 insertions, 1 deletions

diff --git a/libraries/ghci/GHCi/TH/Binary.hs b/libraries/ghci/GHCi/TH/Binary.hs
index 22a2847660..6f7aaca3e2 100644
--- a/libraries/ghci/GHCi/TH/Binary.hs
+++ b/libraries/ghci/GHCi/TH/Binary.hs
@@ -10,6 +10,7 @@ module GHCi.TH.Binary () where
 import Prelude -- See note [Why do we import Prelude here?]
 import Data.Binary
 import qualified Data.ByteString as B
+import qualified Data.ByteString.Internal as B
 import GHC.Serialized
 import qualified Language.Haskell.TH        as TH
 import qualified Language.Haskell.TH.Syntax as TH
@@ -72,3 +73,10 @@ instance Binary TH.PatSynArgs
 instance Binary Serialized where
     put (Serialized tyrep wds) = put tyrep >> put (B.pack wds)
     get = Serialized <$> get <*> (B.unpack <$> get)
+
+instance Binary TH.Bytes where
+   put (TH.Bytes ptr off sz) = put bs
+      where bs = B.PS ptr (fromIntegral off) (fromIntegral sz)
+   get = do
+      B.PS ptr off sz <- get
+      return (TH.Bytes ptr (fromIntegral off) (fromIntegral sz))
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
index 69a40428b8..0a9e11b936 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
@@ -26,7 +26,7 @@ module Language.Haskell.TH.Lib (
     -- ** Constructors lifted to 'Q'
     -- *** Literals
         intPrimL, wordPrimL, floatPrimL, doublePrimL, integerL, rationalL,
-        charL, stringL, stringPrimL, charPrimL,
+        charL, stringL, stringPrimL, charPrimL, bytesPrimL, mkBytes,
     -- *** Patterns
         litP, varP, tupP, unboxedTupP, unboxedSumP, conP, uInfixP, parensP,
         infixP, tildeP, bangP, asP, wildP, recP,
@@ -157,6 +157,8 @@ import Language.Haskell.TH.Lib.Internal hiding
 import Language.Haskell.TH.Syntax
 
 import Control.Monad (liftM2)
+import Foreign.ForeignPtr
+import Data.Word
 import Prelude
 
 -- All definitions below represent the "old" API, since their definitions are
@@ -303,3 +305,17 @@ standaloneDerivWithStrategyD mds ctxt ty = do
   ctxt' <- ctxt
   ty'   <- ty
   return $ StandaloneDerivD mds ctxt' ty'
+
+-------------------------------------------------------------------------------
+-- * Bytes literals
+
+-- | Create a Bytes datatype representing raw bytes to be embedded into the
+-- program/library binary.
+--
+-- @since 2.16.0.0
+mkBytes
+   :: ForeignPtr Word8 -- ^ Pointer to the data
+   -> Word             -- ^ Offset from the pointer
+   -> Word             -- ^ Number of bytes
+   -> Bytes
+mkBytes = Bytes
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
index 14ef0a02a8..b08b31c4fe 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
@@ -86,6 +86,8 @@ stringL     :: String -> Lit
 stringL     = StringL
 stringPrimL :: [Word8] -> Lit
 stringPrimL = StringPrimL
+bytesPrimL :: Bytes -> Lit
+bytesPrimL = BytesPrimL
 rationalL   :: Rational -> Lit
 rationalL   = RationalL
 
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index fa00c8c537..bc9efe6e3d 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -268,6 +268,7 @@ pprLit _ (CharL c)       = text (show c)
 pprLit _ (CharPrimL c)   = text (show c) <> char '#'
 pprLit _ (StringL s)     = pprString s
 pprLit _ (StringPrimL s) = pprString (bytesToString s) <> char '#'
+pprLit _ (BytesPrimL {}) = pprString "<binary data>"
 pprLit i (RationalL rat) = parensIf (i > noPrec) $
                            integer (numerator rat) <+> char '/'
                               <+> integer (denominator rat)
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 22c6cd1def..690d63807c 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -44,6 +44,7 @@ import GHC.ForeignSrcLang.Type
 import Language.Haskell.TH.LanguageExtensions
 import Numeric.Natural
 import Prelude
+import Foreign.ForeignPtr
 
 import qualified Control.Monad.Fail as Fail
 
@@ -1619,6 +1620,7 @@ data Lit = CharL Char
          | FloatPrimL Rational
          | DoublePrimL Rational
          | StringPrimL [Word8]  -- ^ A primitive C-style string, type Addr#
+         | BytesPrimL Bytes     -- ^ Some raw bytes, type Addr#:
          | CharPrimL Char
     deriving( Show, Eq, Ord, Data, Generic )
 
@@ -1626,6 +1628,24 @@ data Lit = CharL Char
     -- but that could complicate the
     -- supposedly-simple TH.Syntax literal type
 
+-- | Raw bytes embedded into the binary.
+--
+-- Avoid using Bytes constructor directly as it is likely to change in the
+-- future. Use helpers such as `mkBytes` in Language.Haskell.TH.Lib instead.
+data Bytes = Bytes
+   { bytesPtr    :: ForeignPtr Word8 -- ^ Pointer to the data
+   , bytesOffset :: Word             -- ^ Offset from the pointer
+   , bytesSize   :: Word             -- ^ Number of bytes
+   -- Maybe someday:
+   -- , bytesAlignement  :: Word -- ^ Alignement constraint
+   -- , bytesReadOnly    :: Bool -- ^ Shall we embed into a read-only
+   --                            --   section or not
+   -- , bytesInitialized :: Bool -- ^ False: only use `bytesSize` to allocate
+   --                            --   an uninitialized region
+   }
+   deriving (Eq,Ord,Data,Generic,Show)
+
+
 -- | Pattern in Haskell given in @{}@
 data Pat
   = LitP Lit                        -- ^ @{ 5 or \'c\' }@
diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md
index a64795b5b9..9928df9ba9 100644
--- a/libraries/template-haskell/changelog.md
+++ b/libraries/template-haskell/changelog.md
@@ -8,6 +8,9 @@
   * Add a `ForallVisT` constructor to `Type` to represent visible, dependent
     quantification.
 
+  * Introduce support for `Bytes` literals (raw bytes embedded into the output
+    binary)
+
 ## 2.15.0.0 *TBA*
 
   * In `Language.Haskell.TH.Syntax`, `DataInstD`, `NewTypeInstD`, `TySynEqn`,