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