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     ) where
  23
  24 import FastString
  25 import Binary
  26 import Outputable
  27 import Module
  28
  29 import Data.Char
  30 \end{code}
  31
  32
  33 %************************************************************************
  34 %*                                                                      *
  35 \subsubsection{Data types}
  36 %*                                                                      *
  37 %************************************************************************
  38
  39 \begin{code}
  40 newtype ForeignCall = CCall CCallSpec
  41   deriving Eq
  42   {-! derive: Binary !-}
  43
  44 -- We may need more clues to distinguish foreign calls
  45 -- but this simple printer will do for now
  46 instance Outputable ForeignCall where
  47   ppr (CCall cc)  = ppr cc
  48 \end{code}
  49
  50
  51 \begin{code}
  52 data Safety
  53   = PlaySafe            -- Might invoke Haskell GC, or do a call back, or
  54                         -- switch threads, etc.  So make sure things are
  55                         -- tidy before the call. Additionally, in the threaded
  56                         -- RTS we arrange for the external call to be executed
  57                         -- by a separate OS thread, i.e., _concurrently_ to the
  58                         -- execution of other Haskell threads.
  59
  60       Bool              -- Indicates the deprecated "threadsafe" annotation
  61                         -- which is now an alias for "safe". This information
  62                         -- is never used except to emit a deprecation warning.
  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 \end{code}
  79
  80
  81 %************************************************************************
  82 %*                                                                      *
  83 \subsubsection{Calling C}
  84 %*                                                                      *
  85 %************************************************************************
  86
  87 \begin{code}
  88 data CExportSpec
  89   = CExportStatic               -- foreign export ccall foo :: ty
  90         CLabelString            -- C Name of exported function
  91         CCallConv
  92   {-! derive: Binary !-}
  93
  94 data CCallSpec
  95   =  CCallSpec  CCallTarget     -- What to call
  96                 CCallConv       -- Calling convention to use.
  97                 Safety
  98   deriving( Eq )
  99   {-! derive: Binary !-}
 100 \end{code}
 101
 102 The call target:
 103
 104 \begin{code}
 105
 106 -- | How to call a particular function in C land.
 107 data CCallTarget
 108   -- An "unboxed" ccall# to named function
 109   = StaticTarget  CLabelString
 110
 111   -- The first argument of the import is the name of a function pointer (an Addr#).
 112   --    Used when importing a label as "foreign import ccall "dynamic" ..."
 113   | DynamicTarget
 114
 115   -- An "unboxed" ccall# to a named function from a particular package.
 116   | PackageTarget CLabelString (Maybe PackageId)
 117
 118   deriving( Eq )
 119   {-! derive: Binary !-}
 120
 121 isDynamicTarget :: CCallTarget -> Bool
 122 isDynamicTarget DynamicTarget = True
 123 isDynamicTarget _             = False
 124 \end{code}
 125
 126
 127 Stuff to do with calling convention:
 128
 129 ccall:          Caller allocates parameters, *and* deallocates them.
 130
 131 stdcall:        Caller allocates parameters, callee deallocates.
 132                 Function name has @N after it, where N is number of arg bytes
 133                 e.g.  _Foo@8
 134
 135 ToDo: The stdcall calling convention is x86 (win32) specific,
 136 so perhaps we should emit a warning if it's being used on other
 137 platforms.
 138
 139 See: http://www.programmersheaven.com/2/Calling-conventions
 140
 141 \begin{code}
 142 data CCallConv = CCallConv | StdCallConv | CmmCallConv | PrimCallConv
 143   deriving (Eq)
 144   {-! derive: Binary !-}
 145
 146 instance Outputable CCallConv where
 147   ppr StdCallConv = ptext (sLit "stdcall")
 148   ppr CCallConv   = ptext (sLit "ccall")
 149   ppr CmmCallConv = ptext (sLit "C--")
 150   ppr PrimCallConv = ptext (sLit "prim")
 151
 152 defaultCCallConv :: CCallConv
 153 defaultCCallConv = CCallConv
 154
 155 ccallConvToInt :: CCallConv -> Int
 156 ccallConvToInt StdCallConv = 0
 157 ccallConvToInt CCallConv   = 1
 158 \end{code}
 159
 160 Generate the gcc attribute corresponding to the given
 161 calling convention (used by PprAbsC):
 162
 163 \begin{code}
 164 ccallConvAttribute :: CCallConv -> String
 165 ccallConvAttribute StdCallConv = "__attribute__((__stdcall__))"
 166 ccallConvAttribute CCallConv   = ""
 167 \end{code}
 168
 169 \begin{code}
 170 type CLabelString = FastString          -- A C label, completely unencoded
 171
 172 pprCLabelString :: CLabelString -> SDoc
 173 pprCLabelString lbl = ftext lbl
 174
 175 isCLabelString :: CLabelString -> Bool  -- Checks to see if this is a valid C label
 176 isCLabelString lbl
 177   = all ok (unpackFS lbl)
 178   where
 179     ok c = isAlphaNum c || c == '_' || c == '.'
 180         -- The '.' appears in e.g. "foo.so" in the
 181         -- module part of a ExtName.  Maybe it should be separate
 182 \end{code}
 183
 184
 185 Printing into C files:
 186
 187 \begin{code}
 188 instance Outputable CExportSpec where
 189   ppr (CExportStatic str _) = pprCLabelString str
 190
 191 instance Outputable CCallSpec where
 192   ppr (CCallSpec fun cconv safety)
 193     = hcat [ ifPprDebug callconv, ppr_fun fun ]
 194     where
 195       callconv = text "{-" <> ppr cconv <> text "-}"
 196
 197       gc_suf | playSafe safety = text "_GC"
 198              | otherwise       = empty
 199
 200       ppr_fun DynamicTarget
 201         = text "__dyn_ccall" <> gc_suf <+> text "\"\""
 202
 203       ppr_fun (PackageTarget fn Nothing)
 204         = text "__pkg_ccall" <> gc_suf <+> pprCLabelString fn
 205
 206       ppr_fun (PackageTarget fn (Just pkgId))
 207         = text "__pkg_ccall" <> gc_suf <+> ppr pkgId <+> pprCLabelString fn
 208
 209       ppr_fun (StaticTarget fn)
 210         = text "__ccall"     <> gc_suf <+> pprCLabelString fn
 211 \end{code}
 212
 213
 214 %************************************************************************
 215 %*                                                                      *
 216 \subsubsection{Misc}
 217 %*                                                                      *
 218 %************************************************************************
 219
 220 \begin{code}
 221 {-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
 222 instance Binary ForeignCall where
 223     put_ bh (CCall aa) = put_ bh aa
 224     get bh = do aa <- get bh; return (CCall aa)
 225
 226 instance Binary Safety where
 227     put_ bh (PlaySafe aa) = do
 228             putByte bh 0
 229             put_ bh aa
 230     put_ bh PlayRisky = do
 231             putByte bh 1
 232     get bh = do
 233             h <- getByte bh
 234             case h of
 235               0 -> do aa <- get bh
 236                       return (PlaySafe aa)
 237               _ -> do return PlayRisky
 238
 239 instance Binary CExportSpec where
 240     put_ bh (CExportStatic aa ab) = do
 241             put_ bh aa
 242             put_ bh ab
 243     get bh = do
 244           aa <- get bh
 245           ab <- get bh
 246           return (CExportStatic aa ab)
 247
 248 instance Binary CCallSpec where
 249     put_ bh (CCallSpec aa ab ac) = do
 250             put_ bh aa
 251             put_ bh ab
 252             put_ bh ac
 253     get bh = do
 254           aa <- get bh
 255           ab <- get bh
 256           ac <- get bh
 257           return (CCallSpec aa ab ac)
 258
 259 instance Binary CCallTarget where
 260     put_ bh (StaticTarget aa) = do
 261             putByte bh 0
 262             put_ bh aa
 263     put_ bh DynamicTarget = do
 264             putByte bh 1
 265     put_ bh (PackageTarget aa ab) = do
 266             putByte bh 2
 267             put_ bh aa
 268             put_ bh ab
 269     get bh = do
 270             h <- getByte bh
 271             case h of
 272               0 -> do aa <- get bh
 273                       return (StaticTarget aa)
 274               1 -> do return DynamicTarget
 275               _ -> do aa <- get bh
 276                       ab <- get bh
 277                       return (PackageTarget aa ab)
 278
 279 instance Binary CCallConv where
 280     put_ bh CCallConv = do
 281             putByte bh 0
 282     put_ bh StdCallConv = do
 283             putByte bh 1
 284     put_ bh PrimCallConv = do
 285             putByte bh 2
 286     get bh = do
 287             h <- getByte bh
 288             case h of
 289               0 -> do return CCallConv
 290               1 -> do return StdCallConv
 291               _ -> do return PrimCallConv
 292 \end{code}