compiler/prelude/ForeignCall.lhs

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