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