summaryrefslogtreecommitdiff
path: root/compiler/prelude/ForeignCall.lhs
blob: 2c90a7dc6ea447880de1032d369fa77be89e04a0 (plain)
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
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[Foreign]{Foreign calls}

\begin{code}
module ForeignCall (
	ForeignCall(..),
	Safety(..), playSafe, playThreadSafe,

	CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
	CCallSpec(..), 
	CCallTarget(..), isDynamicTarget,
	CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,

	DNCallSpec(..), DNKind(..), DNType(..),
	withDNTypes
    ) where

#include "HsVersions.h"

import FastString	( FastString, unpackFS )
import Char		( isAlphaNum )
import Binary
import Outputable
\end{code}


%************************************************************************
%*									*
\subsubsection{Data types}
%*									*
%************************************************************************

\begin{code}
data ForeignCall
  = CCall	CCallSpec
  | DNCall	DNCallSpec
  deriving( Eq )		-- We compare them when seeing if an interface
				-- has changed (for versioning purposes)
  {-! derive: Binary !-}

-- We may need more clues to distinguish foreign calls
-- but this simple printer will do for now
instance Outputable ForeignCall where
  ppr (CCall cc)  = ppr cc		
  ppr (DNCall dn) = ppr dn
\end{code}

  
\begin{code}
data Safety
  = PlaySafe		-- Might invoke Haskell GC, or do a call back, or
			-- switch threads, etc.  So make sure things are
			-- tidy before the call
	Bool            -- => True, external function is also re-entrant.
			--    [if supported, RTS arranges for the external call
			--    to be executed by a separate OS thread, i.e.,
			--    _concurrently_ to the execution of other Haskell threads.]

  | PlayRisky		-- None of the above can happen; the call will return
			-- without interacting with the runtime system at all
  deriving( Eq, Show )
	-- Show used just for Show Lex.Token, I think
  {-! derive: Binary !-}

instance Outputable Safety where
  ppr (PlaySafe False) = ptext SLIT("safe")
  ppr (PlaySafe True)  = ptext SLIT("threadsafe")
  ppr PlayRisky = ptext SLIT("unsafe")

playSafe :: Safety -> Bool
playSafe PlaySafe{} = True
playSafe PlayRisky  = False

playThreadSafe :: Safety -> Bool
playThreadSafe (PlaySafe x) = x
playThreadSafe _ = False
\end{code}


%************************************************************************
%*									*
\subsubsection{Calling C}
%*									*
%************************************************************************

\begin{code}
data CExportSpec
  = CExportStatic		-- foreign export ccall foo :: ty
	CLabelString		-- C Name of exported function
	CCallConv
  {-! derive: Binary !-}

data CCallSpec
  =  CCallSpec	CCallTarget	-- What to call
		CCallConv	-- Calling convention to use.
		Safety
  deriving( Eq )
  {-! derive: Binary !-}
\end{code}

The call target:

\begin{code}
data CCallTarget
  = StaticTarget  CLabelString  -- An "unboxed" ccall# to `fn'.
  | DynamicTarget 		-- First argument (an Addr#) is the function pointer
  deriving( Eq )
  {-! derive: Binary !-}

isDynamicTarget :: CCallTarget -> Bool
isDynamicTarget DynamicTarget = True
isDynamicTarget other	      = False
\end{code}


Stuff to do with calling convention:

ccall:		Caller allocates parameters, *and* deallocates them.

stdcall: 	Caller allocates parameters, callee deallocates.
		Function name has @N after it, where N is number of arg bytes
		e.g.  _Foo@8

ToDo: The stdcall calling convention is x86 (win32) specific,
so perhaps we should emit a warning if it's being used on other
platforms.

\begin{code}
data CCallConv = CCallConv | StdCallConv
  deriving (Eq)
  {-! derive: Binary !-}

instance Outputable CCallConv where
  ppr StdCallConv = ptext SLIT("stdcall")
  ppr CCallConv   = ptext SLIT("ccall")

defaultCCallConv :: CCallConv
defaultCCallConv = CCallConv

ccallConvToInt :: CCallConv -> Int
ccallConvToInt StdCallConv = 0
ccallConvToInt CCallConv   = 1
\end{code}

Generate the gcc attribute corresponding to the given
calling convention (used by PprAbsC):

\begin{code}
ccallConvAttribute :: CCallConv -> String
ccallConvAttribute StdCallConv = "__attribute__((__stdcall__))"
ccallConvAttribute CCallConv   = ""
\end{code}

\begin{code}
type CLabelString = FastString		-- A C label, completely unencoded

pprCLabelString :: CLabelString -> SDoc
pprCLabelString lbl = ftext lbl

isCLabelString :: CLabelString -> Bool	-- Checks to see if this is a valid C label
isCLabelString lbl 
  = all ok (unpackFS lbl)
  where
    ok c = isAlphaNum c || c == '_' || c == '.'
	-- The '.' appears in e.g. "foo.so" in the 
	-- module part of a ExtName.  Maybe it should be separate
\end{code}


Printing into C files:

\begin{code}
instance Outputable CExportSpec where
  ppr (CExportStatic str _) = pprCLabelString str

instance Outputable CCallSpec where
  ppr (CCallSpec fun cconv safety)
    = hcat [ ifPprDebug callconv, ppr_fun fun ]
    where
      callconv = text "{-" <> ppr cconv <> text "-}"

      gc_suf | playSafe safety = text "_GC"
	     | otherwise       = empty

      ppr_fun DynamicTarget     = text "__dyn_ccall" <> gc_suf <+> text "\"\""
      ppr_fun (StaticTarget fn) = text "__ccall"     <> gc_suf <+> pprCLabelString fn
\end{code}


%************************************************************************
%*									*
\subsubsection{.NET interop}
%*									*
%************************************************************************

\begin{code}
data DNCallSpec = 
	DNCallSpec Bool       -- True => static method/field
		   DNKind     -- what type of access
		   String     -- assembly
		   String     -- fully qualified method/field name.
		   [DNType]   -- argument types.
		   DNType     -- result type.
    deriving ( Eq )
  {-! derive: Binary !-}

data DNKind
  = DNMethod
  | DNField
  | DNConstructor
    deriving ( Eq )
  {-! derive: Binary !-}

data DNType
  = DNByte
  | DNBool
  | DNChar
  | DNDouble
  | DNFloat
  | DNInt
  | DNInt8
  | DNInt16
  | DNInt32
  | DNInt64
  | DNWord8
  | DNWord16
  | DNWord32
  | DNWord64
  | DNPtr
  | DNUnit
  | DNObject
  | DNString
    deriving ( Eq )
  {-! derive: Binary !-}

withDNTypes :: DNCallSpec -> [DNType] -> DNType -> DNCallSpec
withDNTypes (DNCallSpec isStatic k assem nm _ _) argTys resTy
  = DNCallSpec isStatic k assem nm argTys resTy

instance Outputable DNCallSpec where
  ppr (DNCallSpec isStatic kind ass nm _ _ ) 
    = char '"' <> 
       (if isStatic then text "static" else empty) <+>
       (text (case kind of { DNMethod -> "method" ; DNField -> "field"; DNConstructor -> "ctor" })) <+>
       (if null ass then char ' ' else char '[' <> text ass <> char ']') <>
       text nm <> 
      char '"'
\end{code}



%************************************************************************
%*									*
\subsubsection{Misc}
%*									*
%************************************************************************

\begin{code}
{-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
instance Binary ForeignCall where
    put_ bh (CCall aa) = do
	    putByte bh 0
	    put_ bh aa
    put_ bh (DNCall ab) = do
	    putByte bh 1
	    put_ bh ab
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do aa <- get bh
		      return (CCall aa)
	      _ -> do ab <- get bh
		      return (DNCall ab)

instance Binary Safety where
    put_ bh (PlaySafe aa) = do
	    putByte bh 0
	    put_ bh aa
    put_ bh PlayRisky = do
	    putByte bh 1
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do aa <- get bh
		      return (PlaySafe aa)
	      _ -> do return PlayRisky

instance Binary CExportSpec where
    put_ bh (CExportStatic aa ab) = do
	    put_ bh aa
	    put_ bh ab
    get bh = do
	  aa <- get bh
	  ab <- get bh
	  return (CExportStatic aa ab)

instance Binary CCallSpec where
    put_ bh (CCallSpec aa ab ac) = do
	    put_ bh aa
	    put_ bh ab
	    put_ bh ac
    get bh = do
	  aa <- get bh
	  ab <- get bh
	  ac <- get bh
	  return (CCallSpec aa ab ac)

instance Binary CCallTarget where
    put_ bh (StaticTarget aa) = do
	    putByte bh 0
	    put_ bh aa
    put_ bh DynamicTarget = do
	    putByte bh 1
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do aa <- get bh
		      return (StaticTarget aa)
	      _ -> do return DynamicTarget

instance Binary CCallConv where
    put_ bh CCallConv = do
	    putByte bh 0
    put_ bh StdCallConv = do
	    putByte bh 1
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do return CCallConv
	      _ -> do return StdCallConv

instance Binary DNCallSpec where
    put_ bh (DNCallSpec isStatic kind ass nm _ _) = do
            put_ bh isStatic
	    put_ bh kind
	    put_ bh ass
	    put_ bh nm
    get bh = do
          isStatic <- get bh
	  kind     <- get bh
	  ass      <- get bh
	  nm       <- get bh
	  return (DNCallSpec isStatic kind ass nm [] undefined)

instance Binary DNKind where
    put_ bh DNMethod = do
	    putByte bh 0
    put_ bh DNField = do
	    putByte bh 1
    put_ bh DNConstructor = do
	    putByte bh 2
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do return DNMethod
	      1 -> do return DNField
	      _ -> do return DNConstructor

instance Binary DNType where
    put_ bh DNByte = do
	    putByte bh 0
    put_ bh DNBool = do
	    putByte bh 1
    put_ bh DNChar = do
	    putByte bh 2
    put_ bh DNDouble = do
	    putByte bh 3
    put_ bh DNFloat = do
	    putByte bh 4
    put_ bh DNInt = do
	    putByte bh 5
    put_ bh DNInt8 = do
	    putByte bh 6
    put_ bh DNInt16 = do
	    putByte bh 7
    put_ bh DNInt32 = do
	    putByte bh 8
    put_ bh DNInt64 = do
	    putByte bh 9
    put_ bh DNWord8 = do
	    putByte bh 10
    put_ bh DNWord16 = do
	    putByte bh 11
    put_ bh DNWord32 = do
	    putByte bh 12
    put_ bh DNWord64 = do
	    putByte bh 13
    put_ bh DNPtr = do
	    putByte bh 14
    put_ bh DNUnit = do
	    putByte bh 15
    put_ bh DNObject = do
	    putByte bh 16
    put_ bh DNString = do
	    putByte bh 17

    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> return DNByte
	      1 -> return DNBool
	      2 -> return DNChar
  	      3 -> return DNDouble
  	      4 -> return DNFloat
  	      5 -> return DNInt
  	      6 -> return DNInt8
  	      7 -> return DNInt16
  	      8 -> return DNInt32
	      9 -> return DNInt64
	      10 -> return DNWord8
	      11 -> return DNWord16
	      12 -> return DNWord32
	      13 -> return DNWord64
	      14 -> return DNPtr
	      15 -> return DNUnit
	      16 -> return DNObject
	      17 -> return DNString

--  Imported from other files :-

\end{code}