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 | PrimCallConv
 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   ppr PrimCallConv = ptext (sLit "prim")
 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     put_ bh PrimCallConv = do
 337             putByte bh 2
 338     get bh = do
 339             h <- getByte bh
 340             case h of
 341               0 -> do return CCallConv
 342               1 -> do return StdCallConv
 343               _ -> do return PrimCallConv
 344
 345 instance Binary DNCallSpec where
 346     put_ bh (DNCallSpec isStatic kind ass nm _ _) = do
 347             put_ bh isStatic
 348             put_ bh kind
 349             put_ bh ass
 350             put_ bh nm
 351     get bh = do
 352           isStatic <- get bh
 353           kind     <- get bh
 354           ass      <- get bh
 355           nm       <- get bh
 356           return (DNCallSpec isStatic kind ass nm [] undefined)
 357
 358 instance Binary DNKind where
 359     put_ bh DNMethod = do
 360             putByte bh 0
 361     put_ bh DNField = do
 362             putByte bh 1
 363     put_ bh DNConstructor = do
 364             putByte bh 2
 365     get bh = do
 366             h <- getByte bh
 367             case h of
 368               0 -> do return DNMethod
 369               1 -> do return DNField
 370               _ -> do return DNConstructor
 371
 372 instance Binary DNType where
 373     put_ bh DNByte = do
 374             putByte bh 0
 375     put_ bh DNBool = do
 376             putByte bh 1
 377     put_ bh DNChar = do
 378             putByte bh 2
 379     put_ bh DNDouble = do
 380             putByte bh 3
 381     put_ bh DNFloat = do
 382             putByte bh 4
 383     put_ bh DNInt = do
 384             putByte bh 5
 385     put_ bh DNInt8 = do
 386             putByte bh 6
 387     put_ bh DNInt16 = do
 388             putByte bh 7
 389     put_ bh DNInt32 = do
 390             putByte bh 8
 391     put_ bh DNInt64 = do
 392             putByte bh 9
 393     put_ bh DNWord8 = do
 394             putByte bh 10
 395     put_ bh DNWord16 = do
 396             putByte bh 11
 397     put_ bh DNWord32 = do
 398             putByte bh 12
 399     put_ bh DNWord64 = do
 400             putByte bh 13
 401     put_ bh DNPtr = do
 402             putByte bh 14
 403     put_ bh DNUnit = do
 404             putByte bh 15
 405     put_ bh DNObject = do
 406             putByte bh 16
 407     put_ bh DNString = do
 408             putByte bh 17
 409
 410     get bh = do
 411             h <- getByte bh
 412             case h of
 413               0 -> return DNByte
 414               1 -> return DNBool
 415               2 -> return DNChar
 416               3 -> return DNDouble
 417               4 -> return DNFloat
 418               5 -> return DNInt
 419               6 -> return DNInt8
 420               7 -> return DNInt16
 421               8 -> return DNInt32
 422               9 -> return DNInt64
 423               10 -> return DNWord8
 424               11 -> return DNWord16
 425               12 -> return DNWord32
 426               13 -> return DNWord64
 427               14 -> return DNPtr
 428               15 -> return DNUnit
 429               16 -> return DNObject
 430               17 -> return DNString
 431
 432 --  Imported from other files :-
 433
 434 \end{code}