Produce new-style Cmm from the Cmm parser
[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 | PrimCallConv
160   deriving (Eq, Data, Typeable)
161   {-! derive: Binary !-}
162
163 instance Outputable CCallConv where
164   ppr StdCallConv = ptext (sLit "stdcall")
165   ppr CCallConv   = ptext (sLit "ccall")
166   ppr CApiConv    = ptext (sLit "capi")
167   ppr PrimCallConv = ptext (sLit "prim")
168
169 defaultCCallConv :: CCallConv
170 defaultCCallConv = CCallConv
171
172 ccallConvToInt :: CCallConv -> Int
173 ccallConvToInt StdCallConv = 0
174 ccallConvToInt CCallConv   = 1
175 ccallConvToInt CApiConv    = panic "ccallConvToInt CApiConv"
176 ccallConvToInt (PrimCallConv {}) = panic "ccallConvToInt PrimCallConv"
177 \end{code}
178
179 Generate the gcc attribute corresponding to the given
180 calling convention (used by PprAbsC):
181
182 \begin{code}
183 ccallConvAttribute :: CCallConv -> SDoc
184 ccallConvAttribute StdCallConv       = text "__attribute__((__stdcall__))"
185 ccallConvAttribute CCallConv         = empty
186 ccallConvAttribute CApiConv          = empty
187 ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv"
188 \end{code}
189
190 \begin{code}
191 type CLabelString = FastString          -- A C label, completely unencoded
192
193 pprCLabelString :: CLabelString -> SDoc
194 pprCLabelString lbl = ftext lbl
195
196 isCLabelString :: CLabelString -> Bool  -- Checks to see if this is a valid C label
197 isCLabelString lbl
198   = all ok (unpackFS lbl)
199   where
200     ok c = isAlphaNum c || c == '_' || c == '.'
201         -- The '.' appears in e.g. "foo.so" in the
202         -- module part of a ExtName.  Maybe it should be separate
203 \end{code}
204
205
206 Printing into C files:
207
208 \begin{code}
209 instance Outputable CExportSpec where
210   ppr (CExportStatic str _) = pprCLabelString str
211
212 instance Outputable CCallSpec where
213   ppr (CCallSpec fun cconv safety)
214     = hcat [ ifPprDebug callconv, ppr_fun fun ]
215     where
216       callconv = text "{-" <> ppr cconv <> text "-}"
217
218       gc_suf | playSafe safety = text "_GC"
219              | otherwise       = empty
220
221       ppr_fun (StaticTarget fn mPkgId isFun)
222         = text (if isFun then "__pkg_ccall"
223                          else "__pkg_ccall_value")
224        <> gc_suf
225        <+> (case mPkgId of
226             Nothing -> empty
227             Just pkgId -> ppr pkgId)
228        <+> pprCLabelString fn
229
230       ppr_fun DynamicTarget
231         = text "__dyn_ccall" <> gc_suf <+> text "\"\""
232 \end{code}
233
234 \begin{code}
235 -- The filename for a C header file
236 newtype Header = Header FastString
237     deriving (Eq, Data, Typeable)
238
239 instance Outputable Header where
240     ppr (Header h) = quotes $ ppr h
241
242 -- | A C type, used in CAPI FFI calls
243 data CType = CType (Maybe Header) -- header to include for this type
244                    FastString     -- the type itself
245     deriving (Data, Typeable)
246
247 instance Outputable CType where
248     ppr (CType mh ct) = hDoc <+> ftext ct
249         where hDoc = case mh of
250                      Nothing -> empty
251                      Just h -> ppr h
252 \end{code}
253
254
255 %************************************************************************
256 %*                                                                      *
257 \subsubsection{Misc}
258 %*                                                                      *
259 %************************************************************************
260
261 \begin{code}
262 {-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
263 instance Binary ForeignCall where
264     put_ bh (CCall aa) = put_ bh aa
265     get bh = do aa <- get bh; return (CCall aa)
266
267 instance Binary Safety where
268     put_ bh PlaySafe = do
269             putByte bh 0
270     put_ bh PlayInterruptible = do
271             putByte bh 1
272     put_ bh PlayRisky = do
273             putByte bh 2
274     get bh = do
275             h <- getByte bh
276             case h of
277               0 -> do return PlaySafe
278               1 -> do return PlayInterruptible
279               _ -> do return PlayRisky
280
281 instance Binary CExportSpec where
282     put_ bh (CExportStatic aa ab) = do
283             put_ bh aa
284             put_ bh ab
285     get bh = do
286           aa <- get bh
287           ab <- get bh
288           return (CExportStatic aa ab)
289
290 instance Binary CCallSpec where
291     put_ bh (CCallSpec aa ab ac) = do
292             put_ bh aa
293             put_ bh ab
294             put_ bh ac
295     get bh = do
296           aa <- get bh
297           ab <- get bh
298           ac <- get bh
299           return (CCallSpec aa ab ac)
300
301 instance Binary CCallTarget where
302     put_ bh (StaticTarget aa ab ac) = do
303             putByte bh 0
304             put_ bh aa
305             put_ bh ab
306             put_ bh ac
307     put_ bh DynamicTarget = do
308             putByte bh 1
309     get bh = do
310             h <- getByte bh
311             case h of
312               0 -> do aa <- get bh
313                       ab <- get bh
314                       ac <- get bh
315                       return (StaticTarget aa ab ac)
316               _ -> do return DynamicTarget
317
318 instance Binary CCallConv where
319     put_ bh CCallConv = do
320             putByte bh 0
321     put_ bh StdCallConv = do
322             putByte bh 1
323     put_ bh PrimCallConv = do
324             putByte bh 2
325     put_ bh CApiConv = do
326             putByte bh 3
327     get bh = do
328             h <- getByte bh
329             case h of
330               0 -> do return CCallConv
331               1 -> do return StdCallConv
332               2 -> do return PrimCallConv
333               _ -> do return CApiConv
334
335 instance Binary CType where
336     put_ bh (CType mh fs) = do put_ bh mh
337                                put_ bh fs
338     get bh = do mh <- get bh
339                 fs <- get bh
340                 return (CType mh fs)
341
342 instance Binary Header where
343     put_ bh (Header h) = put_ bh h
344     get bh = do h <- get bh
345                 return (Header h)
346 \end{code}