ForeignCall.hs 11.2 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 93 94
  = CExportStatic               -- foreign export ccall foo :: ty
        CLabelString            -- C Name of exported function
        CCallConv
95
  deriving (Data, Typeable)
96
  {-! derive: Binary !-}
97

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

Austin Seipp's avatar
Austin Seipp committed
105
-- The call target:
106

107
-- | How to call a particular function in C-land.
108
data CCallTarget
109
  -- An "unboxed" ccall# to named function in a particular package.
Ian Lynagh's avatar
Ian Lynagh committed
110
  = StaticTarget
111
        CLabelString                    -- C-land name of label.
112

113
        (Maybe PackageKey)              -- What package the function is in.
114 115
                                        -- 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
116
                                        --       See CLabel.labelDynamic and CoreToStg.coreToStgApp
117 118 119
                                        --       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.
120 121

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

128
  deriving( Eq, Data, Typeable )
129
  {-! derive: Binary !-}
130

131
isDynamicTarget :: CCallTarget -> Bool
132
isDynamicTarget DynamicTarget = True
Ian Lynagh's avatar
Ian Lynagh committed
133
isDynamicTarget _             = False
134

Austin Seipp's avatar
Austin Seipp committed
135
{-
136 137
Stuff to do with calling convention:

138
ccall:          Caller allocates parameters, *and* deallocates them.
139

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

144
See: http://www.programmersheaven.com/2/Calling-conventions
Austin Seipp's avatar
Austin Seipp committed
145
-}
146

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

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

defaultCCallConv :: CCallConv
defaultCCallConv = CCallConv

ccallConvToInt :: CCallConv -> Int
ccallConvToInt StdCallConv = 0
ccallConvToInt CCallConv   = 1
165
ccallConvToInt CApiConv    = panic "ccallConvToInt CApiConv"
166
ccallConvToInt (PrimCallConv {}) = panic "ccallConvToInt PrimCallConv"
thoughtpolice's avatar
thoughtpolice committed
167
ccallConvToInt JavaScriptCallConv = panic "ccallConvToInt JavaScriptCallConv"
168

Austin Seipp's avatar
Austin Seipp committed
169
{-
170 171
Generate the gcc attribute corresponding to the given
calling convention (used by PprAbsC):
Austin Seipp's avatar
Austin Seipp committed
172
-}
173

Ian Lynagh's avatar
Ian Lynagh committed
174 175 176
ccallConvAttribute :: CCallConv -> SDoc
ccallConvAttribute StdCallConv       = text "__attribute__((__stdcall__))"
ccallConvAttribute CCallConv         = empty
177
ccallConvAttribute CApiConv          = empty
178
ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv"
thoughtpolice's avatar
thoughtpolice committed
179
ccallConvAttribute JavaScriptCallConv = panic "ccallConvAttribute JavaScriptCallConv"
180

181
type CLabelString = FastString          -- A C label, completely unencoded
182 183 184 185

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

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

Austin Seipp's avatar
Austin Seipp committed
194
-- Printing into C files:
195

196 197 198
instance Outputable CExportSpec where
  ppr (CExportStatic str _) = pprCLabelString str

199
instance Outputable CCallSpec where
200 201
  ppr (CCallSpec fun cconv safety)
    = hcat [ ifPprDebug callconv, ppr_fun fun ]
202
    where
203 204 205
      callconv = text "{-" <> ppr cconv <> text "-}"

      gc_suf | playSafe safety = text "_GC"
206
             | otherwise       = empty
207

208 209 210 211 212 213 214 215
      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
216

Ian Lynagh's avatar
Ian Lynagh committed
217
      ppr_fun DynamicTarget
218
        = text "__dyn_ccall" <> gc_suf <+> text "\"\""
219

220 221 222 223
-- The filename for a C header file
newtype Header = Header FastString
    deriving (Eq, Data, Typeable)

224 225 226
instance Outputable Header where
    ppr (Header h) = quotes $ ppr h

227
-- | A C type, used in CAPI FFI calls
Alan Zimmerman's avatar
Alan Zimmerman committed
228 229 230 231 232 233
--
--  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CTYPE'@,
--        'ApiAnnotation.AnnHeader','ApiAnnotation.AnnVal',
--        'ApiAnnotation.AnnClose' @'\#-}'@,
data CType = CType SourceText -- Note [Pragma source text] in BasicTypes
                   (Maybe Header) -- header to include for this type
234
                   FastString     -- the type itself
235
    deriving (Data, Typeable)
236 237

instance Outputable CType where
Alan Zimmerman's avatar
Alan Zimmerman committed
238
    ppr (CType _ mh ct) = hDoc <+> ftext ct
239 240 241
        where hDoc = case mh of
                     Nothing -> empty
                     Just h -> ppr h
242

Austin Seipp's avatar
Austin Seipp committed
243 244 245
{-
************************************************************************
*                                                                      *
246
\subsubsection{Misc}
Austin Seipp's avatar
Austin Seipp committed
247 248 249
*                                                                      *
************************************************************************
-}
250

251 252
{-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
instance Binary ForeignCall where
253 254
    put_ bh (CCall aa) = put_ bh aa
    get bh = do aa <- get bh; return (CCall aa)
255 256

instance Binary Safety where
Ian Lynagh's avatar
Ian Lynagh committed
257
    put_ bh PlaySafe = do
258
            putByte bh 0
259
    put_ bh PlayInterruptible = do
260
            putByte bh 1
261
    put_ bh PlayRisky = do
262
            putByte bh 2
263
    get bh = do
264 265 266 267 268
            h <- getByte bh
            case h of
              0 -> do return PlaySafe
              1 -> do return PlayInterruptible
              _ -> do return PlayRisky
269 270 271

instance Binary CExportSpec where
    put_ bh (CExportStatic aa ab) = do
272 273
            put_ bh aa
            put_ bh ab
274
    get bh = do
275 276 277
          aa <- get bh
          ab <- get bh
          return (CExportStatic aa ab)
278 279 280

instance Binary CCallSpec where
    put_ bh (CCallSpec aa ab ac) = do
281 282 283
            put_ bh aa
            put_ bh ab
            put_ bh ac
284
    get bh = do
285 286 287 288
          aa <- get bh
          ab <- get bh
          ac <- get bh
          return (CCallSpec aa ab ac)
289 290

instance Binary CCallTarget where
291
    put_ bh (StaticTarget aa ab ac) = do
292 293
            putByte bh 0
            put_ bh aa
294
            put_ bh ab
295
            put_ bh ac
296
    put_ bh DynamicTarget = do
297
            putByte bh 1
298
    get bh = do
299 300 301
            h <- getByte bh
            case h of
              0 -> do aa <- get bh
302
                      ab <- get bh
303 304
                      ac <- get bh
                      return (StaticTarget aa ab ac)
305
              _ -> do return DynamicTarget
306 307 308

instance Binary CCallConv where
    put_ bh CCallConv = do
309
            putByte bh 0
310
    put_ bh StdCallConv = do
311
            putByte bh 1
312
    put_ bh PrimCallConv = do
313
            putByte bh 2
314
    put_ bh CApiConv = do
315
            putByte bh 3
thoughtpolice's avatar
thoughtpolice committed
316 317
    put_ bh JavaScriptCallConv = do
            putByte bh 4
318
    get bh = do
319 320 321 322
            h <- getByte bh
            case h of
              0 -> do return CCallConv
              1 -> do return StdCallConv
Ian Lynagh's avatar
Ian Lynagh committed
323
              2 -> do return PrimCallConv
thoughtpolice's avatar
thoughtpolice committed
324 325
              3 -> do return CApiConv
              _ -> do return JavaScriptCallConv
326 327

instance Binary CType where
Alan Zimmerman's avatar
Alan Zimmerman committed
328 329 330 331 332
    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
333
                fs <- get bh
Alan Zimmerman's avatar
Alan Zimmerman committed
334
                return (CType s mh fs)
335 336 337 338 339

instance Binary Header where
    put_ bh (Header h) = put_ bh h
    get bh = do h <- get bh
                return (Header h)