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