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