2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[Foreign]{Foreign calls}
9 Safety(..), playSafe, playThreadSafe,
11 CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
13 CCallTarget(..), isDynamicTarget,
14 CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,
16 DNCallSpec(..), DNKind(..), DNType(..),
20 #include "HsVersions.h"
22 import FastString ( FastString, unpackFS )
23 import Char ( isAlphaNum )
29 %************************************************************************
31 \subsubsection{Data types}
33 %************************************************************************
39 deriving( Eq ) -- We compare them when seeing if an interface
40 -- has changed (for versioning purposes)
41 {-! derive: Binary !-}
43 -- We may need more clues to distinguish foreign calls
44 -- but this simple printer will do for now
45 instance Outputable ForeignCall where
46 ppr (CCall cc) = ppr cc
47 ppr (DNCall dn) = ppr dn
53 = PlaySafe -- Might invoke Haskell GC, or do a call back, or
54 -- switch threads, etc. So make sure things are
55 -- tidy before the call
56 Bool -- => True, external function is also re-entrant.
57 -- [if supported, RTS arranges for the external call
58 -- to be executed by a separate OS thread, i.e.,
59 -- _concurrently_ to the execution of other Haskell threads.]
61 | PlayRisky -- None of the above can happen; the call will return
62 -- without interacting with the runtime system at all
64 -- Show used just for Show Lex.Token, I think
65 {-! derive: Binary !-}
67 instance Outputable Safety where
68 ppr (PlaySafe False) = ptext SLIT("safe")
69 ppr (PlaySafe True) = ptext SLIT("threadsafe")
70 ppr PlayRisky = ptext SLIT("unsafe")
72 playSafe :: Safety -> Bool
73 playSafe PlaySafe{} = True
74 playSafe PlayRisky = False
76 playThreadSafe :: Safety -> Bool
77 playThreadSafe (PlaySafe x) = x
78 playThreadSafe _ = False
82 %************************************************************************
84 \subsubsection{Calling C}
86 %************************************************************************
90 = CExportStatic -- foreign export ccall foo :: ty
91 CLabelString -- C Name of exported function
93 {-! derive: Binary !-}
96 = CCallSpec CCallTarget -- What to call
97 CCallConv -- Calling convention to use.
100 {-! derive: Binary !-}
107 = StaticTarget CLabelString -- An "unboxed" ccall# to `fn'.
108 | DynamicTarget -- First argument (an Addr#) is the function pointer
110 {-! derive: Binary !-}
112 isDynamicTarget :: CCallTarget -> Bool
113 isDynamicTarget DynamicTarget = True
114 isDynamicTarget other = False
118 Stuff to do with calling convention:
120 ccall: Caller allocates parameters, *and* deallocates them.
122 stdcall: Caller allocates parameters, callee deallocates.
123 Function name has @N after it, where N is number of arg bytes
126 ToDo: The stdcall calling convention is x86 (win32) specific,
127 so perhaps we should emit a warning if it's being used on other
131 data CCallConv = CCallConv | StdCallConv | CmmCallConv
133 {-! derive: Binary !-}
135 instance Outputable CCallConv where
136 ppr StdCallConv = ptext SLIT("stdcall")
137 ppr CCallConv = ptext SLIT("ccall")
138 ppr CmmCallConv = ptext SLIT("C--")
140 defaultCCallConv :: CCallConv
141 defaultCCallConv = CCallConv
143 ccallConvToInt :: CCallConv -> Int
144 ccallConvToInt StdCallConv = 0
145 ccallConvToInt CCallConv = 1
148 Generate the gcc attribute corresponding to the given
149 calling convention (used by PprAbsC):
152 ccallConvAttribute :: CCallConv -> String
153 ccallConvAttribute StdCallConv = "__attribute__((__stdcall__))"
154 ccallConvAttribute CCallConv = ""
158 type CLabelString = FastString -- A C label, completely unencoded
160 pprCLabelString :: CLabelString -> SDoc
161 pprCLabelString lbl = ftext lbl
163 isCLabelString :: CLabelString -> Bool -- Checks to see if this is a valid C label
165 = all ok (unpackFS lbl)
167 ok c = isAlphaNum c || c == '_' || c == '.'
168 -- The '.' appears in e.g. "foo.so" in the
169 -- module part of a ExtName. Maybe it should be separate
173 Printing into C files:
176 instance Outputable CExportSpec where
177 ppr (CExportStatic str _) = pprCLabelString str
179 instance Outputable CCallSpec where
180 ppr (CCallSpec fun cconv safety)
181 = hcat [ ifPprDebug callconv, ppr_fun fun ]
183 callconv = text "{-" <> ppr cconv <> text "-}"
185 gc_suf | playSafe safety = text "_GC"
188 ppr_fun DynamicTarget = text "__dyn_ccall" <> gc_suf <+> text "\"\""
189 ppr_fun (StaticTarget fn) = text "__ccall" <> gc_suf <+> pprCLabelString fn
193 %************************************************************************
195 \subsubsection{.NET interop}
197 %************************************************************************
201 DNCallSpec Bool -- True => static method/field
202 DNKind -- what type of access
204 String -- fully qualified method/field name.
205 [DNType] -- argument types.
206 DNType -- result type.
208 {-! derive: Binary !-}
215 {-! derive: Binary !-}
237 {-! derive: Binary !-}
239 withDNTypes :: DNCallSpec -> [DNType] -> DNType -> DNCallSpec
240 withDNTypes (DNCallSpec isStatic k assem nm _ _) argTys resTy
241 = DNCallSpec isStatic k assem nm argTys resTy
243 instance Outputable DNCallSpec where
244 ppr (DNCallSpec isStatic kind ass nm _ _ )
246 (if isStatic then text "static" else empty) <+>
247 (text (case kind of { DNMethod -> "method" ; DNField -> "field"; DNConstructor -> "ctor" })) <+>
248 (if null ass then char ' ' else char '[' <> text ass <> char ']') <>
255 %************************************************************************
259 %************************************************************************
262 {-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
263 instance Binary ForeignCall where
264 put_ bh (CCall aa) = do
267 put_ bh (DNCall ab) = do
278 instance Binary Safety where
279 put_ bh (PlaySafe aa) = do
282 put_ bh PlayRisky = do
289 _ -> do return PlayRisky
291 instance Binary CExportSpec where
292 put_ bh (CExportStatic aa ab) = do
298 return (CExportStatic aa ab)
300 instance Binary CCallSpec where
301 put_ bh (CCallSpec aa ab ac) = do
309 return (CCallSpec aa ab ac)
311 instance Binary CCallTarget where
312 put_ bh (StaticTarget aa) = do
315 put_ bh DynamicTarget = do
321 return (StaticTarget aa)
322 _ -> do return DynamicTarget
324 instance Binary CCallConv where
325 put_ bh CCallConv = do
327 put_ bh StdCallConv = do
332 0 -> do return CCallConv
333 _ -> do return StdCallConv
335 instance Binary DNCallSpec where
336 put_ bh (DNCallSpec isStatic kind ass nm _ _) = do
346 return (DNCallSpec isStatic kind ass nm [] undefined)
348 instance Binary DNKind where
349 put_ bh DNMethod = do
353 put_ bh DNConstructor = do
358 0 -> do return DNMethod
359 1 -> do return DNField
360 _ -> do return DNConstructor
362 instance Binary DNType where
369 put_ bh DNDouble = do
385 put_ bh DNWord16 = do
387 put_ bh DNWord32 = do
389 put_ bh DNWord64 = do
395 put_ bh DNObject = do
397 put_ bh DNString = do
414 11 -> return DNWord16
415 12 -> return DNWord32
416 13 -> return DNWord64
419 16 -> return DNObject
420 17 -> return DNString
422 -- Imported from other files :-