Move blob handling into StgToCmm

Move handling of big literal strings from CmmToAsm to StgToCmm. It
avoids the use of `sdocWithDynFlags` (cf #10143). We might need to move
this handling even higher in the pipeline in the future (cf #17960):
this patch will make it easier.

11 files changed, 59 insertions, 39 deletions

diff --git a/compiler/GHC/Cmm.hs b/compiler/GHC/Cmm.hs
index d52c3ad801..9973db8d0d 100644
--- a/compiler/GHC/Cmm.hs
+++ b/compiler/GHC/Cmm.hs
@@ -197,11 +197,13 @@ data Section = Section SectionType CLabel
 
 data CmmStatic
   = CmmStaticLit CmmLit
-        -- a literal value, size given by cmmLitRep of the literal.
+        -- ^ a literal value, size given by cmmLitRep of the literal.
   | CmmUninitialised Int
-        -- uninitialised data, N bytes long
+        -- ^ uninitialised data, N bytes long
   | CmmString ByteString
-        -- string of 8-bit values only, not zero terminated.
+        -- ^ string of 8-bit values only, not zero terminated.
+  | CmmFileEmbed FilePath
+        -- ^ an embedded binary file
 
 -- Static data before SRT generation
 data CmmStatics
diff --git a/compiler/GHC/Cmm/Ppr/Decl.hs b/compiler/GHC/Cmm/Ppr/Decl.hs
index 6bece6dca8..9190bf61be 100644
--- a/compiler/GHC/Cmm/Ppr/Decl.hs
+++ b/compiler/GHC/Cmm/Ppr/Decl.hs
@@ -155,6 +155,7 @@ pprStatic platform s = case s of
     CmmStaticLit lit   -> nest 4 $ text "const" <+> pprLit platform lit <> semi
     CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
     CmmString s'       -> nest 4 $ text "I8[]" <+> text (show s')
+    CmmFileEmbed path  -> nest 4 $ text "incbin " <+> text (show path)
 
 -- --------------------------------------------------------------------------
 -- data sections
diff --git a/compiler/GHC/Cmm/Utils.hs b/compiler/GHC/Cmm/Utils.hs
index 00600c2d67..0b0c848eb7 100644
--- a/compiler/GHC/Cmm/Utils.hs
+++ b/compiler/GHC/Cmm/Utils.hs
@@ -195,10 +195,9 @@ zeroExpr platform = CmmLit (zeroCLit platform)
 mkWordCLit :: Platform -> Integer -> CmmLit
 mkWordCLit platform wd = CmmInt wd (wordWidth platform)
 
+-- | We make a top-level decl for the string, and return a label pointing to it
 mkByteStringCLit
   :: CLabel -> ByteString -> (CmmLit, GenCmmDecl RawCmmStatics info stmt)
--- We have to make a top-level decl for the string,
--- and return a literal pointing to it
 mkByteStringCLit lbl bytes
   = (CmmLabel lbl, CmmData (Section sec lbl) $ RawCmmStatics lbl [CmmString bytes])
   where
diff --git a/compiler/GHC/CmmToAsm/PPC/Ppr.hs b/compiler/GHC/CmmToAsm/PPC/Ppr.hs
index 90b85023a2..647f1ff1c9 100644
--- a/compiler/GHC/CmmToAsm/PPC/Ppr.hs
+++ b/compiler/GHC/CmmToAsm/PPC/Ppr.hs
@@ -135,7 +135,8 @@ pprDatas platform (RawCmmStatics lbl dats) = vcat (pprLabel platform lbl : map (
 
 pprData :: Platform -> CmmStatic -> SDoc
 pprData platform d = case d of
-   CmmString str          -> pprBytes str
+   CmmString str          -> pprString str
+   CmmFileEmbed path      -> pprFileEmbed path
    CmmUninitialised bytes -> text ".space " <> int bytes
    CmmStaticLit lit       -> pprDataItem platform lit
 
diff --git a/compiler/GHC/CmmToAsm/Ppr.hs b/compiler/GHC/CmmToAsm/Ppr.hs
index 324bad63c4..c0abb52ad3 100644
--- a/compiler/GHC/CmmToAsm/Ppr.hs
+++ b/compiler/GHC/CmmToAsm/Ppr.hs
@@ -14,7 +14,8 @@ module GHC.CmmToAsm.Ppr (
         floatToBytes,
         doubleToBytes,
         pprASCII,
-        pprBytes,
+        pprString,
+        pprFileEmbed,
         pprSectionHeader
 )
 
@@ -26,11 +27,9 @@ import AsmUtils
 import GHC.Cmm.CLabel
 import GHC.Cmm
 import GHC.CmmToAsm.Config
-import GHC.Driver.Session
 import FastString
 import Outputable
 import GHC.Platform
-import FileCleanup
 
 import qualified Data.Array.Unsafe as U ( castSTUArray )
 import Data.Array.ST
@@ -43,7 +42,6 @@ import Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
 import GHC.Exts
 import GHC.Word
-import System.IO.Unsafe
 
 
 
@@ -129,24 +127,18 @@ pprASCII str
                  ]
        ord0 = 0x30 -- = ord '0'
 
--- | Pretty print binary data.
---
--- Use either the ".string" directive or a ".incbin" directive.
--- See Note [Embedding large binary blobs]
+-- | Emit a ".string" directive
+pprString :: ByteString -> SDoc
+pprString bs = text "\t.string " <> doubleQuotes (pprASCII bs)
+
+-- | Emit a ".incbin" directive
 --
 -- A NULL byte is added after the binary data.
---
-pprBytes :: ByteString -> SDoc
-pprBytes bs = sdocWithDynFlags $ \dflags ->
-  if binBlobThreshold dflags == 0
-     || fromIntegral (BS.length bs) <= binBlobThreshold dflags
-    then text "\t.string " <> doubleQuotes (pprASCII bs)
-    else unsafePerformIO $ do
-      bFile <- newTempName dflags TFL_CurrentModule ".dat"
-      BS.writeFile bFile bs
-      return $ text "\t.incbin "
-         <> pprFilePathString bFile -- proper escape (see #16389)
-         <> text "\n\t.byte 0"
+pprFileEmbed :: FilePath -> SDoc
+pprFileEmbed path
+   = text "\t.incbin "
+     <> pprFilePathString path -- proper escape (see #16389)
+     <> text "\n\t.byte 0"
 
 {-
 Note [Embedding large binary blobs]
diff --git a/compiler/GHC/CmmToAsm/SPARC/Ppr.hs b/compiler/GHC/CmmToAsm/SPARC/Ppr.hs
index a65ac03458..7c6954c548 100644
--- a/compiler/GHC/CmmToAsm/SPARC/Ppr.hs
+++ b/compiler/GHC/CmmToAsm/SPARC/Ppr.hs
@@ -116,9 +116,11 @@ pprDatas _platform (RawCmmStatics alias [CmmStaticLit (CmmLabel lbl), CmmStaticL
 pprDatas platform (RawCmmStatics lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats)
 
 pprData :: Platform -> CmmStatic -> SDoc
-pprData _ (CmmString str)           = pprBytes str
-pprData _ (CmmUninitialised bytes)  = text ".skip " <> int bytes
-pprData platform (CmmStaticLit lit) = pprDataItem platform lit
+pprData platform d = case d of
+   CmmString str          -> pprString str
+   CmmFileEmbed path      -> pprFileEmbed path
+   CmmUninitialised bytes -> text ".skip " <> int bytes
+   CmmStaticLit lit       -> pprDataItem platform lit
 
 pprGloblDecl :: CLabel -> SDoc
 pprGloblDecl lbl
diff --git a/compiler/GHC/CmmToAsm/X86/Ppr.hs b/compiler/GHC/CmmToAsm/X86/Ppr.hs
index 357e24a9cc..9230550872 100644
--- a/compiler/GHC/CmmToAsm/X86/Ppr.hs
+++ b/compiler/GHC/CmmToAsm/X86/Ppr.hs
@@ -167,7 +167,8 @@ pprDatas config (align, (RawCmmStatics lbl dats))
       platform = ncgPlatform config
 
 pprData :: NCGConfig -> CmmStatic -> SDoc
-pprData _config (CmmString str) = pprBytes str
+pprData _config (CmmString str) = pprString str
+pprData _config (CmmFileEmbed path) = pprFileEmbed path
 
 pprData config (CmmUninitialised bytes)
  = let platform = ncgPlatform config
diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs
index 21659c2a91..c630fbb305 100644
--- a/compiler/GHC/CmmToC.hs
+++ b/compiler/GHC/CmmToC.hs
@@ -574,6 +574,7 @@ pprStatic dflags s = case s of
 
     -- these should be inlined, like the old .hc
     CmmString s'       -> nest 4 (mkW_ <> parens(pprStringInCStyle s'))
+    CmmFileEmbed {}    -> panic "Unexpected CmmFileEmbed literal"
 
 
 -- ---------------------------------------------------------------------------
diff --git a/compiler/GHC/CmmToLlvm/Data.hs b/compiler/GHC/CmmToLlvm/Data.hs
index deb1929968..ea5b83a703 100644
--- a/compiler/GHC/CmmToLlvm/Data.hs
+++ b/compiler/GHC/CmmToLlvm/Data.hs
@@ -132,6 +132,7 @@ llvmSection (Section t suffix) = do
 -- | Handle static data
 genData :: CmmStatic -> LlvmM LlvmStatic
 
+genData (CmmFileEmbed {}) = panic "Unexpected CmmFileEmbed literal"
 genData (CmmString str) = do
     let v  = map (\x -> LMStaticLit $ LMIntLit (fromIntegral x) i8)
                  (BS.unpack str)
diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs
index 4c4b5b5a9e..0e6013d712 100644
--- a/compiler/GHC/StgToCmm.hs
+++ b/compiler/GHC/StgToCmm.hs
@@ -45,6 +45,7 @@ import Outputable
 import Stream
 import GHC.Types.Basic
 import GHC.Types.Var.Set ( isEmptyDVarSet )
+import FileCleanup
 
 import OrdList
 import GHC.Cmm.Graph
@@ -52,6 +53,8 @@ import GHC.Cmm.Graph
 import Data.IORef
 import Control.Monad (when,void)
 import Util
+import System.IO.Unsafe
+import qualified Data.ByteString as BS
 
 codeGen :: DynFlags
         -> Module
@@ -133,12 +136,24 @@ cgTopBinding dflags (StgTopLifted (StgRec pairs))
         ; sequence_ fcodes
         }
 
-cgTopBinding dflags (StgTopStringLit id str)
-  = do  { let label = mkBytesLabel (idName id)
-        ; let (lit, decl) = mkByteStringCLit label str
-        ; emitDecl decl
-        ; addBindC (litIdInfo dflags id mkLFStringLit lit)
-        }
+cgTopBinding dflags (StgTopStringLit id str) = do
+  let label = mkBytesLabel (idName id)
+  -- emit either a CmmString literal or dump the string in a file and emit a
+  -- CmmFileEmbed literal.
+  -- See Note [Embedding large binary blobs] in GHC.CmmToAsm.Ppr
+  let isNCG    = platformMisc_ghcWithNativeCodeGen $ platformMisc dflags
+      isSmall  = fromIntegral (BS.length str) <= binBlobThreshold dflags
+      asString = binBlobThreshold dflags == 0 || isSmall
+
+      (lit,decl) = if not isNCG || asString
+        then mkByteStringCLit label str
+        else mkFileEmbedLit label $ unsafePerformIO $ do
+               bFile <- newTempName dflags TFL_CurrentModule ".dat"
+               BS.writeFile bFile str
+               return bFile
+  emitDecl decl
+  addBindC (litIdInfo dflags id mkLFStringLit lit)
+
 
 cgTopRhs :: DynFlags -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ())
         -- The Id is passed along for setting up a binding...
diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs
index 1f439db546..bc9c4ac22f 100644
--- a/compiler/GHC/StgToCmm/Utils.hs
+++ b/compiler/GHC/StgToCmm/Utils.hs
@@ -38,7 +38,7 @@ module GHC.StgToCmm.Utils (
         cmmUntag, cmmIsTagged,
 
         addToMem, addToMemE, addToMemLblE, addToMemLbl,
-        mkWordCLit, mkByteStringCLit,
+        mkWordCLit, mkByteStringCLit, mkFileEmbedLit,
         newStringCLit, newByteStringCLit,
         blankWord,
 
@@ -292,10 +292,9 @@ mkRawRODataLits lbl lits
     needsRelocation (CmmLabelOff _ _) = True
     needsRelocation _                 = False
 
+-- | We make a top-level decl for the string, and return a label pointing to it
 mkByteStringCLit
   :: CLabel -> ByteString -> (CmmLit, GenCmmDecl CmmStatics info stmt)
--- We have to make a top-level decl for the string,
--- and return a literal pointing to it
 mkByteStringCLit lbl bytes
   = (CmmLabel lbl, CmmData (Section sec lbl) (CmmStaticsRaw lbl [CmmString bytes]))
   where
@@ -303,6 +302,12 @@ mkByteStringCLit lbl bytes
     -- C0 80). However, it can happen with Addr# literals.
     sec = if 0 `BS.elem` bytes then ReadOnlyData else CString
 
+-- | We make a top-level decl for the embedded binary file, and return a label pointing to it
+mkFileEmbedLit
+  :: CLabel -> FilePath -> (CmmLit, GenCmmDecl CmmStatics info stmt)
+mkFileEmbedLit lbl path
+  = (CmmLabel lbl, CmmData (Section ReadOnlyData lbl) (CmmStaticsRaw lbl [CmmFileEmbed path]))
+
 emitRawDataLits :: CLabel -> [CmmLit] -> FCode ()
 -- Emit a data-segment data block
 emitRawDataLits lbl lits = emitDecl (mkRawDataLits (Section Data lbl) lbl lits)