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 | CmmCallConv
 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   ppr CmmCallConv = ptext SLIT("C--")
 139
 140 defaultCCallConv :: CCallConv
 141 defaultCCallConv = CCallConv
 142
 143 ccallConvToInt :: CCallConv -> Int
 144 ccallConvToInt StdCallConv = 0
 145 ccallConvToInt CCallConv   = 1
 146 \end{code}
 147
 148 Generate the gcc attribute corresponding to the given
 149 calling convention (used by PprAbsC):
 150
 151 \begin{code}
 152 ccallConvAttribute :: CCallConv -> String
 153 ccallConvAttribute StdCallConv = "__attribute__((__stdcall__))"
 154 ccallConvAttribute CCallConv   = ""
 155 \end{code}
 156
 157 \begin{code}
 158 type CLabelString = FastString          -- A C label, completely unencoded
 159
 160 pprCLabelString :: CLabelString -> SDoc
 161 pprCLabelString lbl = ftext lbl
 162
 163 isCLabelString :: CLabelString -> Bool  -- Checks to see if this is a valid C label
 164 isCLabelString lbl
 165   = all ok (unpackFS lbl)
 166   where
 167     ok c = isAlphaNum c || c == '_' || c == '.'
 168         -- The '.' appears in e.g. "foo.so" in the
 169         -- module part of a ExtName.  Maybe it should be separate
 170 \end{code}
 171
 172
 173 Printing into C files:
 174
 175 \begin{code}
 176 instance Outputable CExportSpec where
 177   ppr (CExportStatic str _) = pprCLabelString str
 178
 179 instance Outputable CCallSpec where
 180   ppr (CCallSpec fun cconv safety)
 181     = hcat [ ifPprDebug callconv, ppr_fun fun ]
 182     where
 183       callconv = text "{-" <> ppr cconv <> text "-}"
 184
 185       gc_suf | playSafe safety = text "_GC"
 186              | otherwise       = empty
 187
 188       ppr_fun DynamicTarget     = text "__dyn_ccall" <> gc_suf <+> text "\"\""
 189       ppr_fun (StaticTarget fn) = text "__ccall"     <> gc_suf <+> pprCLabelString fn
 190 \end{code}
 191
 192
 193 %************************************************************************
 194 %*                                                                      *
 195 \subsubsection{.NET interop}
 196 %*                                                                      *
 197 %************************************************************************
 198
 199 \begin{code}
 200 data DNCallSpec =
 201         DNCallSpec Bool       -- True => static method/field
 202                    DNKind     -- what type of access
 203                    String     -- assembly
 204                    String     -- fully qualified method/field name.
 205                    [DNType]   -- argument types.
 206                    DNType     -- result type.
 207     deriving ( Eq )
 208   {-! derive: Binary !-}
 209
 210 data DNKind
 211   = DNMethod
 212   | DNField
 213   | DNConstructor
 214     deriving ( Eq )
 215   {-! derive: Binary !-}
 216
 217 data DNType
 218   = DNByte
 219   | DNBool
 220   | DNChar
 221   | DNDouble
 222   | DNFloat
 223   | DNInt
 224   | DNInt8
 225   | DNInt16
 226   | DNInt32
 227   | DNInt64
 228   | DNWord8
 229   | DNWord16
 230   | DNWord32
 231   | DNWord64
 232   | DNPtr
 233   | DNUnit
 234   | DNObject
 235   | DNString
 236     deriving ( Eq )
 237   {-! derive: Binary !-}
 238
 239 withDNTypes :: DNCallSpec -> [DNType] -> DNType -> DNCallSpec
 240 withDNTypes (DNCallSpec isStatic k assem nm _ _) argTys resTy
 241   = DNCallSpec isStatic k assem nm argTys resTy
 242
 243 instance Outputable DNCallSpec where
 244   ppr (DNCallSpec isStatic kind ass nm _ _ )
 245     = char '"' <>
 246        (if isStatic then text "static" else empty) <+>
 247        (text (case kind of { DNMethod -> "method" ; DNField -> "field"; DNConstructor -> "ctor" })) <+>
 248        (if null ass then char ' ' else char '[' <> text ass <> char ']') <>
 249        text nm <>
 250       char '"'
 251 \end{code}
 252
 253
 254
 255 %************************************************************************
 256 %*                                                                      *
 257 \subsubsection{Misc}
 258 %*                                                                      *
 259 %************************************************************************
 260
 261 \begin{code}
 262 {-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
 263 instance Binary ForeignCall where
 264     put_ bh (CCall aa) = do
 265             putByte bh 0
 266             put_ bh aa
 267     put_ bh (DNCall ab) = do
 268             putByte bh 1
 269             put_ bh ab
 270     get bh = do
 271             h <- getByte bh
 272             case h of
 273               0 -> do aa <- get bh
 274                       return (CCall aa)
 275               _ -> do ab <- get bh
 276                       return (DNCall ab)
 277
 278 instance Binary Safety where
 279     put_ bh (PlaySafe aa) = do
 280             putByte bh 0
 281             put_ bh aa
 282     put_ bh PlayRisky = do
 283             putByte bh 1
 284     get bh = do
 285             h <- getByte bh
 286             case h of
 287               0 -> do aa <- get bh
 288                       return (PlaySafe aa)
 289               _ -> do return PlayRisky
 290
 291 instance Binary CExportSpec where
 292     put_ bh (CExportStatic aa ab) = do
 293             put_ bh aa
 294             put_ bh ab
 295     get bh = do
 296           aa <- get bh
 297           ab <- get bh
 298           return (CExportStatic aa ab)
 299
 300 instance Binary CCallSpec where
 301     put_ bh (CCallSpec aa ab ac) = do
 302             put_ bh aa
 303             put_ bh ab
 304             put_ bh ac
 305     get bh = do
 306           aa <- get bh
 307           ab <- get bh
 308           ac <- get bh
 309           return (CCallSpec aa ab ac)
 310
 311 instance Binary CCallTarget where
 312     put_ bh (StaticTarget aa) = do
 313             putByte bh 0
 314             put_ bh aa
 315     put_ bh DynamicTarget = do
 316             putByte bh 1
 317     get bh = do
 318             h <- getByte bh
 319             case h of
 320               0 -> do aa <- get bh
 321                       return (StaticTarget aa)
 322               _ -> do return DynamicTarget
 323
 324 instance Binary CCallConv where
 325     put_ bh CCallConv = do
 326             putByte bh 0
 327     put_ bh StdCallConv = do
 328             putByte bh 1
 329     get bh = do
 330             h <- getByte bh
 331             case h of
 332               0 -> do return CCallConv
 333               _ -> do return StdCallConv
 334
 335 instance Binary DNCallSpec where
 336     put_ bh (DNCallSpec isStatic kind ass nm _ _) = do
 337             put_ bh isStatic
 338             put_ bh kind
 339             put_ bh ass
 340             put_ bh nm
 341     get bh = do
 342           isStatic <- get bh
 343           kind     <- get bh
 344           ass      <- get bh
 345           nm       <- get bh
 346           return (DNCallSpec isStatic kind ass nm [] undefined)
 347
 348 instance Binary DNKind where
 349     put_ bh DNMethod = do
 350             putByte bh 0
 351     put_ bh DNField = do
 352             putByte bh 1
 353     put_ bh DNConstructor = do
 354             putByte bh 2
 355     get bh = do
 356             h <- getByte bh
 357             case h of
 358               0 -> do return DNMethod
 359               1 -> do return DNField
 360               _ -> do return DNConstructor
 361
 362 instance Binary DNType where
 363     put_ bh DNByte = do
 364             putByte bh 0
 365     put_ bh DNBool = do
 366             putByte bh 1
 367     put_ bh DNChar = do
 368             putByte bh 2
 369     put_ bh DNDouble = do
 370             putByte bh 3
 371     put_ bh DNFloat = do
 372             putByte bh 4
 373     put_ bh DNInt = do
 374             putByte bh 5
 375     put_ bh DNInt8 = do
 376             putByte bh 6
 377     put_ bh DNInt16 = do
 378             putByte bh 7
 379     put_ bh DNInt32 = do
 380             putByte bh 8
 381     put_ bh DNInt64 = do
 382             putByte bh 9
 383     put_ bh DNWord8 = do
 384             putByte bh 10
 385     put_ bh DNWord16 = do
 386             putByte bh 11
 387     put_ bh DNWord32 = do
 388             putByte bh 12
 389     put_ bh DNWord64 = do
 390             putByte bh 13
 391     put_ bh DNPtr = do
 392             putByte bh 14
 393     put_ bh DNUnit = do
 394             putByte bh 15
 395     put_ bh DNObject = do
 396             putByte bh 16
 397     put_ bh DNString = do
 398             putByte bh 17
 399
 400     get bh = do
 401             h <- getByte bh
 402             case h of
 403               0 -> return DNByte
 404               1 -> return DNBool
 405               2 -> return DNChar
 406               3 -> return DNDouble
 407               4 -> return DNFloat
 408               5 -> return DNInt
 409               6 -> return DNInt8
 410               7 -> return DNInt16
 411               8 -> return DNInt32
 412               9 -> return DNInt64
 413               10 -> return DNWord8
 414               11 -> return DNWord16
 415               12 -> return DNWord32
 416               13 -> return DNWord64
 417               14 -> return DNPtr
 418               15 -> return DNUnit
 419               16 -> return DNObject
 420               17 -> return DNString
 421
 422 --  Imported from other files :-
 423
 424 \end{code}