458e7c6747bcef067ed52e9fcbddfd0f68c10b3a
[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     ) where
18
19 import FastString
20 import Binary
21 import Outputable
22 import Module
23
24 import Data.Char
25 import Data.Data
26 \end{code}
27
28
29 %************************************************************************
30 %*                                                                      *
31 \subsubsection{Data types}
32 %*                                                                      *
33 %************************************************************************
34
35 \begin{code}
36 newtype ForeignCall = CCall CCallSpec
37   deriving Eq
38   {-! derive: Binary !-}
39
40 isSafeForeignCall :: ForeignCall -> Bool
41 isSafeForeignCall (CCall (CCallSpec _ _ safe)) = playSafe safe
42
43 -- We may need more clues to distinguish foreign calls
44 -- but this simple printer will do for now
45 instance Outputable ForeignCall where
46   ppr (CCall cc)  = ppr cc
47 \end{code}
48
49
50 \begin{code}
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, Typeable )
67         -- Show used just for Show Lex.Token, I think
68   {-! derive: Binary !-}
69
70 instance Outputable Safety where
71   ppr PlaySafe = ptext (sLit "safe")
72   ppr PlayInterruptible = ptext (sLit "interruptible")
73   ppr PlayRisky = ptext (sLit "unsafe")
74
75 playSafe :: Safety -> Bool
76 playSafe PlaySafe = True
77 playSafe PlayInterruptible = True
78 playSafe PlayRisky = False
79
80 playInterruptible :: Safety -> Bool
81 playInterruptible PlayInterruptible = True
82 playInterruptible _ = False
83 \end{code}
84
85
86 %************************************************************************
87 %*                                                                      *
88 \subsubsection{Calling C}
89 %*                                                                      *
90 %************************************************************************
91
92 \begin{code}
93 data CExportSpec
94   = CExportStatic               -- foreign export ccall foo :: ty
95         CLabelString            -- C Name of exported function
96         CCallConv
97   deriving (Data, Typeable)
98   {-! derive: Binary !-}
99
100 data CCallSpec
101   =  CCallSpec  CCallTarget     -- What to call
102                 CCallConv       -- Calling convention to use.
103                 Safety
104   deriving( Eq )
105   {-! derive: Binary !-}
106 \end{code}
107
108 The call target:
109
110 \begin{code}
111
112 -- | How to call a particular function in C-land.
113 data CCallTarget
114   -- An "unboxed" ccall# to named function in a particular package.
115   = StaticTarget
116         CLabelString                    -- C-land name of label.
117
118         (Maybe PackageId)               -- What package the function is in.
119                                         -- If Nothing, then it's taken to be in the current package.
120                                         -- Note: This information is only used for PrimCalls on Windows.
121                                         --       See CLabel.labelDynamic and CoreToStg.coreToStgApp
122                                         --       for the difference in representation between PrimCalls
123                                         --       and ForeignCalls. If the CCallTarget is representing
124                                         --       a regular ForeignCall then it's safe to set this to Nothing.
125
126   -- The first argument of the import is the name of a function pointer (an Addr#).
127   --    Used when importing a label as "foreign import ccall "dynamic" ..."
128   | DynamicTarget
129
130   deriving( Eq, Data, Typeable )
131   {-! derive: Binary !-}
132
133 isDynamicTarget :: CCallTarget -> Bool
134 isDynamicTarget DynamicTarget = True
135 isDynamicTarget _             = False
136 \end{code}
137
138
139 Stuff to do with calling convention:
140
141 ccall:          Caller allocates parameters, *and* deallocates them.
142
143 stdcall:        Caller allocates parameters, callee deallocates.
144                 Function name has @N after it, where N is number of arg bytes
145                 e.g.  _Foo@8
146
147 ToDo: The stdcall calling convention is x86 (win32) specific,
148 so perhaps we should emit a warning if it's being used on other
149 platforms.
150
151 See: http://www.programmersheaven.com/2/Calling-conventions
152
153 \begin{code}
154 data CCallConv = CCallConv | StdCallConv | CmmCallConv | PrimCallConv
155   deriving (Eq, Data, Typeable)
156   {-! derive: Binary !-}
157
158 instance Outputable CCallConv where
159   ppr StdCallConv = ptext (sLit "stdcall")
160   ppr CCallConv   = ptext (sLit "ccall")
161   ppr CmmCallConv = ptext (sLit "C--")
162   ppr PrimCallConv = ptext (sLit "prim")
163
164 defaultCCallConv :: CCallConv
165 defaultCCallConv = CCallConv
166
167 ccallConvToInt :: CCallConv -> Int
168 ccallConvToInt StdCallConv = 0
169 ccallConvToInt CCallConv   = 1
170 ccallConvToInt (CmmCallConv {})  = panic "ccallConvToInt CmmCallConv"
171 ccallConvToInt (PrimCallConv {}) = panic "ccallConvToInt PrimCallConv"
172 \end{code}
173
174 Generate the gcc attribute corresponding to the given
175 calling convention (used by PprAbsC):
176
177 \begin{code}
178 ccallConvAttribute :: CCallConv -> SDoc
179 ccallConvAttribute StdCallConv       = text "__attribute__((__stdcall__))"
180 ccallConvAttribute CCallConv         = empty
181 ccallConvAttribute (CmmCallConv {})  = panic "ccallConvAttribute CmmCallConv"
182 ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv"
183 \end{code}
184
185 \begin{code}
186 type CLabelString = FastString          -- A C label, completely unencoded
187
188 pprCLabelString :: CLabelString -> SDoc
189 pprCLabelString lbl = ftext lbl
190
191 isCLabelString :: CLabelString -> Bool  -- Checks to see if this is a valid C label
192 isCLabelString lbl
193   = all ok (unpackFS lbl)
194   where
195     ok c = isAlphaNum c || c == '_' || c == '.'
196         -- The '.' appears in e.g. "foo.so" in the
197         -- module part of a ExtName.  Maybe it should be separate
198 \end{code}
199
200
201 Printing into C files:
202
203 \begin{code}
204 instance Outputable CExportSpec where
205   ppr (CExportStatic str _) = pprCLabelString str
206
207 instance Outputable CCallSpec where
208   ppr (CCallSpec fun cconv safety)
209     = hcat [ ifPprDebug callconv, ppr_fun fun ]
210     where
211       callconv = text "{-" <> ppr cconv <> text "-}"
212
213       gc_suf | playSafe safety = text "_GC"
214              | otherwise       = empty
215
216       ppr_fun (StaticTarget fn Nothing)
217         = text "__pkg_ccall" <> gc_suf <+> pprCLabelString fn
218
219       ppr_fun (StaticTarget fn (Just pkgId))
220         = text "__pkg_ccall" <> gc_suf <+> ppr pkgId <+> pprCLabelString fn
221
222       ppr_fun DynamicTarget
223         = text "__dyn_ccall" <> gc_suf <+> text "\"\""
224 \end{code}
225
226
227 %************************************************************************
228 %*                                                                      *
229 \subsubsection{Misc}
230 %*                                                                      *
231 %************************************************************************
232
233 \begin{code}
234 {-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
235 instance Binary ForeignCall where
236     put_ bh (CCall aa) = put_ bh aa
237     get bh = do aa <- get bh; return (CCall aa)
238
239 instance Binary Safety where
240     put_ bh PlaySafe = do
241             putByte bh 0
242     put_ bh PlayInterruptible = do
243             putByte bh 1
244     put_ bh PlayRisky = do
245             putByte bh 2
246     get bh = do
247             h <- getByte bh
248             case h of
249               0 -> do return PlaySafe
250               1 -> do return PlayInterruptible
251               _ -> do return PlayRisky
252
253 instance Binary CExportSpec where
254     put_ bh (CExportStatic aa ab) = do
255             put_ bh aa
256             put_ bh ab
257     get bh = do
258           aa <- get bh
259           ab <- get bh
260           return (CExportStatic aa ab)
261
262 instance Binary CCallSpec where
263     put_ bh (CCallSpec aa ab ac) = do
264             put_ bh aa
265             put_ bh ab
266             put_ bh ac
267     get bh = do
268           aa <- get bh
269           ab <- get bh
270           ac <- get bh
271           return (CCallSpec aa ab ac)
272
273 instance Binary CCallTarget where
274     put_ bh (StaticTarget aa ab) = do
275             putByte bh 0
276             put_ bh aa
277             put_ bh ab
278     put_ bh DynamicTarget = do
279             putByte bh 1
280     get bh = do
281             h <- getByte bh
282             case h of
283               0 -> do aa <- get bh
284                       ab <- get bh
285                       return (StaticTarget aa ab)
286               _ -> do return DynamicTarget
287
288 instance Binary CCallConv where
289     put_ bh CCallConv = do
290             putByte bh 0
291     put_ bh StdCallConv = do
292             putByte bh 1
293     put_ bh PrimCallConv = do
294             putByte bh 2
295     put_ bh CmmCallConv = do
296             putByte bh 3
297     get bh = do
298             h <- getByte bh
299             case h of
300               0 -> do return CCallConv
301               1 -> do return StdCallConv
302               2 -> do return PrimCallConv
303               _ -> do return CmmCallConv
304 \end{code}