ghc/compiler/prelude/ForeignCall.lhs

   1 {-% DrIFT (Automatic class derivations for Haskell) v1.1 %-}
   2 {-% DrIFT (Automatic class derivations for Haskell) v1.1 %-}
   3 %
   4 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   5 %
   6 \section[Foreign]{Foreign calls}
   7
   8 \begin{code}
   9 module ForeignCall (
  10         ForeignCall(..),
  11         Safety(..), playSafe, playThreadSafe,
  12
  13         CExportSpec(..),
  14         CCallSpec(..),
  15         CCallTarget(..), isDynamicTarget,
  16         CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,
  17
  18         DNCallSpec(..), DNKind(..), DNType(..),
  19         withDNTypes
  20     ) where
  21
  22 #include "HsVersions.h"
  23
  24 import CStrings                 ( CLabelString, pprCLabelString )
  25 import FastString               ( FastString )
  26 import Binary
  27 import Outputable
  28 \end{code}
  29
  30
  31 %************************************************************************
  32 %*                                                                      *
  33 \subsubsection{Data types}
  34 %*                                                                      *
  35 %************************************************************************
  36
  37 \begin{code}
  38 data ForeignCall
  39   = CCall       CCallSpec
  40   | DNCall      DNCallSpec
  41   deriving( Eq )                -- We compare them when seeing if an interface
  42                                 -- has changed (for versioning purposes)
  43   {-! derive: Binary !-}
  44
  45 -- We may need more clues to distinguish foreign calls
  46 -- but this simple printer will do for now
  47 instance Outputable ForeignCall where
  48   ppr (CCall cc)  = ppr cc
  49   ppr (DNCall dn) = ppr dn
  50 \end{code}
  51
  52
  53 \begin{code}
  54 data Safety
  55   = PlaySafe            -- Might invoke Haskell GC, or do a call back, or
  56                         -- switch threads, etc.  So make sure things are
  57                         -- tidy before the call
  58         Bool            -- => True, external function is also re-entrant.
  59                         --    [if supported, RTS arranges for the external call
  60                         --    to be executed by a separate OS thread, i.e.,
  61                         --    _concurrently_ to the execution of other Haskell threads.]
  62
  63   | PlayRisky           -- None of the above can happen; the call will return
  64                         -- without interacting with the runtime system at all
  65   deriving( Eq, Show )
  66         -- Show used just for Show Lex.Token, I think
  67   {-! derive: Binary !-}
  68
  69 instance Outputable Safety where
  70   ppr (PlaySafe False) = ptext SLIT("safe")
  71   ppr (PlaySafe True)  = ptext SLIT("threadsafe")
  72   ppr PlayRisky = ptext SLIT("unsafe")
  73
  74 playSafe :: Safety -> Bool
  75 playSafe PlaySafe{} = True
  76 playSafe PlayRisky  = False
  77
  78 playThreadSafe :: Safety -> Bool
  79 playThreadSafe (PlaySafe x) = x
  80 playThreadSafe _ = False
  81 \end{code}
  82
  83
  84 %************************************************************************
  85 %*                                                                      *
  86 \subsubsection{Calling C}
  87 %*                                                                      *
  88 %************************************************************************
  89
  90 \begin{code}
  91 data CExportSpec
  92   = CExportStatic               -- foreign export ccall foo :: ty
  93         CLabelString            -- C Name of exported function
  94         CCallConv
  95   {-! derive: Binary !-}
  96
  97 data CCallSpec
  98   =  CCallSpec  CCallTarget     -- What to call
  99                 CCallConv       -- Calling convention to use.
 100                 Safety
 101   deriving( Eq )
 102   {-! derive: Binary !-}
 103 \end{code}
 104
 105 The call target:
 106
 107 \begin{code}
 108 data CCallTarget
 109   = StaticTarget  CLabelString  -- An "unboxed" ccall# to `fn'.
 110   | DynamicTarget               -- First argument (an Addr#) is the function pointer
 111   deriving( Eq )
 112   {-! derive: Binary !-}
 113
 114 isDynamicTarget :: CCallTarget -> Bool
 115 isDynamicTarget DynamicTarget = True
 116 isDynamicTarget other         = False
 117 \end{code}
 118
 119
 120 Stuff to do with calling convention:
 121
 122 ccall:          Caller allocates parameters, *and* deallocates them.
 123
 124 stdcall:        Caller allocates parameters, callee deallocates.
 125                 Function name has @N after it, where N is number of arg bytes
 126                 e.g.  _Foo@8
 127
 128 ToDo: The stdcall calling convention is x86 (win32) specific,
 129 so perhaps we should emit a warning if it's being used on other
 130 platforms.
 131
 132 \begin{code}
 133 data CCallConv = CCallConv | StdCallConv
 134   deriving (Eq)
 135   {-! derive: Binary !-}
 136
 137 instance Outputable CCallConv where
 138   ppr StdCallConv = ptext SLIT("stdcall")
 139   ppr CCallConv   = ptext SLIT("ccall")
 140
 141 defaultCCallConv :: CCallConv
 142 defaultCCallConv = CCallConv
 143
 144 ccallConvToInt :: CCallConv -> Int
 145 ccallConvToInt StdCallConv = 0
 146 ccallConvToInt CCallConv   = 1
 147 \end{code}
 148
 149 Generate the gcc attribute corresponding to the given
 150 calling convention (used by PprAbsC):
 151
 152 \begin{code}
 153 ccallConvAttribute :: CCallConv -> String
 154 ccallConvAttribute StdCallConv = "__stdcall"
 155 ccallConvAttribute CCallConv   = ""
 156 \end{code}
 157
 158 Printing into C files:
 159
 160 \begin{code}
 161 instance Outputable CExportSpec where
 162   ppr (CExportStatic str _) = pprCLabelString str
 163
 164 instance Outputable CCallSpec where
 165   ppr (CCallSpec fun cconv safety)
 166     = hcat [ ifPprDebug callconv, ppr_fun fun ]
 167     where
 168       callconv = text "{-" <> ppr cconv <> text "-}"
 169
 170       gc_suf | playSafe safety = text "_GC"
 171              | otherwise       = empty
 172
 173       ppr_fun DynamicTarget     = text "__dyn_ccall" <> gc_suf <+> text "\"\""
 174       ppr_fun (StaticTarget fn) = text "__ccall"     <> gc_suf <+> pprCLabelString fn
 175 \end{code}
 176
 177
 178 %************************************************************************
 179 %*                                                                      *
 180 \subsubsection{.NET interop}
 181 %*                                                                      *
 182 %************************************************************************
 183
 184 \begin{code}
 185 data DNCallSpec =
 186         DNCallSpec Bool       -- True => static method/field
 187                    DNKind     -- what type of access
 188                    String     -- assembly
 189                    String     -- fully qualified method/field name.
 190                    [DNType]   -- argument types.
 191                    DNType     -- result type.
 192     deriving ( Eq )
 193   {-! derive: Binary !-}
 194
 195 data DNKind
 196   = DNMethod
 197   | DNField
 198   | DNConstructor
 199     deriving ( Eq )
 200   {-! derive: Binary !-}
 201
 202 data DNType
 203   = DNByte
 204   | DNBool
 205   | DNChar
 206   | DNDouble
 207   | DNFloat
 208   | DNInt
 209   | DNInt8
 210   | DNInt16
 211   | DNInt32
 212   | DNInt64
 213   | DNWord8
 214   | DNWord16
 215   | DNWord32
 216   | DNWord64
 217   | DNPtr
 218   | DNUnit
 219   | DNObject
 220   | DNString
 221     deriving ( Eq )
 222   {-! derive: Binary !-}
 223
 224 withDNTypes :: DNCallSpec -> [DNType] -> DNType -> DNCallSpec
 225 withDNTypes (DNCallSpec isStatic k assem nm _ _) argTys resTy
 226   = DNCallSpec isStatic k assem nm argTys resTy
 227
 228 instance Outputable DNCallSpec where
 229   ppr (DNCallSpec isStatic kind ass nm _ _ )
 230     = char '"' <>
 231        (if isStatic then text "static" else empty) <+>
 232        (text (case kind of { DNMethod -> "method" ; DNField -> "field"; DNConstructor -> "ctor" })) <+>
 233        (if null ass then char ' ' else char '[' <> text ass <> char ']') <>
 234        text nm <>
 235       char '"'
 236 \end{code}
 237
 238
 239
 240 %************************************************************************
 241 %*                                                                      *
 242 \subsubsection{Misc}
 243 %*                                                                      *
 244 %************************************************************************
 245
 246 \begin{code}
 247 {-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
 248 instance Binary ForeignCall where
 249     put_ bh (CCall aa) = do
 250             putByte bh 0
 251             put_ bh aa
 252     put_ bh (DNCall ab) = do
 253             putByte bh 1
 254             put_ bh ab
 255     get bh = do
 256             h <- getByte bh
 257             case h of
 258               0 -> do aa <- get bh
 259                       return (CCall aa)
 260               _ -> do ab <- get bh
 261                       return (DNCall ab)
 262
 263 instance Binary Safety where
 264     put_ bh (PlaySafe aa) = do
 265             putByte bh 0
 266             put_ bh aa
 267     put_ bh PlayRisky = do
 268             putByte bh 1
 269     get bh = do
 270             h <- getByte bh
 271             case h of
 272               0 -> do aa <- get bh
 273                       return (PlaySafe aa)
 274               _ -> do return PlayRisky
 275
 276 instance Binary CExportSpec where
 277     put_ bh (CExportStatic aa ab) = do
 278             put_ bh aa
 279             put_ bh ab
 280     get bh = do
 281           aa <- get bh
 282           ab <- get bh
 283           return (CExportStatic aa ab)
 284
 285 instance Binary CCallSpec where
 286     put_ bh (CCallSpec aa ab ac) = do
 287             put_ bh aa
 288             put_ bh ab
 289             put_ bh ac
 290     get bh = do
 291           aa <- get bh
 292           ab <- get bh
 293           ac <- get bh
 294           return (CCallSpec aa ab ac)
 295
 296 instance Binary CCallTarget where
 297     put_ bh (StaticTarget aa) = do
 298             putByte bh 0
 299             put_ bh aa
 300     put_ bh DynamicTarget = do
 301             putByte bh 1
 302     get bh = do
 303             h <- getByte bh
 304             case h of
 305               0 -> do aa <- get bh
 306                       return (StaticTarget aa)
 307               _ -> do return DynamicTarget
 308
 309 instance Binary CCallConv where
 310     put_ bh CCallConv = do
 311             putByte bh 0
 312     put_ bh StdCallConv = do
 313             putByte bh 1
 314     get bh = do
 315             h <- getByte bh
 316             case h of
 317               0 -> do return CCallConv
 318               _ -> do return StdCallConv
 319
 320 instance Binary DNCallSpec where
 321     put_ bh (DNCallSpec isStatic kind ass nm _ _) = do
 322             put_ bh isStatic
 323             put_ bh kind
 324             put_ bh ass
 325             put_ bh nm
 326     get bh = do
 327           isStatic <- get bh
 328           kind     <- get bh
 329           ass      <- get bh
 330           nm       <- get bh
 331           return (DNCallSpec isStatic kind ass nm [] undefined)
 332
 333 instance Binary DNKind where
 334     put_ bh DNMethod = do
 335             putByte bh 0
 336     put_ bh DNField = do
 337             putByte bh 1
 338     put_ bh DNConstructor = do
 339             putByte bh 2
 340     get bh = do
 341             h <- getByte bh
 342             case h of
 343               0 -> do return DNMethod
 344               1 -> do return DNField
 345               _ -> do return DNConstructor
 346
 347 instance Binary DNType where
 348     put_ bh DNByte = do
 349             putByte bh 0
 350     put_ bh DNBool = do
 351             putByte bh 1
 352     put_ bh DNChar = do
 353             putByte bh 2
 354     put_ bh DNDouble = do
 355             putByte bh 3
 356     put_ bh DNFloat = do
 357             putByte bh 4
 358     put_ bh DNInt = do
 359             putByte bh 5
 360     put_ bh DNInt8 = do
 361             putByte bh 6
 362     put_ bh DNInt16 = do
 363             putByte bh 7
 364     put_ bh DNInt32 = do
 365             putByte bh 8
 366     put_ bh DNInt64 = do
 367             putByte bh 9
 368     put_ bh DNWord8 = do
 369             putByte bh 10
 370     put_ bh DNWord16 = do
 371             putByte bh 11
 372     put_ bh DNWord32 = do
 373             putByte bh 12
 374     put_ bh DNWord64 = do
 375             putByte bh 13
 376     put_ bh DNPtr = do
 377             putByte bh 14
 378     put_ bh DNUnit = do
 379             putByte bh 15
 380     put_ bh DNObject = do
 381             putByte bh 16
 382     put_ bh DNString = do
 383             putByte bh 17
 384
 385     get bh = do
 386             h <- getByte bh
 387             case h of
 388               0 -> return DNByte
 389               1 -> return DNBool
 390               2 -> return DNChar
 391               3 -> return DNDouble
 392               4 -> return DNFloat
 393               5 -> return DNInt
 394               6 -> return DNInt8
 395               7 -> return DNInt16
 396               8 -> return DNInt32
 397               9 -> return DNInt64
 398               10 -> return DNWord8
 399               11 -> return DNWord16
 400               12 -> return DNWord32
 401               13 -> return DNWord64
 402               14 -> return DNPtr
 403               15 -> return DNUnit
 404               16 -> return DNObject
 405               17 -> return DNString
 406
 407 --  Imported from other files :-
 408
 409 \end{code}