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  = empty
  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 \begin{code}
 110 data CCallConv = CCallConv | StdCallConv
 111                deriving( Eq )
 112
 113 instance Outputable CCallConv where
 114   ppr StdCallConv = ptext SLIT("__stdcall")
 115   ppr CCallConv   = ptext SLIT("_ccall")
 116
 117 defaultCCallConv :: CCallConv
 118 defaultCCallConv = CCallConv
 119
 120 ccallConvToInt :: CCallConv -> Int
 121 ccallConvToInt StdCallConv = 0
 122 ccallConvToInt CCallConv   = 1
 123 \end{code}
 124
 125 Generate the gcc attribute corresponding to the given
 126 calling convention (used by PprAbsC):
 127
 128 ToDo: The stdcall calling convention is x86 (win32) specific,
 129 so perhaps we should emit a warning if it's being used on other
 130 platforms.
 131
 132 \begin{code}
 133 ccallConvAttribute :: CCallConv -> String
 134 ccallConvAttribute StdCallConv = "__stdcall"
 135 ccallConvAttribute CCallConv   = ""
 136 \end{code}
 137
 138 Printing into C files:
 139
 140 \begin{code}
 141 instance Outputable CExportSpec where
 142   ppr (CExportStatic str _) = pprCLabelString str
 143
 144 instance Outputable CCallSpec where
 145   ppr (CCallSpec fun cconv safety)
 146     = hcat [ ifPprDebug callconv, ppr_fun fun ]
 147     where
 148       callconv = text "{-" <> ppr cconv <> text "-}"
 149
 150       gc_suf | playSafe safety = text "_GC"
 151              | otherwise       = empty
 152
 153       ppr_fun DynamicTarget     = text "__dyn_ccall" <> gc_suf <+> text "\"\""
 154       ppr_fun (StaticTarget fn) = text "__ccall"     <> gc_suf <+> pprCLabelString fn
 155       ppr_fun (CasmTarget   fn) = text "__casm"      <> gc_suf <+> text "``" <> pprCLabelString fn <> text "''"
 156 \end{code}
 157
 158
 159 %************************************************************************
 160 %*                                                                      *
 161 \subsubsection{.NET stuff}
 162 %*                                                                      *
 163 %************************************************************************
 164
 165 \begin{code}
 166 data DNCallSpec = DNCallSpec FastString
 167                     deriving( Eq )
 168
 169 instance Outputable DNCallSpec where
 170   ppr (DNCallSpec s) = text "DotNet" <+> ptext s
 171 \end{code}
 172
 173
 174
 175 %************************************************************************
 176 %*                                                                      *
 177 \subsubsection{Misc}
 178 %*                                                                      *
 179 %************************************************************************
 180
 181 \begin{code}
 182 okToExposeFCall :: ForeignCall -> Bool
 183 -- OK to unfold a Foreign Call in an interface file
 184 -- Yes, unless it's a _casm_
 185 okToExposeFCall (CCall (CCallSpec target _ _)) = not (isCasmTarget target)
 186 okToExposeFCall other                          = True
 187 \end{code}