1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
|
-- | Foreign export stubs
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE TypeApplications #-}
module GHC.Types.ForeignStubs
( ForeignStubs (..)
, CHeader(..)
, CStub(..)
, initializerCStub
, finalizerCStub
, appendStubC
)
where
import {-# SOURCE #-} GHC.Cmm.CLabel
import GHC.Platform
import GHC.Utils.Outputable
import Data.List ((++))
import Data.Monoid
import Data.Semigroup
import Data.Coerce
data CStub = CStub { getCStub :: SDoc
, getInitializers :: [CLabel]
-- ^ Initializers to be run at startup
-- See Note [Initializers and finalizers in Cmm] in
-- "GHC.Cmm.InitFini".
, getFinalizers :: [CLabel]
-- ^ Finalizers to be run at shutdown
}
emptyCStub :: CStub
emptyCStub = CStub empty [] []
instance Monoid CStub where
mempty = emptyCStub
instance Semigroup CStub where
CStub a0 b0 c0 <> CStub a1 b1 c1 =
CStub (a0 $$ a1) (b0 ++ b1) (c0 ++ c1)
functionCStub :: Platform -> CLabel -> SDoc -> SDoc -> CStub
functionCStub platform clbl declarations body =
CStub body' [] []
where
body' = vcat
[ declarations
, hsep [text "void", pprCLabel platform clbl, text "(void)"]
, braces body
]
-- | @initializerCStub fn_nm decls body@ is a 'CStub' containing C initializer
-- function (e.g. an entry of the @.init_array@ section) named
-- @fn_nm@ with the given body and the given set of declarations.
initializerCStub :: Platform -> CLabel -> SDoc -> SDoc -> CStub
initializerCStub platform clbl declarations body =
functionCStub platform clbl declarations body
`mappend` CStub empty [clbl] []
-- | @finalizerCStub fn_nm decls body@ is a 'CStub' containing C finalizer
-- function (e.g. an entry of the @.fini_array@ section) named
-- @fn_nm@ with the given body and the given set of declarations.
finalizerCStub :: Platform -> CLabel -> SDoc -> SDoc -> CStub
finalizerCStub platform clbl declarations body =
functionCStub platform clbl declarations body
`mappend` CStub empty [] [clbl]
newtype CHeader = CHeader { getCHeader :: SDoc }
instance Monoid CHeader where
mempty = CHeader empty
mconcat = coerce (vcat @SDoc)
instance Semigroup CHeader where
(<>) = coerce (($$) @SDoc)
-- | Foreign export stubs
data ForeignStubs
= NoStubs
-- ^ We don't have any stubs
| ForeignStubs CHeader CStub
-- ^ There are some stubs. Parameters:
--
-- 1) Header file prototypes for
-- "foreign exported" functions
--
-- 2) C stubs to use when calling
-- "foreign exported" functions
appendStubC :: ForeignStubs -> CStub -> ForeignStubs
appendStubC NoStubs c_code = ForeignStubs mempty c_code
appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c `mappend` c_code)
|
