never executed always true always false
1 {-
2 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3
4 \section[Foreign]{Foreign calls}
5 -}
6
7 {-# LANGUAGE DeriveDataTypeable #-}
8
9 module GHC.Types.ForeignCall (
10 ForeignCall(..), isSafeForeignCall,
11 Safety(..), playSafe, playInterruptible,
12
13 CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
14 CCallSpec(..),
15 CCallTarget(..), isDynamicTarget,
16 CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,
17
18 Header(..), CType(..),
19 ) where
20
21 import GHC.Prelude
22
23 import GHC.Data.FastString
24 import GHC.Utils.Binary
25 import GHC.Utils.Outputable
26 import GHC.Utils.Panic
27 import GHC.Unit.Module
28 import GHC.Types.SourceText ( SourceText, pprWithSourceText )
29
30 import Data.Char
31 import Data.Data
32
33 {-
34 ************************************************************************
35 * *
36 \subsubsection{Data types}
37 * *
38 ************************************************************************
39 -}
40
41 newtype ForeignCall = CCall CCallSpec
42 deriving Eq
43
44 isSafeForeignCall :: ForeignCall -> Bool
45 isSafeForeignCall (CCall (CCallSpec _ _ safe)) = playSafe safe
46
47 -- We may need more clues to distinguish foreign calls
48 -- but this simple printer will do for now
49 instance Outputable ForeignCall where
50 ppr (CCall cc) = ppr cc
51
52 data Safety
53 = PlaySafe -- ^ Might invoke Haskell GC, or do a call back, or
54 -- switch threads, etc. So make sure things are
55 -- tidy before the call. Additionally, in the threaded
56 -- RTS we arrange for the external call to be executed
57 -- by a separate OS thread, i.e., _concurrently_ to the
58 -- execution of other Haskell threads.
59
60 | PlayInterruptible -- ^ Like PlaySafe, but additionally
61 -- the worker thread running this foreign call may
62 -- be unceremoniously killed, so it must be scheduled
63 -- on an unbound thread.
64
65 | PlayRisky -- ^ None of the above can happen; the call will return
66 -- without interacting with the runtime system at all.
67 -- Specifically:
68 --
69 -- * No GC
70 -- * No call backs
71 -- * No blocking
72 -- * No precise exceptions
73 --
74 deriving ( Eq, Show, Data )
75 -- Show used just for Show Lex.Token, I think
76
77 instance Outputable Safety where
78 ppr PlaySafe = text "safe"
79 ppr PlayInterruptible = text "interruptible"
80 ppr PlayRisky = text "unsafe"
81
82 playSafe :: Safety -> Bool
83 playSafe PlaySafe = True
84 playSafe PlayInterruptible = True
85 playSafe PlayRisky = False
86
87 playInterruptible :: Safety -> Bool
88 playInterruptible PlayInterruptible = True
89 playInterruptible _ = False
90
91 {-
92 ************************************************************************
93 * *
94 \subsubsection{Calling C}
95 * *
96 ************************************************************************
97 -}
98
99 data CExportSpec
100 = CExportStatic -- foreign export ccall foo :: ty
101 SourceText -- of the CLabelString.
102 -- See note [Pragma source text] in GHC.Types.SourceText
103 CLabelString -- C Name of exported function
104 CCallConv
105 deriving Data
106
107 data CCallSpec
108 = CCallSpec CCallTarget -- What to call
109 CCallConv -- Calling convention to use.
110 Safety
111 deriving( Eq )
112
113 -- The call target:
114
115 -- | How to call a particular function in C-land.
116 data CCallTarget
117 -- An "unboxed" ccall# to named function in a particular package.
118 = StaticTarget
119 SourceText -- of the CLabelString.
120 -- See note [Pragma source text] in GHC.Types.SourceText
121 CLabelString -- C-land name of label.
122
123 (Maybe Unit) -- What package the function is in.
124 -- If Nothing, then it's taken to be in the current package.
125 -- Note: This information is only used for PrimCalls on Windows.
126 -- See CLabel.labelDynamic and CoreToStg.coreToStgApp
127 -- for the difference in representation between PrimCalls
128 -- and ForeignCalls. If the CCallTarget is representing
129 -- a regular ForeignCall then it's safe to set this to Nothing.
130
131 -- The first argument of the import is the name of a function pointer (an Addr#).
132 -- Used when importing a label as "foreign import ccall "dynamic" ..."
133 Bool -- True => really a function
134 -- False => a value; only
135 -- allowed in CAPI imports
136 | DynamicTarget
137
138 deriving( Eq, Data )
139
140 isDynamicTarget :: CCallTarget -> Bool
141 isDynamicTarget DynamicTarget = True
142 isDynamicTarget _ = False
143
144 {-
145 Stuff to do with calling convention:
146
147 ccall: Caller allocates parameters, *and* deallocates them.
148
149 stdcall: Caller allocates parameters, callee deallocates.
150 Function name has @N after it, where N is number of arg bytes
151 e.g. _Foo@8. This convention is x86 (win32) specific.
152
153 See: http://www.programmersheaven.com/2/Calling-conventions
154 -}
155
156 -- any changes here should be replicated in the CallConv type in template haskell
157 data CCallConv = CCallConv | CApiConv | StdCallConv | PrimCallConv | JavaScriptCallConv
158 deriving (Eq, Data)
159
160 instance Outputable CCallConv where
161 ppr StdCallConv = text "stdcall"
162 ppr CCallConv = text "ccall"
163 ppr CApiConv = text "capi"
164 ppr PrimCallConv = text "prim"
165 ppr JavaScriptCallConv = text "javascript"
166
167 defaultCCallConv :: CCallConv
168 defaultCCallConv = CCallConv
169
170 ccallConvToInt :: CCallConv -> Int
171 ccallConvToInt StdCallConv = 0
172 ccallConvToInt CCallConv = 1
173 ccallConvToInt CApiConv = panic "ccallConvToInt CApiConv"
174 ccallConvToInt (PrimCallConv {}) = panic "ccallConvToInt PrimCallConv"
175 ccallConvToInt JavaScriptCallConv = panic "ccallConvToInt JavaScriptCallConv"
176
177 {-
178 Generate the gcc attribute corresponding to the given
179 calling convention (used by PprAbsC):
180 -}
181
182 ccallConvAttribute :: CCallConv -> SDoc
183 ccallConvAttribute StdCallConv = text "__attribute__((__stdcall__))"
184 ccallConvAttribute CCallConv = empty
185 ccallConvAttribute CApiConv = empty
186 ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv"
187 ccallConvAttribute JavaScriptCallConv = panic "ccallConvAttribute JavaScriptCallConv"
188
189 type CLabelString = FastString -- A C label, completely unencoded
190
191 pprCLabelString :: CLabelString -> SDoc
192 pprCLabelString lbl = ftext lbl
193
194 isCLabelString :: CLabelString -> Bool -- Checks to see if this is a valid C label
195 isCLabelString lbl
196 = all ok (unpackFS lbl)
197 where
198 ok c = isAlphaNum c || c == '_' || c == '.'
199 -- The '.' appears in e.g. "foo.so" in the
200 -- module part of a ExtName. Maybe it should be separate
201
202 -- Printing into C files:
203
204 instance Outputable CExportSpec where
205 ppr (CExportStatic _ str _) = pprCLabelString str
206
207 instance Outputable CCallSpec where
208 ppr (CCallSpec fun cconv safety)
209 = hcat [ whenPprDebug callconv, ppr_fun fun, text " ::" ]
210 where
211 callconv = text "{-" <> ppr cconv <> text "-}"
212
213 gc_suf | playSafe safety = text "_safe"
214 | otherwise = text "_unsafe"
215
216 ppr_fun (StaticTarget st lbl mPkgId isFun)
217 = text (if isFun then "__ffi_static_ccall"
218 else "__ffi_static_ccall_value")
219 <> gc_suf
220 <+> (case mPkgId of
221 Nothing -> empty
222 Just pkgId -> ppr pkgId)
223 <> text ":"
224 <> ppr lbl
225 <+> (pprWithSourceText st empty)
226
227 ppr_fun DynamicTarget
228 = text "__ffi_dyn_ccall" <> gc_suf <+> text "\"\""
229
230 -- The filename for a C header file
231 -- Note [Pragma source text] in GHC.Types.SourceText
232 data Header = Header SourceText FastString
233 deriving (Eq, Data)
234
235 instance Outputable Header where
236 ppr (Header st h) = pprWithSourceText st (doubleQuotes $ ppr h)
237
238 -- | A C type, used in CAPI FFI calls
239 --
240 -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'{-\# CTYPE'@,
241 -- 'GHC.Parser.Annotation.AnnHeader','GHC.Parser.Annotation.AnnVal',
242 -- 'GHC.Parser.Annotation.AnnClose' @'\#-}'@,
243
244 -- For details on above see note [exact print annotations] in "GHC.Parser.Annotation"
245 data CType = CType SourceText -- Note [Pragma source text] in GHC.Types.SourceText
246 (Maybe Header) -- header to include for this type
247 (SourceText,FastString) -- the type itself
248 deriving (Eq, Data)
249
250 instance Outputable CType where
251 ppr (CType stp mh (stct,ct))
252 = pprWithSourceText stp (text "{-# CTYPE") <+> hDoc
253 <+> pprWithSourceText stct (doubleQuotes (ftext ct)) <+> text "#-}"
254 where hDoc = case mh of
255 Nothing -> empty
256 Just h -> ppr h
257
258 {-
259 ************************************************************************
260 * *
261 \subsubsection{Misc}
262 * *
263 ************************************************************************
264 -}
265
266 instance Binary ForeignCall where
267 put_ bh (CCall aa) = put_ bh aa
268 get bh = do aa <- get bh; return (CCall aa)
269
270 instance Binary Safety where
271 put_ bh PlaySafe =
272 putByte bh 0
273 put_ bh PlayInterruptible =
274 putByte bh 1
275 put_ bh PlayRisky =
276 putByte bh 2
277 get bh = do
278 h <- getByte bh
279 case h of
280 0 -> return PlaySafe
281 1 -> return PlayInterruptible
282 _ -> return PlayRisky
283
284 instance Binary CExportSpec where
285 put_ bh (CExportStatic ss aa ab) = do
286 put_ bh ss
287 put_ bh aa
288 put_ bh ab
289 get bh = do
290 ss <- get bh
291 aa <- get bh
292 ab <- get bh
293 return (CExportStatic ss aa ab)
294
295 instance Binary CCallSpec where
296 put_ bh (CCallSpec aa ab ac) = do
297 put_ bh aa
298 put_ bh ab
299 put_ bh ac
300 get bh = do
301 aa <- get bh
302 ab <- get bh
303 ac <- get bh
304 return (CCallSpec aa ab ac)
305
306 instance Binary CCallTarget where
307 put_ bh (StaticTarget ss aa ab ac) = do
308 putByte bh 0
309 put_ bh ss
310 put_ bh aa
311 put_ bh ab
312 put_ bh ac
313 put_ bh DynamicTarget =
314 putByte bh 1
315 get bh = do
316 h <- getByte bh
317 case h of
318 0 -> do ss <- get bh
319 aa <- get bh
320 ab <- get bh
321 ac <- get bh
322 return (StaticTarget ss aa ab ac)
323 _ -> return DynamicTarget
324
325 instance Binary CCallConv where
326 put_ bh CCallConv =
327 putByte bh 0
328 put_ bh StdCallConv =
329 putByte bh 1
330 put_ bh PrimCallConv =
331 putByte bh 2
332 put_ bh CApiConv =
333 putByte bh 3
334 put_ bh JavaScriptCallConv =
335 putByte bh 4
336 get bh = do
337 h <- getByte bh
338 case h of
339 0 -> return CCallConv
340 1 -> return StdCallConv
341 2 -> return PrimCallConv
342 3 -> return CApiConv
343 _ -> return JavaScriptCallConv
344
345 instance Binary CType where
346 put_ bh (CType s mh fs) = do put_ bh s
347 put_ bh mh
348 put_ bh fs
349 get bh = do s <- get bh
350 mh <- get bh
351 fs <- get bh
352 return (CType s mh fs)
353
354 instance Binary Header where
355 put_ bh (Header s h) = put_ bh s >> put_ bh h
356 get bh = do s <- get bh
357 h <- get bh
358 return (Header s h)