1 {-% DrIFT (Automatic class derivations for Haskell) v1.1 %-}
2 {-% DrIFT (Automatic class derivations for Haskell) v1.1 %-}
4 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 \section[Foreign]{Foreign calls}
11 Safety(..), playSafe, playThreadSafe,
15 CCallTarget(..), isDynamicTarget, isCasmTarget,
16 CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,
18 DNCallSpec(..), DNKind(..), DNType(..),
24 #include "HsVersions.h"
26 import CStrings ( CLabelString, pprCLabelString )
27 import FastString ( FastString )
33 %************************************************************************
35 \subsubsection{Data types}
37 %************************************************************************
43 deriving( Eq ) -- We compare them when seeing if an interface
44 -- has changed (for versioning purposes)
45 {-! derive: Binary !-}
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 ppr (DNCall dn) = ppr dn
57 = PlaySafe -- Might invoke Haskell GC, or do a call back, or
58 -- switch threads, etc. So make sure things are
59 -- tidy before the call
60 Bool -- => True, external function is also re-entrant.
61 -- [if supported, RTS arranges for the external call
62 -- to be executed by a separate OS thread, i.e.,
63 -- _concurrently_ to the execution of other Haskell threads.]
65 | PlayRisky -- None of the above can happen; the call will return
66 -- without interacting with the runtime system at all
68 -- Show used just for Show Lex.Token, I think
69 {-! derive: Binary !-}
71 instance Outputable Safety where
72 ppr (PlaySafe False) = ptext SLIT("safe")
73 ppr (PlaySafe True) = ptext SLIT("threadsafe")
74 ppr PlayRisky = ptext SLIT("unsafe")
76 playSafe :: Safety -> Bool
77 playSafe PlaySafe{} = True
78 playSafe PlayRisky = False
80 playThreadSafe :: Safety -> Bool
81 playThreadSafe (PlaySafe x) = x
82 playThreadSafe _ = False
86 %************************************************************************
88 \subsubsection{Calling C}
90 %************************************************************************
94 = CExportStatic -- foreign export ccall foo :: ty
95 CLabelString -- C Name of exported function
97 {-! derive: Binary !-}
100 = CCallSpec CCallTarget -- What to call
101 CCallConv -- Calling convention to use.
104 {-! derive: Binary !-}
111 = StaticTarget CLabelString -- An "unboxed" ccall# to `fn'.
112 | DynamicTarget -- First argument (an Addr#) is the function pointer
113 | CasmTarget CLabelString -- Inline C code (now seriously deprecated)
115 {-! derive: Binary !-}
117 isDynamicTarget, isCasmTarget :: CCallTarget -> Bool
118 isDynamicTarget DynamicTarget = True
119 isDynamicTarget other = False
121 isCasmTarget (CasmTarget _) = True
122 isCasmTarget other = False
126 Stuff to do with calling convention:
128 ccall: Caller allocates parameters, *and* deallocates them.
130 stdcall: Caller allocates parameters, callee deallocates.
131 Function name has @N after it, where N is number of arg bytes
134 ToDo: The stdcall calling convention is x86 (win32) specific,
135 so perhaps we should emit a warning if it's being used on other
139 data CCallConv = CCallConv | StdCallConv
141 {-! derive: Binary !-}
143 instance Outputable CCallConv where
144 ppr StdCallConv = ptext SLIT("stdcall")
145 ppr CCallConv = ptext SLIT("ccall")
147 defaultCCallConv :: CCallConv
148 defaultCCallConv = CCallConv
150 ccallConvToInt :: CCallConv -> Int
151 ccallConvToInt StdCallConv = 0
152 ccallConvToInt CCallConv = 1
155 Generate the gcc attribute corresponding to the given
156 calling convention (used by PprAbsC):
159 ccallConvAttribute :: CCallConv -> String
160 ccallConvAttribute StdCallConv = "__stdcall"
161 ccallConvAttribute CCallConv = ""
164 Printing into C files:
167 instance Outputable CExportSpec where
168 ppr (CExportStatic str _) = pprCLabelString str
170 instance Outputable CCallSpec where
171 ppr (CCallSpec fun cconv safety)
172 = hcat [ ifPprDebug callconv, ppr_fun fun ]
174 callconv = text "{-" <> ppr cconv <> text "-}"
176 gc_suf | playSafe safety = text "_GC"
179 ppr_fun DynamicTarget = text "__dyn_ccall" <> gc_suf <+> text "\"\""
180 ppr_fun (StaticTarget fn) = text "__ccall" <> gc_suf <+> pprCLabelString fn
181 ppr_fun (CasmTarget fn) = text "__casm" <> gc_suf <+> text "``" <> pprCLabelString fn <> text "''"
185 %************************************************************************
187 \subsubsection{.NET interop}
189 %************************************************************************
193 DNCallSpec Bool -- True => static method/field
194 DNKind -- what type of access
196 String -- fully qualified method/field name.
197 [DNType] -- argument types.
198 DNType -- result type.
200 {-! derive: Binary !-}
207 {-! derive: Binary !-}
229 {-! derive: Binary !-}
231 withDNTypes :: DNCallSpec -> [DNType] -> DNType -> DNCallSpec
232 withDNTypes (DNCallSpec isStatic k assem nm _ _) argTys resTy
233 = DNCallSpec isStatic k assem nm argTys resTy
235 instance Outputable DNCallSpec where
236 ppr (DNCallSpec isStatic kind ass nm _ _ )
238 (if isStatic then text "static" else empty) <+>
239 (text (case kind of { DNMethod -> "method" ; DNField -> "field"; DNConstructor -> "ctor" })) <+>
240 (if null ass then char ' ' else char '[' <> text ass <> char ']') <>
247 %************************************************************************
251 %************************************************************************
254 okToExposeFCall :: ForeignCall -> Bool
255 -- OK to unfold a Foreign Call in an interface file
256 -- Yes, unless it's a _casm_
257 okToExposeFCall (CCall (CCallSpec target _ _)) = not (isCasmTarget target)
258 okToExposeFCall other = True
261 {-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
262 instance Binary ForeignCall where
263 put_ bh (CCall aa) = do
266 put_ bh (DNCall ab) = do
277 instance Binary Safety where
278 put_ bh (PlaySafe aa) = do
281 put_ bh PlayRisky = do
288 _ -> do return PlayRisky
290 instance Binary CExportSpec where
291 put_ bh (CExportStatic aa ab) = do
297 return (CExportStatic aa ab)
299 instance Binary CCallSpec where
300 put_ bh (CCallSpec aa ab ac) = do
308 return (CCallSpec aa ab ac)
310 instance Binary CCallTarget where
311 put_ bh (StaticTarget aa) = do
314 put_ bh DynamicTarget = do
316 put_ bh (CasmTarget ab) = do
323 return (StaticTarget aa)
324 1 -> do return DynamicTarget
326 return (CasmTarget ab)
328 instance Binary CCallConv where
329 put_ bh CCallConv = do
331 put_ bh StdCallConv = do
336 0 -> do return CCallConv
337 _ -> do return StdCallConv
339 instance Binary DNCallSpec where
340 put_ bh (DNCallSpec isStatic kind ass nm _ _) = do
350 return (DNCallSpec isStatic kind ass nm [] undefined)
352 instance Binary DNKind where
353 put_ bh DNMethod = do
357 put_ bh DNConstructor = do
362 0 -> do return DNMethod
363 1 -> do return DNField
364 _ -> do return DNConstructor
366 instance Binary DNType where
373 put_ bh DNDouble = do
389 put_ bh DNWord16 = do
391 put_ bh DNWord32 = do
393 put_ bh DNWord64 = do
399 put_ bh DNObject = do
401 put_ bh DNString = do
418 11 -> return DNWord16
419 12 -> return DNWord32
420 13 -> return DNWord64
423 16 -> return DNObject
424 17 -> return DNString
426 -- Imported from other files :-