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