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,
16 CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,
18 DNCallSpec(..), DNKind(..), DNType(..),
22 #include "HsVersions.h"
24 import CStrings ( CLabelString, pprCLabelString )
25 import FastString ( FastString )
31 %************************************************************************
33 \subsubsection{Data types}
35 %************************************************************************
41 deriving( Eq ) -- We compare them when seeing if an interface
42 -- has changed (for versioning purposes)
43 {-! derive: Binary !-}
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 ppr (DNCall dn) = ppr dn
55 = PlaySafe -- Might invoke Haskell GC, or do a call back, or
56 -- switch threads, etc. So make sure things are
57 -- tidy before the call
58 Bool -- => True, external function is also re-entrant.
59 -- [if supported, RTS arranges for the external call
60 -- to be executed by a separate OS thread, i.e.,
61 -- _concurrently_ to the execution of other Haskell threads.]
63 | PlayRisky -- None of the above can happen; the call will return
64 -- without interacting with the runtime system at all
66 -- Show used just for Show Lex.Token, I think
67 {-! derive: Binary !-}
69 instance Outputable Safety where
70 ppr (PlaySafe False) = ptext SLIT("safe")
71 ppr (PlaySafe True) = ptext SLIT("threadsafe")
72 ppr PlayRisky = ptext SLIT("unsafe")
74 playSafe :: Safety -> Bool
75 playSafe PlaySafe{} = True
76 playSafe PlayRisky = False
78 playThreadSafe :: Safety -> Bool
79 playThreadSafe (PlaySafe x) = x
80 playThreadSafe _ = False
84 %************************************************************************
86 \subsubsection{Calling C}
88 %************************************************************************
92 = CExportStatic -- foreign export ccall foo :: ty
93 CLabelString -- C Name of exported function
95 {-! derive: Binary !-}
98 = CCallSpec CCallTarget -- What to call
99 CCallConv -- Calling convention to use.
102 {-! derive: Binary !-}
109 = StaticTarget CLabelString -- An "unboxed" ccall# to `fn'.
110 | DynamicTarget -- First argument (an Addr#) is the function pointer
112 {-! derive: Binary !-}
114 isDynamicTarget :: CCallTarget -> Bool
115 isDynamicTarget DynamicTarget = True
116 isDynamicTarget other = False
120 Stuff to do with calling convention:
122 ccall: Caller allocates parameters, *and* deallocates them.
124 stdcall: Caller allocates parameters, callee deallocates.
125 Function name has @N after it, where N is number of arg bytes
128 ToDo: The stdcall calling convention is x86 (win32) specific,
129 so perhaps we should emit a warning if it's being used on other
133 data CCallConv = CCallConv | StdCallConv
135 {-! derive: Binary !-}
137 instance Outputable CCallConv where
138 ppr StdCallConv = ptext SLIT("stdcall")
139 ppr CCallConv = ptext SLIT("ccall")
141 defaultCCallConv :: CCallConv
142 defaultCCallConv = CCallConv
144 ccallConvToInt :: CCallConv -> Int
145 ccallConvToInt StdCallConv = 0
146 ccallConvToInt CCallConv = 1
149 Generate the gcc attribute corresponding to the given
150 calling convention (used by PprAbsC):
153 ccallConvAttribute :: CCallConv -> String
154 ccallConvAttribute StdCallConv = "__stdcall"
155 ccallConvAttribute CCallConv = ""
158 Printing into C files:
161 instance Outputable CExportSpec where
162 ppr (CExportStatic str _) = pprCLabelString str
164 instance Outputable CCallSpec where
165 ppr (CCallSpec fun cconv safety)
166 = hcat [ ifPprDebug callconv, ppr_fun fun ]
168 callconv = text "{-" <> ppr cconv <> text "-}"
170 gc_suf | playSafe safety = text "_GC"
173 ppr_fun DynamicTarget = text "__dyn_ccall" <> gc_suf <+> text "\"\""
174 ppr_fun (StaticTarget fn) = text "__ccall" <> gc_suf <+> pprCLabelString fn
178 %************************************************************************
180 \subsubsection{.NET interop}
182 %************************************************************************
186 DNCallSpec Bool -- True => static method/field
187 DNKind -- what type of access
189 String -- fully qualified method/field name.
190 [DNType] -- argument types.
191 DNType -- result type.
193 {-! derive: Binary !-}
200 {-! derive: Binary !-}
222 {-! derive: Binary !-}
224 withDNTypes :: DNCallSpec -> [DNType] -> DNType -> DNCallSpec
225 withDNTypes (DNCallSpec isStatic k assem nm _ _) argTys resTy
226 = DNCallSpec isStatic k assem nm argTys resTy
228 instance Outputable DNCallSpec where
229 ppr (DNCallSpec isStatic kind ass nm _ _ )
231 (if isStatic then text "static" else empty) <+>
232 (text (case kind of { DNMethod -> "method" ; DNField -> "field"; DNConstructor -> "ctor" })) <+>
233 (if null ass then char ' ' else char '[' <> text ass <> char ']') <>
240 %************************************************************************
244 %************************************************************************
247 {-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
248 instance Binary ForeignCall where
249 put_ bh (CCall aa) = do
252 put_ bh (DNCall ab) = do
263 instance Binary Safety where
264 put_ bh (PlaySafe aa) = do
267 put_ bh PlayRisky = do
274 _ -> do return PlayRisky
276 instance Binary CExportSpec where
277 put_ bh (CExportStatic aa ab) = do
283 return (CExportStatic aa ab)
285 instance Binary CCallSpec where
286 put_ bh (CCallSpec aa ab ac) = do
294 return (CCallSpec aa ab ac)
296 instance Binary CCallTarget where
297 put_ bh (StaticTarget aa) = do
300 put_ bh DynamicTarget = do
306 return (StaticTarget aa)
307 _ -> do return DynamicTarget
309 instance Binary CCallConv where
310 put_ bh CCallConv = do
312 put_ bh StdCallConv = do
317 0 -> do return CCallConv
318 _ -> do return StdCallConv
320 instance Binary DNCallSpec where
321 put_ bh (DNCallSpec isStatic kind ass nm _ _) = do
331 return (DNCallSpec isStatic kind ass nm [] undefined)
333 instance Binary DNKind where
334 put_ bh DNMethod = do
338 put_ bh DNConstructor = do
343 0 -> do return DNMethod
344 1 -> do return DNField
345 _ -> do return DNConstructor
347 instance Binary DNType where
354 put_ bh DNDouble = do
370 put_ bh DNWord16 = do
372 put_ bh DNWord32 = do
374 put_ bh DNWord64 = do
380 put_ bh DNObject = do
382 put_ bh DNString = do
399 11 -> return DNWord16
400 12 -> return DNWord32
401 13 -> return DNWord64
404 16 -> return DNObject
405 17 -> return DNString
407 -- Imported from other files :-