ForeignCall.lhs 11.2 KB
Newer Older
1 2 3 4 5 6
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[Foreign]{Foreign calls}

\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 16
        CCallTarget(..), isDynamicTarget,
        CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,
17

18
        Header(..), CType(..),
19 20
    ) where

21
import FastString
22
import Binary
23
import Outputable
24
import Module
25 26

import Data.Char
27
import Data.Data
28 29 30 31
\end{code}


%************************************************************************
32
%*                                                                      *
33
\subsubsection{Data types}
34
%*                                                                      *
35 36 37
%************************************************************************

\begin{code}
38 39
newtype ForeignCall = CCall CCallSpec
  deriving Eq
40
  {-! derive: Binary !-}
41

42 43 44
isSafeForeignCall :: ForeignCall -> Bool
isSafeForeignCall (CCall (CCallSpec _ _ safe)) = playSafe safe

45 46 47
-- We may need more clues to distinguish foreign calls
-- but this simple printer will do for now
instance Outputable ForeignCall where
48
  ppr (CCall cc)  = ppr cc
49 50
\end{code}

51

52 53
\begin{code}
data Safety
54 55 56 57 58 59
  = PlaySafe            -- Might invoke Haskell GC, or do a call back, or
                        -- switch threads, etc.  So make sure things are
                        -- tidy before the call. Additionally, in the threaded
                        -- RTS we arrange for the external call to be executed
                        -- by a separate OS thread, i.e., _concurrently_ to the
                        -- execution of other Haskell threads.
60

61 62 63 64 65
  | PlayInterruptible   -- Like PlaySafe, but additionally
                        -- the worker thread running this foreign call may
                        -- be unceremoniously killed, so it must be scheduled
                        -- on an unbound thread.

66 67
  | PlayRisky           -- None of the above can happen; the call will return
                        -- 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
Ian Lynagh's avatar
Ian Lynagh committed
73
  ppr PlaySafe = ptext (sLit "safe")
74
  ppr PlayInterruptible = ptext (sLit "interruptible")
75
  ppr PlayRisky = ptext (sLit "unsafe")
76

sof's avatar
sof committed
77
playSafe :: Safety -> Bool
Ian Lynagh's avatar
Ian Lynagh committed
78
playSafe PlaySafe = True
79
playSafe PlayInterruptible = True
Ian Lynagh's avatar
Ian Lynagh committed
80
playSafe PlayRisky = False
81 82 83 84

playInterruptible :: Safety -> Bool
playInterruptible PlayInterruptible = True
playInterruptible _ = False
85 86 87 88
\end{code}


%************************************************************************
89
%*                                                                      *
90
\subsubsection{Calling C}
91
%*                                                                      *
92 93 94
%************************************************************************

\begin{code}
95
data CExportSpec
96 97 98
  = CExportStatic               -- foreign export ccall foo :: ty
        CLabelString            -- C Name of exported function
        CCallConv
99
  deriving (Data, Typeable)
100
  {-! derive: Binary !-}
101

102
data CCallSpec
103 104 105
  =  CCallSpec  CCallTarget     -- What to call
                CCallConv       -- Calling convention to use.
                Safety
106
  deriving( Eq )
107
  {-! derive: Binary !-}
108 109 110 111 112
\end{code}

The call target:

\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 PackageKey)              -- What package the function is in.
121 122
                                        -- If Nothing, then it's taken to be in the current package.
                                        -- Note: This information is only used for PrimCalls on Windows.
123
                                        --       See CLabel.labelDynamic and CoreToStg.coreToStgApp
124 125 126
                                        --       for the difference in representation between PrimCalls
                                        --       and ForeignCalls. If the CCallTarget is representing
                                        --       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 131 132
        Bool                            -- True => really a function
                                        -- False => a value; only
                                        -- allowed in CAPI imports
133
  | DynamicTarget
134

135
  deriving( Eq, Data, Typeable )
136
  {-! derive: Binary !-}
137

138
isDynamicTarget :: CCallTarget -> Bool
139
isDynamicTarget DynamicTarget = True
Ian Lynagh's avatar
Ian Lynagh committed
140
isDynamicTarget _             = False
141 142 143
\end{code}


144 145
Stuff to do with calling convention:

146
ccall:          Caller allocates parameters, *and* deallocates them.
147

148 149 150
stdcall:        Caller allocates parameters, callee deallocates.
                Function name has @N after it, where N is number of arg bytes
                e.g.  _Foo@8
151 152 153 154

ToDo: The stdcall calling convention is x86 (win32) specific,
so perhaps we should emit a warning if it's being used on other
platforms.
155

156
See: http://www.programmersheaven.com/2/Calling-conventions
157 158

\begin{code}
159
-- any changes here should be replicated in  the CallConv type in template haskell
thoughtpolice's avatar
thoughtpolice committed
160
data CCallConv = CCallConv | CApiConv | StdCallConv | PrimCallConv | JavaScriptCallConv
161
  deriving (Eq, Data, Typeable)
162
  {-! derive: Binary !-}
163 164

instance Outputable CCallConv where
165 166
  ppr StdCallConv = ptext (sLit "stdcall")
  ppr CCallConv   = ptext (sLit "ccall")
167
  ppr CApiConv    = ptext (sLit "capi")
168
  ppr PrimCallConv = ptext (sLit "prim")
thoughtpolice's avatar
thoughtpolice committed
169
  ppr JavaScriptCallConv = ptext (sLit "javascript")
170 171 172 173 174 175 176

defaultCCallConv :: CCallConv
defaultCCallConv = CCallConv

ccallConvToInt :: CCallConv -> Int
ccallConvToInt StdCallConv = 0
ccallConvToInt CCallConv   = 1
177
ccallConvToInt CApiConv    = panic "ccallConvToInt CApiConv"
178
ccallConvToInt (PrimCallConv {}) = panic "ccallConvToInt PrimCallConv"
thoughtpolice's avatar
thoughtpolice committed
179
ccallConvToInt JavaScriptCallConv = panic "ccallConvToInt JavaScriptCallConv"
180 181 182 183 184 185
\end{code}

Generate the gcc attribute corresponding to the given
calling convention (used by PprAbsC):

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
186 187 188
ccallConvAttribute :: CCallConv -> SDoc
ccallConvAttribute StdCallConv       = text "__attribute__((__stdcall__))"
ccallConvAttribute CCallConv         = empty
189
ccallConvAttribute CApiConv          = empty
190
ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv"
thoughtpolice's avatar
thoughtpolice committed
191
ccallConvAttribute JavaScriptCallConv = panic "ccallConvAttribute JavaScriptCallConv"
192 193
\end{code}

194
\begin{code}
195
type CLabelString = FastString          -- A C label, completely unencoded
196 197 198 199

pprCLabelString :: CLabelString -> SDoc
pprCLabelString lbl = ftext lbl

200
isCLabelString :: CLabelString -> Bool  -- Checks to see if this is a valid C label
201
isCLabelString lbl
202 203 204
  = all ok (unpackFS lbl)
  where
    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 208 209
\end{code}


210 211 212
Printing into C files:

\begin{code}
213 214 215
instance Outputable CExportSpec where
  ppr (CExportStatic str _) = pprCLabelString str

216
instance Outputable CCallSpec where
217 218
  ppr (CCallSpec fun cconv safety)
    = hcat [ ifPprDebug callconv, ppr_fun fun ]
219
    where
220 221 222
      callconv = text "{-" <> ppr cconv <> text "-}"

      gc_suf | playSafe safety = text "_GC"
223
             | otherwise       = empty
224

225 226 227 228 229 230 231 232
      ppr_fun (StaticTarget fn mPkgId isFun)
        = text (if isFun then "__pkg_ccall"
                         else "__pkg_ccall_value")
       <> gc_suf
       <+> (case mPkgId of
            Nothing -> empty
            Just pkgId -> ppr pkgId)
       <+> pprCLabelString fn
233

234
      ppr_fun DynamicTarget
235
        = text "__dyn_ccall" <> gc_suf <+> text "\"\""
236 237
\end{code}

238
\begin{code}
239 240 241 242
-- The filename for a C header file
newtype Header = Header FastString
    deriving (Eq, Data, Typeable)

243 244 245
instance Outputable Header where
    ppr (Header h) = quotes $ ppr h

246
-- | A C type, used in CAPI FFI calls
247 248
data CType = CType (Maybe Header) -- header to include for this type
                   FastString     -- the type itself
249
    deriving (Data, Typeable)
250 251 252 253 254 255

instance Outputable CType where
    ppr (CType mh ct) = hDoc <+> ftext ct
        where hDoc = case mh of
                     Nothing -> empty
                     Just h -> ppr h
256 257
\end{code}

258

259
%************************************************************************
260
%*                                                                      *
261
\subsubsection{Misc}
262
%*                                                                      *
263 264
%************************************************************************

265 266 267
\begin{code}
{-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
instance Binary ForeignCall where
268 269
    put_ bh (CCall aa) = put_ bh aa
    get bh = do aa <- get bh; return (CCall aa)
270 271

instance Binary Safety where
Ian Lynagh's avatar
Ian Lynagh committed
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 280 281 282 283
            h <- getByte bh
            case h of
              0 -> do return PlaySafe
              1 -> do return PlayInterruptible
              _ -> do return PlayRisky
284 285 286

instance Binary CExportSpec where
    put_ bh (CExportStatic aa ab) = do
287 288
            put_ bh aa
            put_ bh ab
289
    get bh = do
290 291 292
          aa <- get bh
          ab <- get bh
          return (CExportStatic aa ab)
293 294 295

instance Binary CCallSpec where
    put_ bh (CCallSpec aa ab ac) = do
296 297 298
            put_ bh aa
            put_ bh ab
            put_ bh ac
299
    get bh = do
300 301 302 303
          aa <- get bh
          ab <- get bh
          ac <- get bh
          return (CCallSpec aa ab ac)
304 305

instance Binary CCallTarget where
306
    put_ bh (StaticTarget aa ab ac) = do
307 308
            putByte bh 0
            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 315 316
            h <- getByte bh
            case h of
              0 -> do aa <- get bh
317
                      ab <- get bh
318 319
                      ac <- get bh
                      return (StaticTarget aa ab ac)
320
              _ -> do return DynamicTarget
321 322 323

instance Binary CCallConv where
    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
thoughtpolice's avatar
thoughtpolice committed
331 332
    put_ bh JavaScriptCallConv = do
            putByte bh 4
333
    get bh = do
334 335 336 337
            h <- getByte bh
            case h of
              0 -> do return CCallConv
              1 -> do return StdCallConv
338
              2 -> do return PrimCallConv
thoughtpolice's avatar
thoughtpolice committed
339 340
              3 -> do return CApiConv
              _ -> do return JavaScriptCallConv
341 342

instance Binary CType where
343 344 345 346 347
    put_ bh (CType mh fs) = do put_ bh mh
                               put_ bh fs
    get bh = do mh <- get bh
                fs <- get bh
                return (CType mh fs)
348 349 350 351 352

instance Binary Header where
    put_ bh (Header h) = put_ bh h
    get bh = do h <- get bh
                return (Header h)
353
\end{code}