summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthew Pickering <matthewtpickering@gmail.com>2021-01-27 09:58:59 +0000
committerMatthew Pickering <matthewtpickering@gmail.com>2021-03-03 19:11:08 +0000
commit7b9767b81f4f0b25b0c0402593be1182b9546bab (patch)
treee446784907016969d94c30cd1beabed6af45d462
parentf121ffe4be7dd156701d856fbc9afeaf50e7038e (diff)
downloadhaskell-7b9767b81f4f0b25b0c0402593be1182b9546bab.tar.gz
Use a newtype for CHeader and CStub in ForeignStubs
-rw-r--r--compiler/GHC/Driver/CodeOutput.hs12
-rw-r--r--compiler/GHC/Driver/Hooks.hs4
-rw-r--r--compiler/GHC/Driver/Main.hs7
-rw-r--r--compiler/GHC/HsToCore.hs2
-rw-r--r--compiler/GHC/HsToCore/Coverage.hs7
-rw-r--r--compiler/GHC/HsToCore/Foreign/Decl.hs38
-rw-r--r--compiler/GHC/Iface/Tidy/StaticPtrTable.hs7
-rw-r--r--compiler/GHC/StgToCmm.hs3
-rw-r--r--compiler/GHC/StgToCmm/Prof.hs3
-rw-r--r--compiler/GHC/StgToCmm/Types.hs3
-rw-r--r--compiler/GHC/Types/ForeignStubs.hs29
11 files changed, 71 insertions, 44 deletions
diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs
index 5e0c5f0c05..b459b7b447 100644
--- a/compiler/GHC/Driver/CodeOutput.hs
+++ b/compiler/GHC/Driver/CodeOutput.hs
@@ -210,7 +210,7 @@ outputForeignStubs logger 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
@@ -285,9 +285,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]
@@ -325,11 +325,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 4cf62412b5..99c6ba8609 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
@@ -71,7 +72,6 @@ import GHC.Data.Bag
import qualified Data.Kind
import System.Process
-import GHC.Utils.Outputable ( SDoc )
{-
************************************************************************
@@ -146,7 +146,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 fea51a7f96..d3695177d3 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -1548,7 +1548,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
@@ -1576,7 +1576,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" #-}
@@ -1712,7 +1713,7 @@ doCodeGen hsc_env this_mod denv data_tycons
Nothing -> StgToCmm.codeGen logger
Just h -> h
- 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" #-}
stg_to_cmm dflags this_mod denv data_tycons cost_centre_info stg_binds_w_fvs hpc_info
diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs
index 1410ef2709..bf15fd2e10 100644
--- a/compiler/GHC/HsToCore.hs
+++ b/compiler/GHC/HsToCore.hs
@@ -161,7 +161,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 8180696700..9aadaff9fd 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)
@@ -1316,10 +1317,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 4249204615..43175c69a3 100644
--- a/compiler/GHC/HsToCore/Foreign/Decl.hs
+++ b/compiler/GHC/HsToCore/Foreign/Decl.hs
@@ -102,13 +102,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
@@ -152,7 +152,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
@@ -162,7 +162,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
@@ -179,7 +179,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))
@@ -211,7 +211,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
@@ -297,7 +297,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)
{-
************************************************************************
@@ -315,7 +315,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
@@ -330,7 +330,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)
{-
************************************************************************
@@ -360,8 +360,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
)
@@ -430,7 +430,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
@@ -520,8 +520,8 @@ mkFExportCBits :: DynFlags
-> Type
-> Bool -- True <=> returns an IO type
-> CCallConv
- -> (SDoc,
- SDoc,
+ -> (CHeader,
+ CStub,
String, -- the argument reps
Int -- total size of arguments
)
@@ -599,7 +599,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"
@@ -646,7 +646,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 $$
@@ -683,7 +683,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.
@@ -695,7 +695,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 d60b52536f..d4ed196c91 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
@@ -85,7 +86,7 @@ codeGen :: Logger
-> 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 logger 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)