Add debugPprType
[ghc.git] / compiler / prelude / ForeignCall.hs
1 {-
2 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3
4 \section[Foreign]{Foreign calls}
5 -}
6
7 {-# LANGUAGE DeriveDataTypeable #-}
8
9 module ForeignCall (
10 ForeignCall(..), isSafeForeignCall,
11 Safety(..), playSafe, playInterruptible,
12
13 CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
14 CCallSpec(..),
15 CCallTarget(..), isDynamicTarget,
16 CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,
17
18 Header(..), CType(..),
19 ) where
20
21 import FastString
22 import Binary
23 import Outputable
24 import Module
25 import BasicTypes ( SourceText, pprWithSourceText )
26
27 import Data.Char
28 import Data.Data
29
30 {-
31 ************************************************************************
32 * *
33 \subsubsection{Data types}
34 * *
35 ************************************************************************
36 -}
37
38 newtype ForeignCall = CCall CCallSpec
39 deriving Eq
40
41 isSafeForeignCall :: ForeignCall -> Bool
42 isSafeForeignCall (CCall (CCallSpec _ _ safe)) = playSafe safe
43
44 -- We may need more clues to distinguish foreign calls
45 -- but this simple printer will do for now
46 instance Outputable ForeignCall where
47 ppr (CCall cc) = ppr cc
48
49 data Safety
50 = PlaySafe -- Might invoke Haskell GC, or do a call back, or
51 -- switch threads, etc. So make sure things are
52 -- tidy before the call. Additionally, in the threaded
53 -- RTS we arrange for the external call to be executed
54 -- by a separate OS thread, i.e., _concurrently_ to the
55 -- execution of other Haskell threads.
56
57 | PlayInterruptible -- Like PlaySafe, but additionally
58 -- the worker thread running this foreign call may
59 -- be unceremoniously killed, so it must be scheduled
60 -- on an unbound thread.
61
62 | PlayRisky -- None of the above can happen; the call will return
63 -- without interacting with the runtime system at all
64 deriving ( Eq, Show, Data )
65 -- Show used just for Show Lex.Token, I think
66
67 instance Outputable Safety where
68 ppr PlaySafe = text "safe"
69 ppr PlayInterruptible = text "interruptible"
70 ppr PlayRisky = text "unsafe"
71
72 playSafe :: Safety -> Bool
73 playSafe PlaySafe = True
74 playSafe PlayInterruptible = True
75 playSafe PlayRisky = False
76
77 playInterruptible :: Safety -> Bool
78 playInterruptible PlayInterruptible = True
79 playInterruptible _ = False
80
81 {-
82 ************************************************************************
83 * *
84 \subsubsection{Calling C}
85 * *
86 ************************************************************************
87 -}
88
89 data CExportSpec
90 = CExportStatic -- foreign export ccall foo :: ty
91 SourceText -- of the CLabelString.
92 -- See note [Pragma source text] in BasicTypes
93 CLabelString -- C Name of exported function
94 CCallConv
95 deriving Data
96
97 data CCallSpec
98 = CCallSpec CCallTarget -- What to call
99 CCallConv -- Calling convention to use.
100 Safety
101 deriving( Eq )
102
103 -- The call target:
104
105 -- | How to call a particular function in C-land.
106 data CCallTarget
107 -- An "unboxed" ccall# to named function in a particular package.
108 = StaticTarget
109 SourceText -- of the CLabelString.
110 -- See note [Pragma source text] in BasicTypes
111 CLabelString -- C-land name of label.
112
113 (Maybe UnitId) -- What package the function is in.
114 -- If Nothing, then it's taken to be in the current package.
115 -- Note: This information is only used for PrimCalls on Windows.
116 -- See CLabel.labelDynamic and CoreToStg.coreToStgApp
117 -- for the difference in representation between PrimCalls
118 -- and ForeignCalls. If the CCallTarget is representing
119 -- a regular ForeignCall then it's safe to set this to Nothing.
120
121 -- The first argument of the import is the name of a function pointer (an Addr#).
122 -- Used when importing a label as "foreign import ccall "dynamic" ..."
123 Bool -- True => really a function
124 -- False => a value; only
125 -- allowed in CAPI imports
126 | DynamicTarget
127
128 deriving( Eq, Data )
129
130 isDynamicTarget :: CCallTarget -> Bool
131 isDynamicTarget DynamicTarget = True
132 isDynamicTarget _ = False
133
134 {-
135 Stuff to do with calling convention:
136
137 ccall: Caller allocates parameters, *and* deallocates them.
138
139 stdcall: Caller allocates parameters, callee deallocates.
140 Function name has @N after it, where N is number of arg bytes
141 e.g. _Foo@8. This convention is x86 (win32) specific.
142
143 See: http://www.programmersheaven.com/2/Calling-conventions
144 -}
145
146 -- any changes here should be replicated in the CallConv type in template haskell
147 data CCallConv = CCallConv | CApiConv | StdCallConv | PrimCallConv | JavaScriptCallConv
148 deriving (Eq, Data)
149
150 instance Outputable CCallConv where
151 ppr StdCallConv = text "stdcall"
152 ppr CCallConv = text "ccall"
153 ppr CApiConv = text "capi"
154 ppr PrimCallConv = text "prim"
155 ppr JavaScriptCallConv = text "javascript"
156
157 defaultCCallConv :: CCallConv
158 defaultCCallConv = CCallConv
159
160 ccallConvToInt :: CCallConv -> Int
161 ccallConvToInt StdCallConv = 0
162 ccallConvToInt CCallConv = 1
163 ccallConvToInt CApiConv = panic "ccallConvToInt CApiConv"
164 ccallConvToInt (PrimCallConv {}) = panic "ccallConvToInt PrimCallConv"
165 ccallConvToInt JavaScriptCallConv = panic "ccallConvToInt JavaScriptCallConv"
166
167 {-
168 Generate the gcc attribute corresponding to the given
169 calling convention (used by PprAbsC):
170 -}
171
172 ccallConvAttribute :: CCallConv -> SDoc
173 ccallConvAttribute StdCallConv = text "__attribute__((__stdcall__))"
174 ccallConvAttribute CCallConv = empty
175 ccallConvAttribute CApiConv = empty
176 ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv"
177 ccallConvAttribute JavaScriptCallConv = panic "ccallConvAttribute JavaScriptCallConv"
178
179 type CLabelString = FastString -- A C label, completely unencoded
180
181 pprCLabelString :: CLabelString -> SDoc
182 pprCLabelString lbl = ftext lbl
183
184 isCLabelString :: CLabelString -> Bool -- Checks to see if this is a valid C label
185 isCLabelString lbl
186 = all ok (unpackFS lbl)
187 where
188 ok c = isAlphaNum c || c == '_' || c == '.'
189 -- The '.' appears in e.g. "foo.so" in the
190 -- module part of a ExtName. Maybe it should be separate
191
192 -- Printing into C files:
193
194 instance Outputable CExportSpec where
195 ppr (CExportStatic _ str _) = pprCLabelString str
196
197 instance Outputable CCallSpec where
198 ppr (CCallSpec fun cconv safety)
199 = hcat [ whenPprDebug callconv, ppr_fun fun ]
200 where
201 callconv = text "{-" <> ppr cconv <> text "-}"
202
203 gc_suf | playSafe safety = text "_GC"
204 | otherwise = empty
205
206 ppr_fun (StaticTarget st _fn mPkgId isFun)
207 = text (if isFun then "__pkg_ccall"
208 else "__pkg_ccall_value")
209 <> gc_suf
210 <+> (case mPkgId of
211 Nothing -> empty
212 Just pkgId -> ppr pkgId)
213 <+> (pprWithSourceText st empty)
214
215 ppr_fun DynamicTarget
216 = text "__dyn_ccall" <> gc_suf <+> text "\"\""
217
218 -- The filename for a C header file
219 -- Note [Pragma source text] in BasicTypes
220 data Header = Header SourceText FastString
221 deriving (Eq, Data)
222
223 instance Outputable Header where
224 ppr (Header st h) = pprWithSourceText st (doubleQuotes $ ppr h)
225
226 -- | A C type, used in CAPI FFI calls
227 --
228 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CTYPE'@,
229 -- 'ApiAnnotation.AnnHeader','ApiAnnotation.AnnVal',
230 -- 'ApiAnnotation.AnnClose' @'\#-}'@,
231
232 -- For details on above see note [Api annotations] in ApiAnnotation
233 data CType = CType SourceText -- Note [Pragma source text] in BasicTypes
234 (Maybe Header) -- header to include for this type
235 (SourceText,FastString) -- the type itself
236 deriving (Eq, Data)
237
238 instance Outputable CType where
239 ppr (CType stp mh (stct,ct))
240 = pprWithSourceText stp (text "{-# CTYPE") <+> hDoc
241 <+> pprWithSourceText stct (doubleQuotes (ftext ct)) <+> text "#-}"
242 where hDoc = case mh of
243 Nothing -> empty
244 Just h -> ppr h
245
246 {-
247 ************************************************************************
248 * *
249 \subsubsection{Misc}
250 * *
251 ************************************************************************
252 -}
253
254 instance Binary ForeignCall where
255 put_ bh (CCall aa) = put_ bh aa
256 get bh = do aa <- get bh; return (CCall aa)
257
258 instance Binary Safety where
259 put_ bh PlaySafe = do
260 putByte bh 0
261 put_ bh PlayInterruptible = do
262 putByte bh 1
263 put_ bh PlayRisky = do
264 putByte bh 2
265 get bh = do
266 h <- getByte bh
267 case h of
268 0 -> do return PlaySafe
269 1 -> do return PlayInterruptible
270 _ -> do return PlayRisky
271
272 instance Binary CExportSpec where
273 put_ bh (CExportStatic ss aa ab) = do
274 put_ bh ss
275 put_ bh aa
276 put_ bh ab
277 get bh = do
278 ss <- get bh
279 aa <- get bh
280 ab <- get bh
281 return (CExportStatic ss aa ab)
282
283 instance Binary CCallSpec where
284 put_ bh (CCallSpec aa ab ac) = do
285 put_ bh aa
286 put_ bh ab
287 put_ bh ac
288 get bh = do
289 aa <- get bh
290 ab <- get bh
291 ac <- get bh
292 return (CCallSpec aa ab ac)
293
294 instance Binary CCallTarget where
295 put_ bh (StaticTarget ss aa ab ac) = do
296 putByte bh 0
297 put_ bh ss
298 put_ bh aa
299 put_ bh ab
300 put_ bh ac
301 put_ bh DynamicTarget = do
302 putByte bh 1
303 get bh = do
304 h <- getByte bh
305 case h of
306 0 -> do ss <- get bh
307 aa <- get bh
308 ab <- get bh
309 ac <- get bh
310 return (StaticTarget ss aa ab ac)
311 _ -> do return DynamicTarget
312
313 instance Binary CCallConv where
314 put_ bh CCallConv = do
315 putByte bh 0
316 put_ bh StdCallConv = do
317 putByte bh 1
318 put_ bh PrimCallConv = do
319 putByte bh 2
320 put_ bh CApiConv = do
321 putByte bh 3
322 put_ bh JavaScriptCallConv = do
323 putByte bh 4
324 get bh = do
325 h <- getByte bh
326 case h of
327 0 -> do return CCallConv
328 1 -> do return StdCallConv
329 2 -> do return PrimCallConv
330 3 -> do return CApiConv
331 _ -> do return JavaScriptCallConv
332
333 instance Binary CType where
334 put_ bh (CType s mh fs) = do put_ bh s
335 put_ bh mh
336 put_ bh fs
337 get bh = do s <- get bh
338 mh <- get bh
339 fs <- get bh
340 return (CType s mh fs)
341
342 instance Binary Header where
343 put_ bh (Header s h) = put_ bh s >> put_ bh h
344 get bh = do s <- get bh
345 h <- get bh
346 return (Header s h)