Deprecate the threadsafe kind of foreign import
[ghc.git] / compiler / prelude / ForeignCall.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 %
4 \section[Foreign]{Foreign calls}
5
6 \begin{code}
7 {-# OPTIONS -w #-}
8 -- The above warning supression flag is a temporary kludge.
9 -- While working on this module you are encouraged to remove it and fix
10 -- any warnings in the module. See
11 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
12 -- for details
13
14 module ForeignCall (
15         ForeignCall(..),
16         Safety(..), playSafe,
17
18         CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
19         CCallSpec(..), 
20         CCallTarget(..), isDynamicTarget,
21         CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,
22
23         DNCallSpec(..), DNKind(..), DNType(..),
24         withDNTypes
25     ) where
26
27 import FastString
28 import Char             ( isAlphaNum )
29 import Binary
30 import Outputable
31 \end{code}
32
33
34 %************************************************************************
35 %*                                                                      *
36 \subsubsection{Data types}
37 %*                                                                      *
38 %************************************************************************
39
40 \begin{code}
41 data ForeignCall
42   = CCall       CCallSpec
43   | DNCall      DNCallSpec
44   deriving( Eq )                -- We compare them when seeing if an interface
45                                 -- has changed (for versioning purposes)
46   {-! derive: Binary !-}
47
48 -- We may need more clues to distinguish foreign calls
49 -- but this simple printer will do for now
50 instance Outputable ForeignCall where
51   ppr (CCall cc)  = ppr cc              
52   ppr (DNCall dn) = ppr dn
53 \end{code}
54
55   
56 \begin{code}
57 data Safety
58   = PlaySafe            -- Might invoke Haskell GC, or do a call back, or
59                         -- switch threads, etc.  So make sure things are
60                         -- tidy before the call. Additionally, in the threaded
61                         -- RTS we arrange for the external call to be executed
62                         -- by a separate OS thread, i.e., _concurrently_ to the
63                         -- execution of other Haskell threads.
64
65       Bool              -- Indicates the deprecated "threadsafe" annotation
66                         -- which is now an alias for "safe". This information
67                         -- is never used except to emit a deprecation warning.
68
69   | PlayRisky           -- None of the above can happen; the call will return
70                         -- without interacting with the runtime system at all
71   deriving( Eq, Show )
72         -- Show used just for Show Lex.Token, I think
73   {-! derive: Binary !-}
74
75 instance Outputable Safety where
76   ppr (PlaySafe False) = ptext (sLit "safe")
77   ppr (PlaySafe True)  = ptext (sLit "threadsafe")
78   ppr PlayRisky = ptext (sLit "unsafe")
79
80 playSafe :: Safety -> Bool
81 playSafe PlaySafe{} = True
82 playSafe PlayRisky  = False
83 \end{code}
84
85
86 %************************************************************************
87 %*                                                                      *
88 \subsubsection{Calling C}
89 %*                                                                      *
90 %************************************************************************
91
92 \begin{code}
93 data CExportSpec
94   = CExportStatic               -- foreign export ccall foo :: ty
95         CLabelString            -- C Name of exported function
96         CCallConv
97   {-! derive: Binary !-}
98
99 data CCallSpec
100   =  CCallSpec  CCallTarget     -- What to call
101                 CCallConv       -- Calling convention to use.
102                 Safety
103   deriving( Eq )
104   {-! derive: Binary !-}
105 \end{code}
106
107 The call target:
108
109 \begin{code}
110 data CCallTarget
111   = StaticTarget  CLabelString  -- An "unboxed" ccall# to `fn'.
112   | DynamicTarget               -- First argument (an Addr#) is the function pointer
113   deriving( Eq )
114   {-! derive: Binary !-}
115
116 isDynamicTarget :: CCallTarget -> Bool
117 isDynamicTarget DynamicTarget = True
118 isDynamicTarget _             = False
119 \end{code}
120
121
122 Stuff to do with calling convention:
123
124 ccall:          Caller allocates parameters, *and* deallocates them.
125
126 stdcall:        Caller allocates parameters, callee deallocates.
127                 Function name has @N after it, where N is number of arg bytes
128                 e.g.  _Foo@8
129
130 ToDo: The stdcall calling convention is x86 (win32) specific,
131 so perhaps we should emit a warning if it's being used on other
132 platforms.
133  
134 See: http://www.programmersheaven.com/2/Calling-conventions
135
136 \begin{code}
137 data CCallConv = CCallConv | StdCallConv | CmmCallConv
138   deriving (Eq)
139   {-! derive: Binary !-}
140
141 instance Outputable CCallConv where
142   ppr StdCallConv = ptext (sLit "stdcall")
143   ppr CCallConv   = ptext (sLit "ccall")
144   ppr CmmCallConv = ptext (sLit "C--")
145
146 defaultCCallConv :: CCallConv
147 defaultCCallConv = CCallConv
148
149 ccallConvToInt :: CCallConv -> Int
150 ccallConvToInt StdCallConv = 0
151 ccallConvToInt CCallConv   = 1
152 \end{code}
153
154 Generate the gcc attribute corresponding to the given
155 calling convention (used by PprAbsC):
156
157 \begin{code}
158 ccallConvAttribute :: CCallConv -> String
159 ccallConvAttribute StdCallConv = "__attribute__((__stdcall__))"
160 ccallConvAttribute CCallConv   = ""
161 \end{code}
162
163 \begin{code}
164 type CLabelString = FastString          -- A C label, completely unencoded
165
166 pprCLabelString :: CLabelString -> SDoc
167 pprCLabelString lbl = ftext lbl
168
169 isCLabelString :: CLabelString -> Bool  -- Checks to see if this is a valid C label
170 isCLabelString lbl 
171   = all ok (unpackFS lbl)
172   where
173     ok c = isAlphaNum c || c == '_' || c == '.'
174         -- The '.' appears in e.g. "foo.so" in the 
175         -- module part of a ExtName.  Maybe it should be separate
176 \end{code}
177
178
179 Printing into C files:
180
181 \begin{code}
182 instance Outputable CExportSpec where
183   ppr (CExportStatic str _) = pprCLabelString str
184
185 instance Outputable CCallSpec where
186   ppr (CCallSpec fun cconv safety)
187     = hcat [ ifPprDebug callconv, ppr_fun fun ]
188     where
189       callconv = text "{-" <> ppr cconv <> text "-}"
190
191       gc_suf | playSafe safety = text "_GC"
192              | otherwise       = empty
193
194       ppr_fun DynamicTarget     = text "__dyn_ccall" <> gc_suf <+> text "\"\""
195       ppr_fun (StaticTarget fn) = text "__ccall"     <> gc_suf <+> pprCLabelString fn
196 \end{code}
197
198
199 %************************************************************************
200 %*                                                                      *
201 \subsubsection{.NET interop}
202 %*                                                                      *
203 %************************************************************************
204
205 \begin{code}
206 data DNCallSpec = 
207         DNCallSpec Bool       -- True => static method/field
208                    DNKind     -- what type of access
209                    String     -- assembly
210                    String     -- fully qualified method/field name.
211                    [DNType]   -- argument types.
212                    DNType     -- result type.
213     deriving ( Eq )
214   {-! derive: Binary !-}
215
216 data DNKind
217   = DNMethod
218   | DNField
219   | DNConstructor
220     deriving ( Eq )
221   {-! derive: Binary !-}
222
223 data DNType
224   = DNByte
225   | DNBool
226   | DNChar
227   | DNDouble
228   | DNFloat
229   | DNInt
230   | DNInt8
231   | DNInt16
232   | DNInt32
233   | DNInt64
234   | DNWord8
235   | DNWord16
236   | DNWord32
237   | DNWord64
238   | DNPtr
239   | DNUnit
240   | DNObject
241   | DNString
242     deriving ( Eq )
243   {-! derive: Binary !-}
244
245 withDNTypes :: DNCallSpec -> [DNType] -> DNType -> DNCallSpec
246 withDNTypes (DNCallSpec isStatic k assem nm _ _) argTys resTy
247   = DNCallSpec isStatic k assem nm argTys resTy
248
249 instance Outputable DNCallSpec where
250   ppr (DNCallSpec isStatic kind ass nm _ _ ) 
251     = char '"' <> 
252        (if isStatic then text "static" else empty) <+>
253        (text (case kind of { DNMethod -> "method" ; DNField -> "field"; DNConstructor -> "ctor" })) <+>
254        (if null ass then char ' ' else char '[' <> text ass <> char ']') <>
255        text nm <> 
256       char '"'
257 \end{code}
258
259
260
261 %************************************************************************
262 %*                                                                      *
263 \subsubsection{Misc}
264 %*                                                                      *
265 %************************************************************************
266
267 \begin{code}
268 {-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
269 instance Binary ForeignCall where
270     put_ bh (CCall aa) = do
271             putByte bh 0
272             put_ bh aa
273     put_ bh (DNCall ab) = do
274             putByte bh 1
275             put_ bh ab
276     get bh = do
277             h <- getByte bh
278             case h of
279               0 -> do aa <- get bh
280                       return (CCall aa)
281               _ -> do ab <- get bh
282                       return (DNCall ab)
283
284 instance Binary Safety where
285     put_ bh (PlaySafe aa) = do
286             putByte bh 0
287             put_ bh aa
288     put_ bh PlayRisky = do
289             putByte bh 1
290     get bh = do
291             h <- getByte bh
292             case h of
293               0 -> do aa <- get bh
294                       return (PlaySafe aa)
295               _ -> do return PlayRisky
296
297 instance Binary CExportSpec where
298     put_ bh (CExportStatic aa ab) = do
299             put_ bh aa
300             put_ bh ab
301     get bh = do
302           aa <- get bh
303           ab <- get bh
304           return (CExportStatic aa ab)
305
306 instance Binary CCallSpec where
307     put_ bh (CCallSpec aa ab ac) = do
308             put_ bh aa
309             put_ bh ab
310             put_ bh ac
311     get bh = do
312           aa <- get bh
313           ab <- get bh
314           ac <- get bh
315           return (CCallSpec aa ab ac)
316
317 instance Binary CCallTarget where
318     put_ bh (StaticTarget aa) = do
319             putByte bh 0
320             put_ bh aa
321     put_ bh DynamicTarget = do
322             putByte bh 1
323     get bh = do
324             h <- getByte bh
325             case h of
326               0 -> do aa <- get bh
327                       return (StaticTarget aa)
328               _ -> do return DynamicTarget
329
330 instance Binary CCallConv where
331     put_ bh CCallConv = do
332             putByte bh 0
333     put_ bh StdCallConv = do
334             putByte bh 1
335     get bh = do
336             h <- getByte bh
337             case h of
338               0 -> do return CCallConv
339               _ -> do return StdCallConv
340
341 instance Binary DNCallSpec where
342     put_ bh (DNCallSpec isStatic kind ass nm _ _) = do
343             put_ bh isStatic
344             put_ bh kind
345             put_ bh ass
346             put_ bh nm
347     get bh = do
348           isStatic <- get bh
349           kind     <- get bh
350           ass      <- get bh
351           nm       <- get bh
352           return (DNCallSpec isStatic kind ass nm [] undefined)
353
354 instance Binary DNKind where
355     put_ bh DNMethod = do
356             putByte bh 0
357     put_ bh DNField = do
358             putByte bh 1
359     put_ bh DNConstructor = do
360             putByte bh 2
361     get bh = do
362             h <- getByte bh
363             case h of
364               0 -> do return DNMethod
365               1 -> do return DNField
366               _ -> do return DNConstructor
367
368 instance Binary DNType where
369     put_ bh DNByte = do
370             putByte bh 0
371     put_ bh DNBool = do
372             putByte bh 1
373     put_ bh DNChar = do
374             putByte bh 2
375     put_ bh DNDouble = do
376             putByte bh 3
377     put_ bh DNFloat = do
378             putByte bh 4
379     put_ bh DNInt = do
380             putByte bh 5
381     put_ bh DNInt8 = do
382             putByte bh 6
383     put_ bh DNInt16 = do
384             putByte bh 7
385     put_ bh DNInt32 = do
386             putByte bh 8
387     put_ bh DNInt64 = do
388             putByte bh 9
389     put_ bh DNWord8 = do
390             putByte bh 10
391     put_ bh DNWord16 = do
392             putByte bh 11
393     put_ bh DNWord32 = do
394             putByte bh 12
395     put_ bh DNWord64 = do
396             putByte bh 13
397     put_ bh DNPtr = do
398             putByte bh 14
399     put_ bh DNUnit = do
400             putByte bh 15
401     put_ bh DNObject = do
402             putByte bh 16
403     put_ bh DNString = do
404             putByte bh 17
405
406     get bh = do
407             h <- getByte bh
408             case h of
409               0 -> return DNByte
410               1 -> return DNBool
411               2 -> return DNChar
412               3 -> return DNDouble
413               4 -> return DNFloat
414               5 -> return DNInt
415               6 -> return DNInt8
416               7 -> return DNInt16
417               8 -> return DNInt32
418               9 -> return DNInt64
419               10 -> return DNWord8
420               11 -> return DNWord16
421               12 -> return DNWord32
422               13 -> return DNWord64
423               14 -> return DNPtr
424               15 -> return DNUnit
425               16 -> return DNObject
426               17 -> return DNString
427
428 --  Imported from other files :-
429
430 \end{code}