Use a newtype for CHeader and CStub in ForeignStubs

11 files changed, 71 insertions, 44 deletions

diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs
index e767041536..aacedee669 100644
--- a/compiler/GHC/Driver/CodeOutput.hs
+++ b/compiler/GHC/Driver/CodeOutput.hs
@@ -206,7 +206,7 @@ outputForeignStubs dflags unit_state mod location stubs
      NoStubs ->
         return (False, Nothing)
 
-     ForeignStubs h_code c_code -> do
+     ForeignStubs (CHeader h_code) (CStub c_code) -> do
         let
             stub_c_output_d = pprCode CStyle c_code
             stub_c_output_w = showSDoc dflags stub_c_output_d
@@ -281,9 +281,9 @@ outputForeignStubs_help fname doc_str header footer
 -- module;
 
 -- | Generate code to initialise cost centres
-profilingInitCode :: Platform -> Module -> CollectedCCs -> SDoc
+profilingInitCode :: Platform -> Module -> CollectedCCs -> CStub
 profilingInitCode platform this_mod (local_CCs, singleton_CCSs)
- = vcat
+ = CStub $ vcat
     $  map emit_cc_decl local_CCs
     ++ map emit_ccs_decl singleton_CCSs
     ++ [emit_cc_list local_CCs]
@@ -321,11 +321,11 @@ profilingInitCode platform this_mod (local_CCs, singleton_CCSs)
 
 -- | Generate code to initialise info pointer origin
 -- See note [Mapping Info Tables to Source Positions]
-ipInitCode :: DynFlags -> Module -> [InfoProvEnt] -> SDoc
+ipInitCode :: DynFlags -> Module -> [InfoProvEnt] -> CStub
 ipInitCode dflags this_mod ents
  = if not (gopt Opt_InfoTableMap dflags)
-    then empty
-    else withPprStyle (PprCode CStyle) $ vcat
+    then mempty
+    else CStub $ vcat
     $  map emit_ipe_decl ents
     ++ [emit_ipe_list ents]
     ++ [ text "static void ip_init_" <> ppr this_mod
diff --git a/compiler/GHC/Driver/Hooks.hs b/compiler/GHC/Driver/Hooks.hs
index 82c17e1355..13c9c5252f 100644
--- a/compiler/GHC/Driver/Hooks.hs
+++ b/compiler/GHC/Driver/Hooks.hs
@@ -49,6 +49,7 @@ import GHC.Types.CostCentre
 import GHC.Types.IPE
 import GHC.Types.Meta
 import GHC.Types.HpcInfo
+import GHC.Types.ForeignStubs
 
 import GHC.Unit.Module
 import GHC.Unit.Module.ModSummary
@@ -72,7 +73,6 @@ import GHC.Data.Bag
 import Data.Maybe
 import qualified Data.Kind
 import System.Process
-import GHC.Utils.Outputable ( SDoc )
 
 {-
 ************************************************************************
@@ -147,7 +147,7 @@ data Hooks = Hooks
                                                           -> IO (Maybe HValue))
   , createIservProcessHook :: Maybe (CreateProcess -> IO ProcessHandle)
   , stgToCmmHook           :: Maybe (DynFlags -> Module -> InfoTableProvMap -> [TyCon] -> CollectedCCs
-                                 -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup (SDoc, ModuleLFInfos))
+                                 -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup (CStub, ModuleLFInfos))
   , cmmToRawCmmHook        :: forall a . Maybe (DynFlags -> Maybe Module -> Stream IO CmmGroupSRTs a
                                  -> IO (Stream IO RawCmmGroup a))
   }
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 3c6e6dfce6..0e2563c53f 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -1533,7 +1533,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do
             platform = targetPlatform dflags
             prof_init
               | sccProfilingEnabled dflags = profilingInitCode platform this_mod cost_centre_info
-              | otherwise = empty
+              | otherwise = mempty
 
         ------------------  Code generation ------------------
         -- The back-end is streamed: each top-level function goes
@@ -1560,7 +1560,8 @@ hscGenHardCode hsc_env cgguts location output_filename = do
                   return a
                 rawcmms1 = Stream.mapM dump rawcmms0
 
-            let foreign_stubs st = foreign_stubs0 `appendStubC` prof_init `appendStubC` (cgIPEStub st)
+            let foreign_stubs st = foreign_stubs0 `appendStubC` prof_init
+                                                  `appendStubC` cgIPEStub st
 
             (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cg_infos)
                 <- {-# SCC "codeOutput" #-}
@@ -1684,7 +1685,7 @@ doCodeGen hsc_env this_mod denv data_tycons
 
     dumpIfSet_dyn dflags Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_w_fvs)
 
-    let cmm_stream :: Stream IO CmmGroup (SDoc, ModuleLFInfos)
+    let cmm_stream :: Stream IO CmmGroup (CStub, ModuleLFInfos)
         -- See Note [Forcing of stg_binds]
         cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-}
             lookupHook stgToCmmHook StgToCmm.codeGen dflags dflags this_mod denv data_tycons
diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs
index ba73a7bb59..281791ec7b 100644
--- a/compiler/GHC/HsToCore.hs
+++ b/compiler/GHC/HsToCore.hs
@@ -159,7 +159,7 @@ deSugar hsc_env
                           ; ds_rules <- mapMaybeM dsRule rules
                           ; let hpc_init
                                   | gopt Opt_Hpc dflags = hpcInitCode (hsc_dflags hsc_env) mod ds_hpc_info
-                                  | otherwise = empty
+                                  | otherwise = mempty
                           ; return ( ds_ev_binds
                                    , foreign_prs `appOL` core_prs `appOL` spec_prs
                                    , spec_rules ++ ds_rules
diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs
index 54a3ba0ca0..ea176aa438 100644
--- a/compiler/GHC/HsToCore/Coverage.hs
+++ b/compiler/GHC/HsToCore/Coverage.hs
@@ -49,6 +49,7 @@ import GHC.Types.Name
 import GHC.Types.HpcInfo
 import GHC.Types.CostCentre
 import GHC.Types.CostCentre.State
+import GHC.Types.ForeignStubs
 
 import Control.Monad
 import Data.List (isSuffixOf, intersperse)
@@ -1323,10 +1324,10 @@ static void hpc_init_Main(void)
  hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);}
 -}
 
-hpcInitCode :: DynFlags -> Module -> HpcInfo -> SDoc
-hpcInitCode _ _ (NoHpcInfo {}) = Outputable.empty
+hpcInitCode :: DynFlags -> Module -> HpcInfo -> CStub
+hpcInitCode _ _ (NoHpcInfo {}) = mempty
 hpcInitCode dflags this_mod (HpcInfo tickCount hashNo)
- = vcat
+ = CStub $ vcat
     [ text "static void hpc_init_" <> ppr this_mod
          <> text "(void) __attribute__((constructor));"
     , text "static void hpc_init_" <> ppr this_mod <> text "(void)"
diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs
index 7f618eb77c..38cfd5171f 100644
--- a/compiler/GHC/HsToCore/Foreign/Decl.hs
+++ b/compiler/GHC/HsToCore/Foreign/Decl.hs
@@ -99,13 +99,13 @@ dsForeigns' fos = do
         fe_init_code = foreignExportsInitialiser mod fe_ids
     --
     return (ForeignStubs
-             (vcat hs)
-             (vcat cs $$ fe_init_code),
+             (mconcat hs)
+             (mconcat cs `mappend` fe_init_code),
             foldr (appOL . toOL) nilOL bindss)
   where
    do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl)
 
-   do_decl :: ForeignDecl GhcTc -> DsM (SDoc, SDoc, [Id], [Binding])
+   do_decl :: ForeignDecl GhcTc -> DsM (CHeader, CStub, [Id], [Binding])
    do_decl (ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec }) = do
       traceIf (text "fi start" <+> ppr id)
       let id' = unLoc id
@@ -149,7 +149,7 @@ because it exposes the boxing to the call site.
 dsFImport :: Id
           -> Coercion
           -> ForeignImport
-          -> DsM ([Binding], SDoc, SDoc)
+          -> DsM ([Binding], CHeader, CStub)
 dsFImport id co (CImport cconv safety mHeader spec _) =
     dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader
 
@@ -159,7 +159,7 @@ dsCImport :: Id
           -> CCallConv
           -> Safety
           -> Maybe Header
-          -> DsM ([Binding], SDoc, SDoc)
+          -> DsM ([Binding], CHeader, CStub)
 dsCImport id co (CLabel cid) cconv _ _ = do
    dflags <- getDynFlags
    let ty  = coercionLKind co
@@ -176,7 +176,7 @@ dsCImport id co (CLabel cid) cconv _ _ = do
         rhs' = Cast rhs co
         stdcall_info = fun_type_arg_stdcall_info platform cconv ty
     in
-    return ([(id, rhs')], empty, empty)
+    return ([(id, rhs')], mempty, mempty)
 
 dsCImport id co (CFunction target) cconv@PrimCallConv safety _
   = dsPrimCall id co (CCall (CCallSpec target cconv safety))
@@ -208,7 +208,7 @@ fun_type_arg_stdcall_info _ _other_conv _
 -}
 
 dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header
-        -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
+        -> DsM ([(Id, Expr TyVar)], CHeader, CStub)
 dsFCall fn_id co fcall mDeclHeader = do
     let
         ty                   = coercionLKind co
@@ -294,7 +294,7 @@ dsFCall fn_id co fcall mDeclHeader = do
                                                 simpl_opts
                                                 wrap_rhs'
 
-    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, cDoc)
+    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], mempty, CStub cDoc)
 
 {-
 ************************************************************************
@@ -312,7 +312,7 @@ for calling convention they are really prim ops.
 -}
 
 dsPrimCall :: Id -> Coercion -> ForeignCall
-           -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
+           -> DsM ([(Id, Expr TyVar)], CHeader, CStub)
 dsPrimCall fn_id co fcall = do
     let
         ty                   = coercionLKind co
@@ -327,7 +327,7 @@ dsPrimCall fn_id co fcall = do
         call_app = mkFCall dflags ccall_uniq fcall (map Var args) io_res_ty
         rhs      = mkLams tvs (mkLams args call_app)
         rhs'     = Cast rhs co
-    return ([(fn_id, rhs')], empty, empty)
+    return ([(fn_id, rhs')], mempty, mempty)
 
 {-
 ************************************************************************
@@ -357,8 +357,8 @@ dsFExport :: Id                 -- Either the exported Id,
           -> Bool               -- True => foreign export dynamic
                                 --         so invoke IO action that's hanging off
                                 --         the first argument's stable pointer
-          -> DsM ( SDoc         -- contents of Module_stub.h
-                 , SDoc         -- contents of Module_stub.c
+          -> DsM ( CHeader      -- contents of Module_stub.h
+                 , CStub        -- contents of Module_stub.c
                  , String       -- string describing type to pass to createAdj.
                  , Int          -- size of args to stub function
                  )
@@ -427,7 +427,7 @@ f_helper(StablePtr s, HsBool b, HsInt i)
 dsFExportDynamic :: Id
                  -> Coercion
                  -> CCallConv
-                 -> DsM ([Binding], SDoc, SDoc)
+                 -> DsM ([Binding], CHeader, CStub)
 dsFExportDynamic id co0 cconv = do
     mod <- getModule
     dflags <- getDynFlags
@@ -517,8 +517,8 @@ mkFExportCBits :: DynFlags
                -> Type
                -> Bool          -- True <=> returns an IO type
                -> CCallConv
-               -> (SDoc,
-                   SDoc,
+               -> (CHeader,
+                   CStub,
                    String,      -- the argument reps
                    Int          -- total size of arguments
                   )
@@ -617,7 +617,7 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
   -- Now we can cook up the prototype for the exported function.
   pprCconv = ccallConvAttribute cc
 
-  header_bits = text "extern" <+> fun_proto <> semi
+  header_bits = CHeader (text "extern" <+> fun_proto <> semi)
 
   fun_args
     | null aug_arg_info = text "void"
@@ -664,7 +664,7 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
 
 
   -- finally, the whole darn thing
-  c_bits =
+  c_bits = CStub $
     space $$
     extern_decl $$
     fun_proto  $$
@@ -701,7 +701,7 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
      ]
 
 
-foreignExportsInitialiser :: Module -> [Id] -> SDoc
+foreignExportsInitialiser :: Module -> [Id] -> CStub
 foreignExportsInitialiser mod hs_fns =
    -- Initialise foreign exports by registering a stable pointer from an
    -- __attribute__((constructor)) function.
@@ -713,7 +713,7 @@ foreignExportsInitialiser mod hs_fns =
    -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)
    --
    -- See Note [Tracking foreign exports] in rts/ForeignExports.c
-   vcat
+   CStub $ vcat
     [ text "static struct ForeignExportsList" <+> list_symbol <+> equals
          <+> braces (
            text ".exports = " <+> export_list <> comma <+>
diff --git a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs
index 0606728900..0a61f63aed 100644
--- a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs
+++ b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs
@@ -148,6 +148,7 @@ import GHC.Linker.Types
 import GHC.Types.Name
 import GHC.Types.Id
 import GHC.Types.TyThing
+import GHC.Types.ForeignStubs
 
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.State
@@ -264,9 +265,9 @@ sptCreateStaticBinds hsc_env this_mod binds
 --
 -- @fps@ is a list associating each binding corresponding to a static entry with
 -- its fingerprint.
-sptModuleInitCode :: Platform -> Module -> [SptEntry] -> SDoc
-sptModuleInitCode _        _        [] = Outputable.empty
-sptModuleInitCode platform this_mod entries = vcat
+sptModuleInitCode :: Platform -> Module -> [SptEntry] -> CStub
+sptModuleInitCode _        _        [] = mempty
+sptModuleInitCode platform this_mod entries = CStub $ vcat
     [ text "static void hs_spt_init_" <> ppr this_mod
            <> text "(void) __attribute__((constructor));"
     , text "static void hs_spt_init_" <> ppr this_mod <> text "(void)"
diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs
index cb0e8490ee..02ae83db11 100644
--- a/compiler/GHC/StgToCmm.hs
+++ b/compiler/GHC/StgToCmm.hs
@@ -48,6 +48,7 @@ import GHC.Types.Basic
 import GHC.Types.Var.Set ( isEmptyDVarSet )
 import GHC.Types.Unique.FM
 import GHC.Types.Name.Env
+import GHC.Types.ForeignStubs
 
 import GHC.Core.DataCon
 import GHC.Core.TyCon
@@ -84,7 +85,7 @@ codeGen :: DynFlags
         -> CollectedCCs                -- (Local/global) cost-centres needing declaring/registering.
         -> [CgStgTopBinding]           -- Bindings to convert
         -> HpcInfo
-        -> Stream IO CmmGroup (SDoc, ModuleLFInfos)       -- Output as a stream, so codegen can
+        -> Stream IO CmmGroup (CStub, ModuleLFInfos)       -- Output as a stream, so codegen can
                                        -- be interleaved with output
 
 codeGen dflags this_mod ip_map@(InfoTableProvMap (UniqMap denv) _) data_tycons
diff --git a/compiler/GHC/StgToCmm/Prof.hs b/compiler/GHC/StgToCmm/Prof.hs
index 0176c3dbdc..f0b9b2ae8c 100644
--- a/compiler/GHC/StgToCmm/Prof.hs
+++ b/compiler/GHC/StgToCmm/Prof.hs
@@ -45,6 +45,7 @@ import GHC.Cmm.CLabel
 
 import GHC.Types.CostCentre
 import GHC.Types.IPE
+import GHC.Types.ForeignStubs
 import GHC.Data.FastString
 import GHC.Unit.Module as Module
 import GHC.Utils.Outputable
@@ -276,7 +277,7 @@ sizeof_ccs_words platform
    (ws,ms) = pc_SIZEOF_CostCentreStack (platformConstants platform) `divMod` platformWordSizeInBytes platform
 
 
-initInfoTableProv ::  [CmmInfoTable] -> InfoTableProvMap -> Module -> FCode SDoc
+initInfoTableProv ::  [CmmInfoTable] -> InfoTableProvMap -> Module -> FCode CStub
 -- Emit the declarations
 initInfoTableProv infos itmap this_mod
   = do
diff --git a/compiler/GHC/StgToCmm/Types.hs b/compiler/GHC/StgToCmm/Types.hs
index 944ff4b072..2788a4a7cc 100644
--- a/compiler/GHC/StgToCmm/Types.hs
+++ b/compiler/GHC/StgToCmm/Types.hs
@@ -15,6 +15,7 @@ module GHC.StgToCmm.Types
 import GHC.Prelude
 
 import GHC.Types.Basic
+import GHC.Types.ForeignStubs
 import GHC.Core.DataCon
 import GHC.Types.Name.Env
 import GHC.Types.Name.Set
@@ -87,7 +88,7 @@ data CgInfos = CgInfos
       -- either not exported of CAFFY.
   , cgLFInfos :: !ModuleLFInfos
       -- ^ LambdaFormInfos of exported closures in the current module.
-  , cgIPEStub :: !SDoc
+  , cgIPEStub :: !CStub
       -- ^ The C stub which is used for IPE information
   }
 
diff --git a/compiler/GHC/Types/ForeignStubs.hs b/compiler/GHC/Types/ForeignStubs.hs
index eb4e45243e..0a37d230fe 100644
--- a/compiler/GHC/Types/ForeignStubs.hs
+++ b/compiler/GHC/Types/ForeignStubs.hs
@@ -1,17 +1,38 @@
 -- | Foreign export stubs
+{-# LANGUAGE DerivingVia #-}
 module GHC.Types.ForeignStubs
    ( ForeignStubs (..)
+   , CHeader(..)
+   , CStub(..)
    , appendStubC
    )
 where
 
 import GHC.Utils.Outputable
+import Data.Monoid
+import Data.Semigroup
+import Data.Coerce
+
+newtype CStub = CStub { getCStub :: SDoc }
+
+emptyCStub :: CStub
+emptyCStub = CStub empty
+
+instance Monoid CStub where
+  mempty = emptyCStub
+  mconcat = coerce vcat
+
+instance Semigroup CStub where
+  (<>) = coerce ($$)
+
+newtype CHeader = CHeader { getCHeader :: SDoc }
+  deriving (Monoid, Semigroup) via CStub
 
 -- | Foreign export stubs
 data ForeignStubs
   = NoStubs
       -- ^ We don't have any stubs
-  | ForeignStubs SDoc SDoc
+  | ForeignStubs CHeader CStub
       -- ^ There are some stubs. Parameters:
       --
       --  1) Header file prototypes for
@@ -20,6 +41,6 @@ data ForeignStubs
       --  2) C stubs to use when calling
       --     "foreign exported" functions
 
-appendStubC :: ForeignStubs -> SDoc -> ForeignStubs
-appendStubC NoStubs            c_code = ForeignStubs empty c_code
-appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code)
+appendStubC :: ForeignStubs -> CStub -> ForeignStubs
+appendStubC NoStubs         c_code = ForeignStubs mempty c_code
+appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c `mappend` c_code)