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