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