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