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,
23 #include "HsVersions.h"
25 import CStrings ( CLabelString, pprCLabelString )
26 import FastString ( FastString )
32 %************************************************************************
34 \subsubsection{Data types}
36 %************************************************************************
42 deriving( Eq ) -- We compare them when seeing if an interface
43 -- has changed (for versioning purposes)
44 {-! derive: Binary !-}
46 -- We may need more clues to distinguish foreign calls
47 -- but this simple printer will do for now
48 instance Outputable ForeignCall where
49 ppr (CCall cc) = ppr cc
50 ppr (DNCall dn) = ppr dn
56 = PlaySafe -- Might invoke Haskell GC, or do a call back, or
57 -- switch threads, etc. So make sure things are
58 -- tidy before the call
59 Bool -- => True, external function is also re-entrant.
60 -- [if supported, RTS arranges for the external call
61 -- to be executed by a separate OS thread, i.e.,
62 -- _concurrently_ to the execution of other Haskell threads.]
64 | PlayRisky -- None of the above can happen; the call will return
65 -- without interacting with the runtime system at all
67 -- Show used just for Show Lex.Token, I think
68 {-! derive: Binary !-}
70 instance Outputable Safety where
71 ppr (PlaySafe False) = ptext SLIT("safe")
72 ppr (PlaySafe True) = ptext SLIT("threadsafe")
73 ppr PlayRisky = ptext SLIT("unsafe")
75 playSafe :: Safety -> Bool
76 playSafe PlaySafe{} = True
77 playSafe PlayRisky = False
79 playThreadSafe :: Safety -> Bool
80 playThreadSafe (PlaySafe x) = x
81 playThreadSafe _ = False
85 %************************************************************************
87 \subsubsection{Calling C}
89 %************************************************************************
93 = CExportStatic -- foreign export ccall foo :: ty
94 CLabelString -- C Name of exported function
96 {-! derive: Binary !-}
99 = CCallSpec CCallTarget -- What to call
100 CCallConv -- Calling convention to use.
103 {-! derive: Binary !-}
110 = StaticTarget CLabelString -- An "unboxed" ccall# to `fn'.
111 | DynamicTarget -- First argument (an Addr#) is the function pointer
112 | CasmTarget CLabelString -- Inline C code (now seriously deprecated)
114 {-! derive: Binary !-}
116 isDynamicTarget, isCasmTarget :: CCallTarget -> Bool
117 isDynamicTarget DynamicTarget = True
118 isDynamicTarget other = False
120 isCasmTarget (CasmTarget _) = True
121 isCasmTarget other = False
125 Stuff to do with calling convention:
127 ccall: Caller allocates parameters, *and* deallocates them.
129 stdcall: Caller allocates parameters, callee deallocates.
130 Function name has @N after it, where N is number of arg bytes
133 ToDo: The stdcall calling convention is x86 (win32) specific,
134 so perhaps we should emit a warning if it's being used on other
138 data CCallConv = CCallConv | StdCallConv
140 {-! derive: Binary !-}
142 instance Outputable CCallConv where
143 ppr StdCallConv = ptext SLIT("stdcall")
144 ppr CCallConv = ptext SLIT("ccall")
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 = "__stdcall"
160 ccallConvAttribute CCallConv = ""
163 Printing into C files:
166 instance Outputable CExportSpec where
167 ppr (CExportStatic str _) = pprCLabelString str
169 instance Outputable CCallSpec where
170 ppr (CCallSpec fun cconv safety)
171 = hcat [ ifPprDebug callconv, ppr_fun fun ]
173 callconv = text "{-" <> ppr cconv <> text "-}"
175 gc_suf | playSafe safety = text "_GC"
178 ppr_fun DynamicTarget = text "__dyn_ccall" <> gc_suf <+> text "\"\""
179 ppr_fun (StaticTarget fn) = text "__ccall" <> gc_suf <+> pprCLabelString fn
180 ppr_fun (CasmTarget fn) = text "__casm" <> gc_suf <+> text "``" <> pprCLabelString fn <> text "''"
184 %************************************************************************
186 \subsubsection{.NET stuff}
188 %************************************************************************
191 data DNCallSpec = DNCallSpec FastString
193 {-! derive: Binary !-}
195 instance Outputable DNCallSpec where
196 ppr (DNCallSpec s) = char '"' <> ptext s <> char '"'
201 %************************************************************************
205 %************************************************************************
208 okToExposeFCall :: ForeignCall -> Bool
209 -- OK to unfold a Foreign Call in an interface file
210 -- Yes, unless it's a _casm_
211 okToExposeFCall (CCall (CCallSpec target _ _)) = not (isCasmTarget target)
212 okToExposeFCall other = True
215 {-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
216 instance Binary ForeignCall where
217 put_ bh (CCall aa) = do
220 put_ bh (DNCall ab) = do
231 instance Binary Safety where
232 put_ bh (PlaySafe aa) = do
235 put_ bh PlayRisky = do
242 _ -> do return PlayRisky
244 instance Binary CExportSpec where
245 put_ bh (CExportStatic aa ab) = do
251 return (CExportStatic aa ab)
253 instance Binary CCallSpec where
254 put_ bh (CCallSpec aa ab ac) = do
262 return (CCallSpec aa ab ac)
264 instance Binary CCallTarget where
265 put_ bh (StaticTarget aa) = do
268 put_ bh DynamicTarget = do
270 put_ bh (CasmTarget ab) = do
277 return (StaticTarget aa)
278 1 -> do return DynamicTarget
280 return (CasmTarget ab)
282 instance Binary CCallConv where
283 put_ bh CCallConv = do
285 put_ bh StdCallConv = do
290 0 -> do return CCallConv
291 _ -> do return StdCallConv
293 instance Binary DNCallSpec where
294 put_ bh (DNCallSpec aa) = do
298 return (DNCallSpec aa)
300 -- Imported from other files :-