ghc/compiler/prelude/ForeignCall.lhs

   1 {-% DrIFT (Automatic class derivations for Haskell) v1.1 %-}
   2 {-% DrIFT (Automatic class derivations for Haskell) v1.1 %-}
   3 %
   4 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   5 %
   6 \section[Foreign]{Foreign calls}
   7
   8 \begin{code}
   9 module ForeignCall (
  10         ForeignCall(..),
  11         Safety(..), playSafe, playThreadSafe,
  12
  13         CExportSpec(..),
  14         CCallSpec(..),
  15         CCallTarget(..), isDynamicTarget, isCasmTarget,
  16         CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,
  17
  18         DNCallSpec(..),
  19
  20         okToExposeFCall
  21     ) where
  22
  23 #include "HsVersions.h"
  24
  25 import CStrings         ( CLabelString, pprCLabelString )
  26 import FastString       ( FastString )
  27 import Binary
  28 import Outputable
  29 \end{code}
  30
  31
  32 %************************************************************************
  33 %*                                                                      *
  34 \subsubsection{Data types}
  35 %*                                                                      *
  36 %************************************************************************
  37
  38 \begin{code}
  39 data ForeignCall
  40   = CCall       CCallSpec
  41   | DNCall      DNCallSpec
  42   deriving( Eq )                -- We compare them when seeing if an interface
  43                                 -- has changed (for versioning purposes)
  44   {-! derive: Binary !-}
  45
  46 -- We may need more clues to distinguish foreign calls
  47 -- but this simple printer will do for now
  48 instance Outputable ForeignCall where
  49   ppr (CCall cc)  = ppr cc
  50   ppr (DNCall dn) = ppr dn
  51 \end{code}
  52
  53
  54 \begin{code}
  55 data Safety
  56   = PlaySafe            -- Might invoke Haskell GC, or do a call back, or
  57                         -- switch threads, etc.  So make sure things are
  58                         -- tidy before the call
  59         Bool            -- => True, external function is also re-entrant.
  60                         --    [if supported, RTS arranges for the external call
  61                         --    to be executed by a separate OS thread, i.e.,
  62                         --    _concurrently_ to the execution of other Haskell threads.]
  63
  64   | PlayRisky           -- None of the above can happen; the call will return
  65                         -- without interacting with the runtime system at all
  66   deriving( Eq, Show )
  67         -- Show used just for Show Lex.Token, I think
  68   {-! derive: Binary !-}
  69
  70 instance Outputable Safety where
  71   ppr (PlaySafe False) = ptext SLIT("safe")
  72   ppr (PlaySafe True)  = ptext SLIT("threadsafe")
  73   ppr PlayRisky = ptext SLIT("unsafe")
  74
  75 playSafe :: Safety -> Bool
  76 playSafe PlaySafe{} = True
  77 playSafe PlayRisky  = False
  78
  79 playThreadSafe :: Safety -> Bool
  80 playThreadSafe (PlaySafe x) = x
  81 playThreadSafe _ = False
  82 \end{code}
  83
  84
  85 %************************************************************************
  86 %*                                                                      *
  87 \subsubsection{Calling C}
  88 %*                                                                      *
  89 %************************************************************************
  90
  91 \begin{code}
  92 data CExportSpec
  93   = CExportStatic               -- foreign export ccall foo :: ty
  94         CLabelString            -- C Name of exported function
  95         CCallConv
  96   {-! derive: Binary !-}
  97
  98 data CCallSpec
  99   =  CCallSpec  CCallTarget     -- What to call
 100                 CCallConv       -- Calling convention to use.
 101                 Safety
 102   deriving( Eq )
 103   {-! derive: Binary !-}
 104 \end{code}
 105
 106 The call target:
 107
 108 \begin{code}
 109 data CCallTarget
 110   = StaticTarget  CLabelString  -- An "unboxed" ccall# to `fn'.
 111   | DynamicTarget               -- First argument (an Addr#) is the function pointer
 112   | CasmTarget    CLabelString  -- Inline C code (now seriously deprecated)
 113   deriving( Eq )
 114   {-! derive: Binary !-}
 115
 116 isDynamicTarget, isCasmTarget :: CCallTarget -> Bool
 117 isDynamicTarget DynamicTarget = True
 118 isDynamicTarget other         = False
 119
 120 isCasmTarget (CasmTarget _) = True
 121 isCasmTarget other          = False
 122 \end{code}
 123
 124
 125 Stuff to do with calling convention:
 126
 127 ccall:          Caller allocates parameters, *and* deallocates them.
 128
 129 stdcall:        Caller allocates parameters, callee deallocates.
 130                 Function name has @N after it, where N is number of arg bytes
 131                 e.g.  _Foo@8
 132
 133 ToDo: The stdcall calling convention is x86 (win32) specific,
 134 so perhaps we should emit a warning if it's being used on other
 135 platforms.
 136
 137 \begin{code}
 138 data CCallConv = CCallConv | StdCallConv
 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
 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 = "__stdcall"
 160 ccallConvAttribute CCallConv   = ""
 161 \end{code}
 162
 163 Printing into C files:
 164
 165 \begin{code}
 166 instance Outputable CExportSpec where
 167   ppr (CExportStatic str _) = pprCLabelString str
 168
 169 instance Outputable CCallSpec where
 170   ppr (CCallSpec fun cconv safety)
 171     = hcat [ ifPprDebug callconv, ppr_fun fun ]
 172     where
 173       callconv = text "{-" <> ppr cconv <> text "-}"
 174
 175       gc_suf | playSafe safety = text "_GC"
 176              | otherwise       = empty
 177
 178       ppr_fun DynamicTarget     = text "__dyn_ccall" <> gc_suf <+> text "\"\""
 179       ppr_fun (StaticTarget fn) = text "__ccall"     <> gc_suf <+> pprCLabelString fn
 180       ppr_fun (CasmTarget   fn) = text "__casm"      <> gc_suf <+> text "``" <> pprCLabelString fn <> text "''"
 181 \end{code}
 182
 183
 184 %************************************************************************
 185 %*                                                                      *
 186 \subsubsection{.NET stuff}
 187 %*                                                                      *
 188 %************************************************************************
 189
 190 \begin{code}
 191 data DNCallSpec = DNCallSpec FastString
 192   deriving (Eq)
 193   {-! derive: Binary !-}
 194
 195 instance Outputable DNCallSpec where
 196   ppr (DNCallSpec s) = char '"' <> ftext s <> char '"'
 197 \end{code}
 198
 199
 200
 201 %************************************************************************
 202 %*                                                                      *
 203 \subsubsection{Misc}
 204 %*                                                                      *
 205 %************************************************************************
 206
 207 \begin{code}
 208 okToExposeFCall :: ForeignCall -> Bool
 209 -- OK to unfold a Foreign Call in an interface file
 210 -- Yes, unless it's a _casm_
 211 okToExposeFCall (CCall (CCallSpec target _ _)) = not (isCasmTarget target)
 212 okToExposeFCall other                          = True
 213 \end{code}
 214 \begin{code}
 215 {-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
 216 instance Binary ForeignCall where
 217     put_ bh (CCall aa) = do
 218             putByte bh 0
 219             put_ bh aa
 220     put_ bh (DNCall ab) = do
 221             putByte bh 1
 222             put_ bh ab
 223     get bh = do
 224             h <- getByte bh
 225             case h of
 226               0 -> do aa <- get bh
 227                       return (CCall aa)
 228               _ -> do ab <- get bh
 229                       return (DNCall ab)
 230
 231 instance Binary Safety where
 232     put_ bh (PlaySafe aa) = do
 233             putByte bh 0
 234             put_ bh aa
 235     put_ bh PlayRisky = do
 236             putByte bh 1
 237     get bh = do
 238             h <- getByte bh
 239             case h of
 240               0 -> do aa <- get bh
 241                       return (PlaySafe aa)
 242               _ -> do return PlayRisky
 243
 244 instance Binary CExportSpec where
 245     put_ bh (CExportStatic aa ab) = do
 246             put_ bh aa
 247             put_ bh ab
 248     get bh = do
 249           aa <- get bh
 250           ab <- get bh
 251           return (CExportStatic aa ab)
 252
 253 instance Binary CCallSpec where
 254     put_ bh (CCallSpec aa ab ac) = do
 255             put_ bh aa
 256             put_ bh ab
 257             put_ bh ac
 258     get bh = do
 259           aa <- get bh
 260           ab <- get bh
 261           ac <- get bh
 262           return (CCallSpec aa ab ac)
 263
 264 instance Binary CCallTarget where
 265     put_ bh (StaticTarget aa) = do
 266             putByte bh 0
 267             put_ bh aa
 268     put_ bh DynamicTarget = do
 269             putByte bh 1
 270     put_ bh (CasmTarget ab) = do
 271             putByte bh 2
 272             put_ bh ab
 273     get bh = do
 274             h <- getByte bh
 275             case h of
 276               0 -> do aa <- get bh
 277                       return (StaticTarget aa)
 278               1 -> do return DynamicTarget
 279               _ -> do ab <- get bh
 280                       return (CasmTarget ab)
 281
 282 instance Binary CCallConv where
 283     put_ bh CCallConv = do
 284             putByte bh 0
 285     put_ bh StdCallConv = do
 286             putByte bh 1
 287     get bh = do
 288             h <- getByte bh
 289             case h of
 290               0 -> do return CCallConv
 291               _ -> do return StdCallConv
 292
 293 instance Binary DNCallSpec where
 294     put_ bh (DNCallSpec aa) = do
 295             put_ bh aa
 296     get bh = do
 297           aa <- get bh
 298           return (DNCallSpec aa)
 299
 300 --  Imported from other files :-
 301
 302 \end{code}