2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[Foreign]{Foreign calls}
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
18 CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
20 CCallTarget(..), isDynamicTarget,
21 CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,
23 DNCallSpec(..), DNKind(..), DNType(..),
28 import Char ( isAlphaNum )
34 %************************************************************************
36 \subsubsection{Data types}
38 %************************************************************************
44 deriving( Eq ) -- We compare them when seeing if an interface
45 -- has changed (for versioning purposes)
46 {-! derive: Binary !-}
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
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. Additionally, in the threaded
61 -- RTS we arrange for the external call to be executed
62 -- by a separate OS thread, i.e., _concurrently_ to the
63 -- execution of other Haskell threads.
65 Bool -- Indicates the deprecated "threadsafe" annotation
66 -- which is now an alias for "safe". This information
67 -- is never used except to emit a deprecation warning.
69 | PlayRisky -- None of the above can happen; the call will return
70 -- without interacting with the runtime system at all
72 -- Show used just for Show Lex.Token, I think
73 {-! derive: Binary !-}
75 instance Outputable Safety where
76 ppr (PlaySafe False) = ptext (sLit "safe")
77 ppr (PlaySafe True) = ptext (sLit "threadsafe")
78 ppr PlayRisky = ptext (sLit "unsafe")
80 playSafe :: Safety -> Bool
81 playSafe PlaySafe{} = True
82 playSafe PlayRisky = 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
114 {-! derive: Binary !-}
116 isDynamicTarget :: CCallTarget -> Bool
117 isDynamicTarget DynamicTarget = True
118 isDynamicTarget _ = False
122 Stuff to do with calling convention:
124 ccall: Caller allocates parameters, *and* deallocates them.
126 stdcall: Caller allocates parameters, callee deallocates.
127 Function name has @N after it, where N is number of arg bytes
130 ToDo: The stdcall calling convention is x86 (win32) specific,
131 so perhaps we should emit a warning if it's being used on other
134 See: http://www.programmersheaven.com/2/Calling-conventions
137 data CCallConv = CCallConv | StdCallConv | CmmCallConv
139 {-! derive: Binary !-}
141 instance Outputable CCallConv where
142 ppr StdCallConv = ptext (sLit "stdcall")
143 ppr CCallConv = ptext (sLit "ccall")
144 ppr CmmCallConv = ptext (sLit "C--")
146 defaultCCallConv :: CCallConv
147 defaultCCallConv = CCallConv
149 ccallConvToInt :: CCallConv -> Int
150 ccallConvToInt StdCallConv = 0
151 ccallConvToInt CCallConv = 1
154 Generate the gcc attribute corresponding to the given
155 calling convention (used by PprAbsC):
158 ccallConvAttribute :: CCallConv -> String
159 ccallConvAttribute StdCallConv = "__attribute__((__stdcall__))"
160 ccallConvAttribute CCallConv = ""
164 type CLabelString = FastString -- A C label, completely unencoded
166 pprCLabelString :: CLabelString -> SDoc
167 pprCLabelString lbl = ftext lbl
169 isCLabelString :: CLabelString -> Bool -- Checks to see if this is a valid C label
171 = all ok (unpackFS lbl)
173 ok c = isAlphaNum c || c == '_' || c == '.'
174 -- The '.' appears in e.g. "foo.so" in the
175 -- module part of a ExtName. Maybe it should be separate
179 Printing into C files:
182 instance Outputable CExportSpec where
183 ppr (CExportStatic str _) = pprCLabelString str
185 instance Outputable CCallSpec where
186 ppr (CCallSpec fun cconv safety)
187 = hcat [ ifPprDebug callconv, ppr_fun fun ]
189 callconv = text "{-" <> ppr cconv <> text "-}"
191 gc_suf | playSafe safety = text "_GC"
194 ppr_fun DynamicTarget = text "__dyn_ccall" <> gc_suf <+> text "\"\""
195 ppr_fun (StaticTarget fn) = text "__ccall" <> gc_suf <+> pprCLabelString fn
199 %************************************************************************
201 \subsubsection{.NET interop}
203 %************************************************************************
207 DNCallSpec Bool -- True => static method/field
208 DNKind -- what type of access
210 String -- fully qualified method/field name.
211 [DNType] -- argument types.
212 DNType -- result type.
214 {-! derive: Binary !-}
221 {-! derive: Binary !-}
243 {-! derive: Binary !-}
245 withDNTypes :: DNCallSpec -> [DNType] -> DNType -> DNCallSpec
246 withDNTypes (DNCallSpec isStatic k assem nm _ _) argTys resTy
247 = DNCallSpec isStatic k assem nm argTys resTy
249 instance Outputable DNCallSpec where
250 ppr (DNCallSpec isStatic kind ass nm _ _ )
252 (if isStatic then text "static" else empty) <+>
253 (text (case kind of { DNMethod -> "method" ; DNField -> "field"; DNConstructor -> "ctor" })) <+>
254 (if null ass then char ' ' else char '[' <> text ass <> char ']') <>
261 %************************************************************************
265 %************************************************************************
268 {-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
269 instance Binary ForeignCall where
270 put_ bh (CCall aa) = do
273 put_ bh (DNCall ab) = do
284 instance Binary Safety where
285 put_ bh (PlaySafe aa) = do
288 put_ bh PlayRisky = do
295 _ -> do return PlayRisky
297 instance Binary CExportSpec where
298 put_ bh (CExportStatic aa ab) = do
304 return (CExportStatic aa ab)
306 instance Binary CCallSpec where
307 put_ bh (CCallSpec aa ab ac) = do
315 return (CCallSpec aa ab ac)
317 instance Binary CCallTarget where
318 put_ bh (StaticTarget aa) = do
321 put_ bh DynamicTarget = do
327 return (StaticTarget aa)
328 _ -> do return DynamicTarget
330 instance Binary CCallConv where
331 put_ bh CCallConv = do
333 put_ bh StdCallConv = do
338 0 -> do return CCallConv
339 _ -> do return StdCallConv
341 instance Binary DNCallSpec where
342 put_ bh (DNCallSpec isStatic kind ass nm _ _) = do
352 return (DNCallSpec isStatic kind ass nm [] undefined)
354 instance Binary DNKind where
355 put_ bh DNMethod = do
359 put_ bh DNConstructor = do
364 0 -> do return DNMethod
365 1 -> do return DNField
366 _ -> do return DNConstructor
368 instance Binary DNType where
375 put_ bh DNDouble = do
391 put_ bh DNWord16 = do
393 put_ bh DNWord32 = do
395 put_ bh DNWord64 = do
401 put_ bh DNObject = do
403 put_ bh DNString = do
420 11 -> return DNWord16
421 12 -> return DNWord32
422 13 -> return DNWord64
425 16 -> return DNObject
426 17 -> return DNString
428 -- Imported from other files :-