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