ForeignCall.hs 11.8 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

4
\section[Foreign]{Foreign calls}
Austin Seipp's avatar
Austin Seipp committed
5
-}
6

7
{-# LANGUAGE DeriveDataTypeable #-}
8

9
module ForeignCall (
10
        ForeignCall(..), isSafeForeignCall,
11
        Safety(..), playSafe, playInterruptible,
12

13
        CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
Ian Lynagh's avatar
Ian Lynagh committed
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
Alan Zimmerman's avatar
Alan Zimmerman committed
25
import BasicTypes ( SourceText )
Ian Lynagh's avatar
Ian Lynagh committed
26 27

import Data.Char
28
import Data.Data
29

Austin Seipp's avatar
Austin Seipp committed
30 31 32
{-
************************************************************************
*                                                                      *
33
\subsubsection{Data types}
Austin Seipp's avatar
Austin Seipp committed
34 35 36
*                                                                      *
************************************************************************
-}
37

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
Ian Lynagh's avatar
Ian Lynagh committed
48
  ppr (CCall cc)  = ppr cc
49 50

data Safety
51 52 53 54 55 56
  = 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.
57

58 59 60 61 62
  | 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.

63 64
  | PlayRisky           -- None of the above can happen; the call will return
                        -- without interacting with the runtime system at all
65
  deriving ( Eq, Show, Data, Typeable )
66
        -- Show used just for Show Lex.Token, I think
67
  {-! derive: Binary !-}
68 69

instance Outputable Safety where
Ian Lynagh's avatar
Ian Lynagh committed
70
  ppr PlaySafe = ptext (sLit "safe")
71
  ppr PlayInterruptible = ptext (sLit "interruptible")
Ian Lynagh's avatar
Ian Lynagh committed
72
  ppr PlayRisky = ptext (sLit "unsafe")
73

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

playInterruptible :: Safety -> Bool
playInterruptible PlayInterruptible = True
playInterruptible _ = False
82

Austin Seipp's avatar
Austin Seipp committed
83 84 85
{-
************************************************************************
*                                                                      *
86
\subsubsection{Calling C}
Austin Seipp's avatar
Austin Seipp committed
87 88 89
*                                                                      *
************************************************************************
-}
90

91
data CExportSpec
92
  = CExportStatic               -- foreign export ccall foo :: ty
93 94
        SourceText              -- of the CLabelString.
                                -- See note [Pragma source text] in BasicTypes
95 96
        CLabelString            -- C Name of exported function
        CCallConv
97
  deriving (Data, Typeable)
98
  {-! derive: Binary !-}
99

100
data CCallSpec
101 102 103
  =  CCallSpec  CCallTarget     -- What to call
                CCallConv       -- Calling convention to use.
                Safety
104
  deriving( Eq )
105
  {-! derive: Binary !-}
106

Austin Seipp's avatar
Austin Seipp committed
107
-- The call target:
108

109
-- | How to call a particular function in C-land.
110
data CCallTarget
111
  -- An "unboxed" ccall# to named function in a particular package.
Ian Lynagh's avatar
Ian Lynagh committed
112
  = StaticTarget
113 114
        SourceText                -- of the CLabelString.
                                  -- See note [Pragma source text] in BasicTypes
115
        CLabelString                    -- C-land name of label.
116

117
        (Maybe PackageKey)              -- What package the function is in.
118 119
                                        -- If Nothing, then it's taken to be in the current package.
                                        -- Note: This information is only used for PrimCalls on Windows.
Ian Lynagh's avatar
Ian Lynagh committed
120
                                        --       See CLabel.labelDynamic and CoreToStg.coreToStgApp
121 122 123
                                        --       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.
124 125

  -- The first argument of the import is the name of a function pointer (an Addr#).
126
  --    Used when importing a label as "foreign import ccall "dynamic" ..."
127 128 129
        Bool                            -- True => really a function
                                        -- False => a value; only
                                        -- allowed in CAPI imports
130
  | DynamicTarget
Ian Lynagh's avatar
Ian Lynagh committed
131

132
  deriving( Eq, Data, Typeable )
133
  {-! derive: Binary !-}
134

135
isDynamicTarget :: CCallTarget -> Bool
136
isDynamicTarget DynamicTarget = True
Ian Lynagh's avatar
Ian Lynagh committed
137
isDynamicTarget _             = False
138

Austin Seipp's avatar
Austin Seipp committed
139
{-
140 141
Stuff to do with calling convention:

142
ccall:          Caller allocates parameters, *and* deallocates them.
143

144 145
stdcall:        Caller allocates parameters, callee deallocates.
                Function name has @N after it, where N is number of arg bytes
146
                e.g.  _Foo@8. This convention is x86 (win32) specific.
Ian Lynagh's avatar
Ian Lynagh committed
147

148
See: http://www.programmersheaven.com/2/Calling-conventions
Austin Seipp's avatar
Austin Seipp committed
149
-}
150

151
-- any changes here should be replicated in  the CallConv type in template haskell
thoughtpolice's avatar
thoughtpolice committed
152
data CCallConv = CCallConv | CApiConv | StdCallConv | PrimCallConv | JavaScriptCallConv
153
  deriving (Eq, Data, Typeable)
154
  {-! derive: Binary !-}
155 156

instance Outputable CCallConv where
Ian Lynagh's avatar
Ian Lynagh committed
157 158
  ppr StdCallConv = ptext (sLit "stdcall")
  ppr CCallConv   = ptext (sLit "ccall")
159
  ppr CApiConv    = ptext (sLit "capi")
160
  ppr PrimCallConv = ptext (sLit "prim")
thoughtpolice's avatar
thoughtpolice committed
161
  ppr JavaScriptCallConv = ptext (sLit "javascript")
162 163 164 165 166 167 168

defaultCCallConv :: CCallConv
defaultCCallConv = CCallConv

ccallConvToInt :: CCallConv -> Int
ccallConvToInt StdCallConv = 0
ccallConvToInt CCallConv   = 1
169
ccallConvToInt CApiConv    = panic "ccallConvToInt CApiConv"
170
ccallConvToInt (PrimCallConv {}) = panic "ccallConvToInt PrimCallConv"
thoughtpolice's avatar
thoughtpolice committed
171
ccallConvToInt JavaScriptCallConv = panic "ccallConvToInt JavaScriptCallConv"
172

Austin Seipp's avatar
Austin Seipp committed
173
{-
174 175
Generate the gcc attribute corresponding to the given
calling convention (used by PprAbsC):
Austin Seipp's avatar
Austin Seipp committed
176
-}
177

Ian Lynagh's avatar
Ian Lynagh committed
178 179 180
ccallConvAttribute :: CCallConv -> SDoc
ccallConvAttribute StdCallConv       = text "__attribute__((__stdcall__))"
ccallConvAttribute CCallConv         = empty
181
ccallConvAttribute CApiConv          = empty
182
ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv"
thoughtpolice's avatar
thoughtpolice committed
183
ccallConvAttribute JavaScriptCallConv = panic "ccallConvAttribute JavaScriptCallConv"
184

185
type CLabelString = FastString          -- A C label, completely unencoded
186 187 188 189

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

190
isCLabelString :: CLabelString -> Bool  -- Checks to see if this is a valid C label
Ian Lynagh's avatar
Ian Lynagh committed
191
isCLabelString lbl
192 193 194
  = all ok (unpackFS lbl)
  where
    ok c = isAlphaNum c || c == '_' || c == '.'
Ian Lynagh's avatar
Ian Lynagh committed
195
        -- The '.' appears in e.g. "foo.so" in the
196
        -- module part of a ExtName.  Maybe it should be separate
197

Austin Seipp's avatar
Austin Seipp committed
198
-- Printing into C files:
199

200
instance Outputable CExportSpec where
201
  ppr (CExportStatic _ str _) = pprCLabelString str
202

203
instance Outputable CCallSpec where
204 205
  ppr (CCallSpec fun cconv safety)
    = hcat [ ifPprDebug callconv, ppr_fun fun ]
206
    where
207 208 209
      callconv = text "{-" <> ppr cconv <> text "-}"

      gc_suf | playSafe safety = text "_GC"
210
             | otherwise       = empty
211

212
      ppr_fun (StaticTarget _ fn mPkgId isFun)
213 214 215 216 217 218 219
        = text (if isFun then "__pkg_ccall"
                         else "__pkg_ccall_value")
       <> gc_suf
       <+> (case mPkgId of
            Nothing -> empty
            Just pkgId -> ppr pkgId)
       <+> pprCLabelString fn
220

Ian Lynagh's avatar
Ian Lynagh committed
221
      ppr_fun DynamicTarget
222
        = text "__dyn_ccall" <> gc_suf <+> text "\"\""
223

224
-- The filename for a C header file
225 226
-- Note [Pragma source text] in BasicTypes
data Header = Header SourceText FastString
227 228
    deriving (Eq, Data, Typeable)

229
instance Outputable Header where
230
    ppr (Header _ h) = quotes $ ppr h
231

232
-- | A C type, used in CAPI FFI calls
Alan Zimmerman's avatar
Alan Zimmerman committed
233 234 235 236
--
--  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CTYPE'@,
--        'ApiAnnotation.AnnHeader','ApiAnnotation.AnnVal',
--        'ApiAnnotation.AnnClose' @'\#-}'@,
237 238

-- For details on above see note [Api annotations] in ApiAnnotation
Alan Zimmerman's avatar
Alan Zimmerman committed
239 240
data CType = CType SourceText -- Note [Pragma source text] in BasicTypes
                   (Maybe Header) -- header to include for this type
241
                   (SourceText,FastString) -- the type itself
242
    deriving (Data, Typeable)
243 244

instance Outputable CType where
245
    ppr (CType _ mh (_,ct)) = hDoc <+> ftext ct
246 247 248
        where hDoc = case mh of
                     Nothing -> empty
                     Just h -> ppr h
249

Austin Seipp's avatar
Austin Seipp committed
250 251 252
{-
************************************************************************
*                                                                      *
253
\subsubsection{Misc}
Austin Seipp's avatar
Austin Seipp committed
254 255 256
*                                                                      *
************************************************************************
-}
257

258 259
{-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
instance Binary ForeignCall where
260 261
    put_ bh (CCall aa) = put_ bh aa
    get bh = do aa <- get bh; return (CCall aa)
262 263

instance Binary Safety where
Ian Lynagh's avatar
Ian Lynagh committed
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 272 273 274 275
            h <- getByte bh
            case h of
              0 -> do return PlaySafe
              1 -> do return PlayInterruptible
              _ -> do return PlayRisky
276 277

instance Binary CExportSpec where
278 279
    put_ bh (CExportStatic ss aa ab) = do
            put_ bh ss
280 281
            put_ bh aa
            put_ bh ab
282
    get bh = do
283
          ss <- get bh
284 285
          aa <- get bh
          ab <- get bh
286
          return (CExportStatic ss aa ab)
287 288 289

instance Binary CCallSpec where
    put_ bh (CCallSpec aa ab ac) = do
290 291 292
            put_ bh aa
            put_ bh ab
            put_ bh ac
293
    get bh = do
294 295 296 297
          aa <- get bh
          ab <- get bh
          ac <- get bh
          return (CCallSpec aa ab ac)
298 299

instance Binary CCallTarget where
300
    put_ bh (StaticTarget ss aa ab ac) = do
301
            putByte bh 0
302
            put_ bh ss
303
            put_ bh aa
304
            put_ bh ab
305
            put_ bh ac
306
    put_ bh DynamicTarget = do
307
            putByte bh 1
308
    get bh = do
309 310
            h <- getByte bh
            case h of
311 312
              0 -> do ss <- get bh
                      aa <- get bh
313
                      ab <- get bh
314
                      ac <- get bh
315
                      return (StaticTarget ss aa ab ac)
316
              _ -> do return DynamicTarget
317 318 319

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

instance Binary CType where
Alan Zimmerman's avatar
Alan Zimmerman committed
339 340 341 342 343
    put_ bh (CType s mh fs) = do put_ bh s
                                 put_ bh mh
                                 put_ bh fs
    get bh = do s  <- get bh
                mh <- get bh
344
                fs <- get bh
Alan Zimmerman's avatar
Alan Zimmerman committed
345
                return (CType s mh fs)
346 347

instance Binary Header where
348 349 350 351
    put_ bh (Header s h) = put_ bh s >> put_ bh h
    get bh = do s <- get bh
                h <- get bh
                return (Header s h)