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