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