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
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
|
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-
(c) The University of Glasgow 2006
(c) The AQUA Project, Glasgow University, 1998
-}
-- | Desugaring foreign declarations
module GHC.HsToCore.Foreign.Decl
( dsForeigns
)
where
import GHC.Prelude
import GHC.Tc.Utils.Monad -- temp
import GHC.HsToCore.Foreign.C
import GHC.HsToCore.Foreign.Utils
import GHC.HsToCore.Monad
import GHC.Hs
import GHC.Types.Id
import GHC.Types.ForeignStubs
import GHC.Unit.Module
import GHC.Core.Coercion
import GHC.Cmm.CLabel
import GHC.Types.ForeignCall
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Driver.Session
import GHC.Platform
import GHC.Data.OrdList
import GHC.Utils.Panic
import GHC.Driver.Hooks
import Data.List (unzip4)
{-
Desugaring of @foreign@ declarations is naturally split up into
parts, an @import@ and an @export@ part. A @foreign import@
declaration
\begin{verbatim}
foreign import cc nm f :: prim_args -> IO prim_res
\end{verbatim}
is the same as
\begin{verbatim}
f :: prim_args -> IO prim_res
f a1 ... an = _ccall_ nm cc a1 ... an
\end{verbatim}
so we reuse the desugaring code in @GHC.HsToCore.Foreign.Call@ to deal with these.
-}
dsForeigns :: [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding)
dsForeigns fos = do
hooks <- getHooks
case dsForeignsHook hooks of
Nothing -> dsForeigns' fos
Just h -> h fos
dsForeigns' :: [LForeignDecl GhcTc]
-> DsM (ForeignStubs, OrdList Binding)
dsForeigns' []
= return (NoStubs, nilOL)
dsForeigns' fos = do
mod <- getModule
platform <- targetPlatform <$> getDynFlags
fives <- mapM do_ldecl fos
let
(hs, cs, idss, bindss) = unzip4 fives
fe_ids = concat idss
fe_init_code = foreignExportsInitialiser platform mod fe_ids
--
return (ForeignStubs
(mconcat hs)
(mconcat cs `mappend` fe_init_code),
foldr (appOL . toOL) nilOL bindss)
where
do_ldecl (L loc decl) = putSrcSpanDs (locA loc) (do_decl decl)
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
(bs, h, c) <- dsFImport id' co spec
traceIf (text "fi end" <+> ppr id)
return (h, c, [], bs)
do_decl (ForeignExport { fd_name = L _ id
, fd_e_ext = co
, fd_fe = CExport
(L _ (CExportStatic _ ext_nm cconv)) _ }) = do
(h, c, _, _) <- dsFExport id co ext_nm cconv False
return (h, c, [id], [])
{-
************************************************************************
* *
\subsection{Foreign import}
* *
************************************************************************
Desugaring foreign imports is just the matter of creating a binding
that on its RHS unboxes its arguments, performs the external call
(using the @CCallOp@ primop), before boxing the result up and returning it.
However, we create a worker/wrapper pair, thus:
foreign import f :: Int -> IO Int
==>
f x = IO ( \s -> case x of { I# x# ->
case fw s x# of { (# s1, y# #) ->
(# s1, I# y# #)}})
fw s x# = ccall f s x#
The strictness/CPR analyser won't do this automatically because it doesn't look
inside returned tuples; but inlining this wrapper is a Really Good Idea
because it exposes the boxing to the call site.
-}
dsFImport :: Id
-> Coercion
-> ForeignImport
-> DsM ([Binding], CHeader, CStub)
dsFImport id co (CImport cconv safety mHeader spec _) =
dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader
{-
************************************************************************
* *
\subsection{Foreign export}
* *
************************************************************************
The function that does most of the work for `@foreign export@' declarations.
(see below for the boilerplate code a `@foreign export@' declaration expands
into.)
For each `@foreign export foo@' in a module M we generate:
\begin{itemize}
\item a C function `@foo@', which calls
\item a Haskell stub `@M.\$ffoo@', which calls
\end{itemize}
the user-written Haskell function `@M.foo@'.
-}
dsFExport :: Id -- Either the exported Id,
-- or the foreign-export-dynamic constructor
-> Coercion -- Coercion between the Haskell type callable
-- from C, and its representation type
-> CLabelString -- The name to export to C land
-> CCallConv
-> Bool -- True => foreign export dynamic
-- so invoke IO action that's hanging off
-- the first argument's stable pointer
-> 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
)
dsFExport fn_id co ext_name cconv is_dyn = case cconv of
JavaScriptCallConv -> panic "dsFExport: JavaScript foreign exports not supported yet"
_ -> dsCFExport fn_id co ext_name cconv is_dyn
foreignExportsInitialiser :: Platform -> Module -> [Id] -> CStub
foreignExportsInitialiser _ _ [] = mempty
foreignExportsInitialiser platform mod hs_fns =
-- Initialise foreign exports by registering a stable pointer from an
-- __attribute__((constructor)) function.
-- The alternative is to do this from stginit functions generated in
-- codeGen/CodeGen.hs; however, stginit functions have a negative impact
-- on binary sizes and link times because the static linker will think that
-- all modules that are imported directly or indirectly are actually used by
-- the program.
-- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)
--
-- See Note [Tracking foreign exports] in rts/ForeignExports.c
initializerCStub platform fn_nm list_decl fn_body
where
fn_nm = mkInitializerStubLabel mod "fexports"
mod_str = pprModuleName (moduleName mod)
fn_body = text "registerForeignExports" <> parens (char '&' <> list_symbol) <> semi
list_symbol = text "stg_exports_" <> mod_str
list_decl = text "static struct ForeignExportsList" <+> list_symbol <+> equals
<+> braces (
text ".exports = " <+> export_list <> comma <+>
text ".n_entries = " <+> ppr (length hs_fns))
<> semi
export_list = braces $ pprWithCommas closure_ptr hs_fns
closure_ptr :: Id -> SDoc
closure_ptr fn = text "(StgPtr) &" <> ppr fn <> text "_closure"
|
