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