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