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 {-# LANGUAGE DeriveDataTypeable #-}
  14
  15 module ForeignCall (
  16         ForeignCall(..), isSafeForeignCall,
  17         Safety(..), playSafe, playInterruptible,
  18
  19         CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
  20         CCallSpec(..),
  21         CCallTarget(..), isDynamicTarget,
  22         CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,
  23     ) where
  24
  25 import FastString
  26 import Binary
  27 import Outputable
  28 import Module
  29
  30 import Data.Char
  31 import Data.Data
  32 \end{code}
  33
  34
  35 %************************************************************************
  36 %*                                                                      *
  37 \subsubsection{Data types}
  38 %*                                                                      *
  39 %************************************************************************
  40
  41 \begin{code}
  42 newtype ForeignCall = CCall CCallSpec
  43   deriving Eq
  44   {-! derive: Binary !-}
  45
  46 isSafeForeignCall :: ForeignCall -> Bool
  47 isSafeForeignCall (CCall (CCallSpec _ _ safe)) = playSafe safe
  48
  49 -- We may need more clues to distinguish foreign calls
  50 -- but this simple printer will do for now
  51 instance Outputable ForeignCall where
  52   ppr (CCall cc)  = ppr cc
  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   | PlayInterruptible   -- Like PlaySafe, but additionally
  70                         -- the worker thread running this foreign call may
  71                         -- be unceremoniously killed, so it must be scheduled
  72                         -- on an unbound thread.
  73
  74   | PlayRisky           -- None of the above can happen; the call will return
  75                         -- without interacting with the runtime system at all
  76   deriving ( Eq, Show, Data, Typeable )
  77         -- Show used just for Show Lex.Token, I think
  78   {-! derive: Binary !-}
  79
  80 instance Outputable Safety where
  81   ppr (PlaySafe False) = ptext (sLit "safe")
  82   ppr (PlaySafe True)  = ptext (sLit "threadsafe")
  83   ppr PlayInterruptible = ptext (sLit "interruptible")
  84   ppr PlayRisky = ptext (sLit "unsafe")
  85
  86 playSafe :: Safety -> Bool
  87 playSafe PlaySafe{} = True
  88 playSafe PlayInterruptible = True
  89 playSafe PlayRisky  = False
  90
  91 playInterruptible :: Safety -> Bool
  92 playInterruptible PlayInterruptible = True
  93 playInterruptible _ = False
  94 \end{code}
  95
  96
  97 %************************************************************************
  98 %*                                                                      *
  99 \subsubsection{Calling C}
 100 %*                                                                      *
 101 %************************************************************************
 102
 103 \begin{code}
 104 data CExportSpec
 105   = CExportStatic               -- foreign export ccall foo :: ty
 106         CLabelString            -- C Name of exported function
 107         CCallConv
 108   deriving (Data, Typeable)
 109   {-! derive: Binary !-}
 110
 111 data CCallSpec
 112   =  CCallSpec  CCallTarget     -- What to call
 113                 CCallConv       -- Calling convention to use.
 114                 Safety
 115   deriving( Eq )
 116   {-! derive: Binary !-}
 117 \end{code}
 118
 119 The call target:
 120
 121 \begin{code}
 122
 123 -- | How to call a particular function in C-land.
 124 data CCallTarget
 125   -- An "unboxed" ccall# to named function in a particular package.
 126   = StaticTarget
 127         CLabelString                    -- C-land name of label.
 128
 129         (Maybe PackageId)               -- What package the function is in.
 130                                         -- If Nothing, then it's taken to be in the current package.
 131                                         -- Note: This information is only used for PrimCalls on Windows.
 132                                         --       See CLabel.labelDynamic and CoreToStg.coreToStgApp
 133                                         --       for the difference in representation between PrimCalls
 134                                         --       and ForeignCalls. If the CCallTarget is representing
 135                                         --       a regular ForeignCall then it's safe to set this to Nothing.
 136
 137   -- The first argument of the import is the name of a function pointer (an Addr#).
 138   --    Used when importing a label as "foreign import ccall "dynamic" ..."
 139   | DynamicTarget
 140
 141   deriving( Eq, Data, Typeable )
 142   {-! derive: Binary !-}
 143
 144 isDynamicTarget :: CCallTarget -> Bool
 145 isDynamicTarget DynamicTarget = True
 146 isDynamicTarget _             = False
 147 \end{code}
 148
 149
 150 Stuff to do with calling convention:
 151
 152 ccall:          Caller allocates parameters, *and* deallocates them.
 153
 154 stdcall:        Caller allocates parameters, callee deallocates.
 155                 Function name has @N after it, where N is number of arg bytes
 156                 e.g.  _Foo@8
 157
 158 ToDo: The stdcall calling convention is x86 (win32) specific,
 159 so perhaps we should emit a warning if it's being used on other
 160 platforms.
 161
 162 See: http://www.programmersheaven.com/2/Calling-conventions
 163
 164 \begin{code}
 165 data CCallConv = CCallConv | StdCallConv | CmmCallConv | PrimCallConv
 166   deriving (Eq, Data, Typeable)
 167   {-! derive: Binary !-}
 168
 169 instance Outputable CCallConv where
 170   ppr StdCallConv = ptext (sLit "stdcall")
 171   ppr CCallConv   = ptext (sLit "ccall")
 172   ppr CmmCallConv = ptext (sLit "C--")
 173   ppr PrimCallConv = ptext (sLit "prim")
 174
 175 defaultCCallConv :: CCallConv
 176 defaultCCallConv = CCallConv
 177
 178 ccallConvToInt :: CCallConv -> Int
 179 ccallConvToInt StdCallConv = 0
 180 ccallConvToInt CCallConv   = 1
 181 \end{code}
 182
 183 Generate the gcc attribute corresponding to the given
 184 calling convention (used by PprAbsC):
 185
 186 \begin{code}
 187 ccallConvAttribute :: CCallConv -> String
 188 ccallConvAttribute StdCallConv = "__attribute__((__stdcall__))"
 189 ccallConvAttribute CCallConv   = ""
 190 \end{code}
 191
 192 \begin{code}
 193 type CLabelString = FastString          -- A C label, completely unencoded
 194
 195 pprCLabelString :: CLabelString -> SDoc
 196 pprCLabelString lbl = ftext lbl
 197
 198 isCLabelString :: CLabelString -> Bool  -- Checks to see if this is a valid C label
 199 isCLabelString lbl
 200   = all ok (unpackFS lbl)
 201   where
 202     ok c = isAlphaNum c || c == '_' || c == '.'
 203         -- The '.' appears in e.g. "foo.so" in the
 204         -- module part of a ExtName.  Maybe it should be separate
 205 \end{code}
 206
 207
 208 Printing into C files:
 209
 210 \begin{code}
 211 instance Outputable CExportSpec where
 212   ppr (CExportStatic str _) = pprCLabelString str
 213
 214 instance Outputable CCallSpec where
 215   ppr (CCallSpec fun cconv safety)
 216     = hcat [ ifPprDebug callconv, ppr_fun fun ]
 217     where
 218       callconv = text "{-" <> ppr cconv <> text "-}"
 219
 220       gc_suf | playSafe safety = text "_GC"
 221              | otherwise       = empty
 222
 223       ppr_fun (StaticTarget fn Nothing)
 224         = text "__pkg_ccall" <> gc_suf <+> pprCLabelString fn
 225
 226       ppr_fun (StaticTarget fn (Just pkgId))
 227         = text "__pkg_ccall" <> gc_suf <+> ppr pkgId <+> pprCLabelString fn
 228
 229       ppr_fun DynamicTarget
 230         = text "__dyn_ccall" <> gc_suf <+> text "\"\""
 231 \end{code}
 232
 233
 234 %************************************************************************
 235 %*                                                                      *
 236 \subsubsection{Misc}
 237 %*                                                                      *
 238 %************************************************************************
 239
 240 \begin{code}
 241 {-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
 242 instance Binary ForeignCall where
 243     put_ bh (CCall aa) = put_ bh aa
 244     get bh = do aa <- get bh; return (CCall aa)
 245
 246 instance Binary Safety where
 247     put_ bh (PlaySafe aa) = do
 248             putByte bh 0
 249             put_ bh aa
 250     put_ bh PlayInterruptible = do
 251             putByte bh 1
 252     put_ bh PlayRisky = do
 253             putByte bh 2
 254     get bh = do
 255             h <- getByte bh
 256             case h of
 257               0 -> do aa <- get bh
 258                       return (PlaySafe aa)
 259               1 -> do return PlayInterruptible
 260               _ -> do return PlayRisky
 261
 262 instance Binary CExportSpec where
 263     put_ bh (CExportStatic aa ab) = do
 264             put_ bh aa
 265             put_ bh ab
 266     get bh = do
 267           aa <- get bh
 268           ab <- get bh
 269           return (CExportStatic aa ab)
 270
 271 instance Binary CCallSpec where
 272     put_ bh (CCallSpec aa ab ac) = do
 273             put_ bh aa
 274             put_ bh ab
 275             put_ bh ac
 276     get bh = do
 277           aa <- get bh
 278           ab <- get bh
 279           ac <- get bh
 280           return (CCallSpec aa ab ac)
 281
 282 instance Binary CCallTarget where
 283     put_ bh (StaticTarget aa ab) = do
 284             putByte bh 0
 285             put_ bh aa
 286             put_ bh ab
 287     put_ bh DynamicTarget = do
 288             putByte bh 1
 289     get bh = do
 290             h <- getByte bh
 291             case h of
 292               0 -> do aa <- get bh
 293                       ab <- get bh
 294                       return (StaticTarget aa ab)
 295               _ -> do return DynamicTarget
 296
 297 instance Binary CCallConv where
 298     put_ bh CCallConv = do
 299             putByte bh 0
 300     put_ bh StdCallConv = do
 301             putByte bh 1
 302     put_ bh PrimCallConv = do
 303             putByte bh 2
 304     get bh = do
 305             h <- getByte bh
 306             case h of
 307               0 -> do return CCallConv
 308               1 -> do return StdCallConv
 309               _ -> do return PrimCallConv
 310 \end{code}