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