ghc/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 module ForeignCall (
   8         ForeignCall(..),
   9         Safety(..), playSafe,
  10
  11         CExportSpec(..),
  12         CCallSpec(..),
  13         CCallTarget(..), isDynamicTarget, isCasmTarget,
  14         CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,
  15
  16         DNCallSpec(..),
  17
  18         okToExposeFCall
  19     ) where
  20
  21 #include "HsVersions.h"
  22
  23 import CStrings         ( CLabelString, pprCLabelString )
  24 import FastString       ( FastString )
  25 import Outputable
  26 \end{code}
  27
  28
  29 %************************************************************************
  30 %*                                                                      *
  31 \subsubsection{Data types}
  32 %*                                                                      *
  33 %************************************************************************
  34
  35 \begin{code}
  36 data ForeignCall
  37   = CCall       CCallSpec
  38   | DNCall      DNCallSpec
  39   deriving( Eq )                -- We compare them when seeing if an interface
  40                                 -- has changed (for versioning purposes)
  41
  42 -- We may need more clues to distinguish foreign calls
  43 -- but this simple printer will do for now
  44 instance Outputable ForeignCall where
  45   ppr (CCall cc)  = ppr cc
  46   ppr (DNCall dn) = ppr dn
  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
  55
  56   | PlayRisky           -- None of the above can happen; the call will return
  57                         -- without interacting with the runtime system at all
  58   deriving( Eq, Show )
  59         -- Show used just for Show Lex.Token, I think
  60
  61 instance Outputable Safety where
  62   ppr PlaySafe  = ptext SLIT("safe")
  63   ppr PlayRisky = ptext SLIT("unsafe")
  64
  65 playSafe PlaySafe  = True
  66 playSafe PlayRisky = False
  67 \end{code}
  68
  69
  70 %************************************************************************
  71 %*                                                                      *
  72 \subsubsection{Calling C}
  73 %*                                                                      *
  74 %************************************************************************
  75
  76 \begin{code}
  77 data CExportSpec
  78   = CExportStatic               -- foreign export ccall foo :: ty
  79         CLabelString            -- C Name of exported function
  80         CCallConv
  81
  82 data CCallSpec
  83   =  CCallSpec  CCallTarget     -- What to call
  84                 CCallConv       -- Calling convention to use.
  85                 Safety
  86   deriving( Eq )
  87 \end{code}
  88
  89 The call target:
  90
  91 \begin{code}
  92 data CCallTarget
  93   = StaticTarget  CLabelString  -- An "unboxed" ccall# to `fn'.
  94   | DynamicTarget               -- First argument (an Addr#) is the function pointer
  95   | CasmTarget    CLabelString  -- Inline C code (now seriously deprecated)
  96   deriving( Eq )
  97
  98 isDynamicTarget, isCasmTarget :: CCallTarget -> Bool
  99 isDynamicTarget DynamicTarget = True
 100 isDynamicTarget other         = False
 101
 102 isCasmTarget (CasmTarget _) = True
 103 isCasmTarget other          = False
 104 \end{code}
 105
 106
 107 Stuff to do with calling convention:
 108
 109 ccall:          Caller allocates parameters, *and* deallocates them.
 110
 111 stdcall:        Caller allocates parameters, callee deallocates.
 112                 Function name has @N after it, where N is number of arg bytes
 113                 e.g.  _Foo@8
 114
 115 ToDo: The stdcall calling convention is x86 (win32) specific,
 116 so perhaps we should emit a warning if it's being used on other
 117 platforms.
 118
 119 \begin{code}
 120 data CCallConv = CCallConv | StdCallConv
 121                deriving (Eq)
 122
 123 instance Outputable CCallConv where
 124   ppr StdCallConv = ptext SLIT("stdcall")
 125   ppr CCallConv   = ptext SLIT("ccall")
 126
 127 defaultCCallConv :: CCallConv
 128 defaultCCallConv = CCallConv
 129
 130 ccallConvToInt :: CCallConv -> Int
 131 ccallConvToInt StdCallConv = 0
 132 ccallConvToInt CCallConv   = 1
 133 \end{code}
 134
 135 Generate the gcc attribute corresponding to the given
 136 calling convention (used by PprAbsC):
 137
 138 \begin{code}
 139 ccallConvAttribute :: CCallConv -> String
 140 ccallConvAttribute StdCallConv = "__stdcall"
 141 ccallConvAttribute CCallConv   = ""
 142 \end{code}
 143
 144 Printing into C files:
 145
 146 \begin{code}
 147 instance Outputable CExportSpec where
 148   ppr (CExportStatic str _) = pprCLabelString str
 149
 150 instance Outputable CCallSpec where
 151   ppr (CCallSpec fun cconv safety)
 152     = hcat [ ifPprDebug callconv, ppr_fun fun ]
 153     where
 154       callconv = text "{-" <> ppr cconv <> text "-}"
 155
 156       gc_suf | playSafe safety = text "_GC"
 157              | otherwise       = empty
 158
 159       ppr_fun DynamicTarget     = text "__dyn_ccall" <> gc_suf <+> text "\"\""
 160       ppr_fun (StaticTarget fn) = text "__ccall"     <> gc_suf <+> pprCLabelString fn
 161       ppr_fun (CasmTarget   fn) = text "__casm"      <> gc_suf <+> text "``" <> pprCLabelString fn <> text "''"
 162 \end{code}
 163
 164
 165 %************************************************************************
 166 %*                                                                      *
 167 \subsubsection{.NET stuff}
 168 %*                                                                      *
 169 %************************************************************************
 170
 171 \begin{code}
 172 data DNCallSpec = DNCallSpec FastString
 173                 deriving (Eq)
 174
 175 instance Outputable DNCallSpec where
 176   ppr (DNCallSpec s) = char '"' <> ptext s <> char '"'
 177 \end{code}
 178
 179
 180
 181 %************************************************************************
 182 %*                                                                      *
 183 \subsubsection{Misc}
 184 %*                                                                      *
 185 %************************************************************************
 186
 187 \begin{code}
 188 okToExposeFCall :: ForeignCall -> Bool
 189 -- OK to unfold a Foreign Call in an interface file
 190 -- Yes, unless it's a _casm_
 191 okToExposeFCall (CCall (CCallSpec target _ _)) = not (isCasmTarget target)
 192 okToExposeFCall other                          = True
 193 \end{code}