ForeignCall.lhs 10.3 KB
Newer Older
1 2 3 4 5 6 7 8
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[Foreign]{Foreign calls}

\begin{code}
module ForeignCall (
	ForeignCall(..),
sof's avatar
sof committed
9
	Safety(..), playSafe, playThreadSafe,
10

11
	CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
12
	CCallSpec(..), 
13
	CCallTarget(..), isDynamicTarget,
14 15
	CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,

sof's avatar
sof committed
16
	DNCallSpec(..), DNKind(..), DNType(..),
17
	withDNTypes
18 19 20 21
    ) where

#include "HsVersions.h"

22 23
import FastString	( FastString, unpackFS )
import Char		( isAlphaNum )
24
import Binary
25 26 27 28 29 30 31 32 33 34 35 36 37
import Outputable
\end{code}


%************************************************************************
%*									*
\subsubsection{Data types}
%*									*
%************************************************************************

\begin{code}
data ForeignCall
  = CCall	CCallSpec
38
  | DNCall	DNCallSpec
39 40
  deriving( Eq )		-- We compare them when seeing if an interface
				-- has changed (for versioning purposes)
41
  {-! derive: Binary !-}
42 43 44 45

-- We may need more clues to distinguish foreign calls
-- but this simple printer will do for now
instance Outputable ForeignCall where
chak's avatar
chak committed
46
  ppr (CCall cc)  = ppr cc		
47
  ppr (DNCall dn) = ppr dn
48 49 50 51 52 53 54 55
\end{code}

  
\begin{code}
data Safety
  = PlaySafe		-- Might invoke Haskell GC, or do a call back, or
			-- switch threads, etc.  So make sure things are
			-- tidy before the call
sof's avatar
sof committed
56 57 58 59
	Bool            -- => True, external function is also re-entrant.
			--    [if supported, RTS arranges for the external call
			--    to be executed by a separate OS thread, i.e.,
			--    _concurrently_ to the execution of other Haskell threads.]
60 61 62 63 64

  | PlayRisky		-- None of the above can happen; the call will return
			-- without interacting with the runtime system at all
  deriving( Eq, Show )
	-- Show used just for Show Lex.Token, I think
65
  {-! derive: Binary !-}
66 67

instance Outputable Safety where
sof's avatar
sof committed
68 69
  ppr (PlaySafe False) = ptext SLIT("safe")
  ppr (PlaySafe True)  = ptext SLIT("threadsafe")
70 71
  ppr PlayRisky = ptext SLIT("unsafe")

sof's avatar
sof committed
72 73 74 75 76 77 78
playSafe :: Safety -> Bool
playSafe PlaySafe{} = True
playSafe PlayRisky  = False

playThreadSafe :: Safety -> Bool
playThreadSafe (PlaySafe x) = x
playThreadSafe _ = False
79 80 81 82 83 84 85 86 87 88
\end{code}


%************************************************************************
%*									*
\subsubsection{Calling C}
%*									*
%************************************************************************

\begin{code}
89 90 91 92
data CExportSpec
  = CExportStatic		-- foreign export ccall foo :: ty
	CLabelString		-- C Name of exported function
	CCallConv
93
  {-! derive: Binary !-}
94

95 96 97 98 99
data CCallSpec
  =  CCallSpec	CCallTarget	-- What to call
		CCallConv	-- Calling convention to use.
		Safety
  deriving( Eq )
100
  {-! derive: Binary !-}
101 102 103 104 105 106 107 108 109
\end{code}

The call target:

\begin{code}
data CCallTarget
  = StaticTarget  CLabelString  -- An "unboxed" ccall# to `fn'.
  | DynamicTarget 		-- First argument (an Addr#) is the function pointer
  deriving( Eq )
110
  {-! derive: Binary !-}
111

112
isDynamicTarget :: CCallTarget -> Bool
113 114
isDynamicTarget DynamicTarget = True
isDynamicTarget other	      = False
115 116 117
\end{code}


118 119 120 121 122 123 124 125 126 127 128
Stuff to do with calling convention:

ccall:		Caller allocates parameters, *and* deallocates them.

stdcall: 	Caller allocates parameters, callee deallocates.
		Function name has @N after it, where N is number of arg bytes
		e.g.  _Foo@8

ToDo: The stdcall calling convention is x86 (win32) specific,
so perhaps we should emit a warning if it's being used on other
platforms.
129 130

\begin{code}
131
data CCallConv = CCallConv | StdCallConv | CmmCallConv
132 133
  deriving (Eq)
  {-! derive: Binary !-}
134 135

instance Outputable CCallConv where
chak's avatar
chak committed
136 137
  ppr StdCallConv = ptext SLIT("stdcall")
  ppr CCallConv   = ptext SLIT("ccall")
138
  ppr CmmCallConv = ptext SLIT("C--")
139 140 141 142 143 144 145 146 147 148 149 150 151 152

defaultCCallConv :: CCallConv
defaultCCallConv = CCallConv

ccallConvToInt :: CCallConv -> Int
ccallConvToInt StdCallConv = 0
ccallConvToInt CCallConv   = 1
\end{code}

Generate the gcc attribute corresponding to the given
calling convention (used by PprAbsC):

\begin{code}
ccallConvAttribute :: CCallConv -> String
153
ccallConvAttribute StdCallConv = "__attribute__((__stdcall__))"
154 155 156
ccallConvAttribute CCallConv   = ""
\end{code}

157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172
\begin{code}
type CLabelString = FastString		-- A C label, completely unencoded

pprCLabelString :: CLabelString -> SDoc
pprCLabelString lbl = ftext lbl

isCLabelString :: CLabelString -> Bool	-- Checks to see if this is a valid C label
isCLabelString lbl 
  = all ok (unpackFS lbl)
  where
    ok c = isAlphaNum c || c == '_' || c == '.'
	-- The '.' appears in e.g. "foo.so" in the 
	-- module part of a ExtName.  Maybe it should be separate
\end{code}


173 174 175
Printing into C files:

\begin{code}
176 177 178
instance Outputable CExportSpec where
  ppr (CExportStatic str _) = pprCLabelString str

179
instance Outputable CCallSpec where
180 181
  ppr (CCallSpec fun cconv safety)
    = hcat [ ifPprDebug callconv, ppr_fun fun ]
182
    where
183 184 185 186 187 188 189
      callconv = text "{-" <> ppr cconv <> text "-}"

      gc_suf | playSafe safety = text "_GC"
	     | otherwise       = empty

      ppr_fun DynamicTarget     = text "__dyn_ccall" <> gc_suf <+> text "\"\""
      ppr_fun (StaticTarget fn) = text "__ccall"     <> gc_suf <+> pprCLabelString fn
190 191 192 193 194
\end{code}


%************************************************************************
%*									*
sof's avatar
sof committed
195
\subsubsection{.NET interop}
196 197 198 199
%*									*
%************************************************************************

\begin{code}
sof's avatar
sof committed
200 201 202 203 204 205 206 207 208 209 210 211 212 213 214
data DNCallSpec = 
	DNCallSpec Bool       -- True => static method/field
		   DNKind     -- what type of access
		   String     -- assembly
		   String     -- fully qualified method/field name.
		   [DNType]   -- argument types.
		   DNType     -- result type.
    deriving ( Eq )
  {-! derive: Binary !-}

data DNKind
  = DNMethod
  | DNField
  | DNConstructor
    deriving ( Eq )
215
  {-! derive: Binary !-}
216

sof's avatar
sof committed
217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242
data DNType
  = DNByte
  | DNBool
  | DNChar
  | DNDouble
  | DNFloat
  | DNInt
  | DNInt8
  | DNInt16
  | DNInt32
  | DNInt64
  | DNWord8
  | DNWord16
  | DNWord32
  | DNWord64
  | DNPtr
  | DNUnit
  | DNObject
  | DNString
    deriving ( Eq )
  {-! derive: Binary !-}

withDNTypes :: DNCallSpec -> [DNType] -> DNType -> DNCallSpec
withDNTypes (DNCallSpec isStatic k assem nm _ _) argTys resTy
  = DNCallSpec isStatic k assem nm argTys resTy

243
instance Outputable DNCallSpec where
sof's avatar
sof committed
244 245 246 247 248 249 250
  ppr (DNCallSpec isStatic kind ass nm _ _ ) 
    = char '"' <> 
       (if isStatic then text "static" else empty) <+>
       (text (case kind of { DNMethod -> "method" ; DNField -> "field"; DNConstructor -> "ctor" })) <+>
       (if null ass then char ' ' else char '[' <> text ass <> char ']') <>
       text nm <> 
      char '"'
251 252 253 254 255 256 257 258 259 260
\end{code}



%************************************************************************
%*									*
\subsubsection{Misc}
%*									*
%************************************************************************

261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321
\begin{code}
{-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
instance Binary ForeignCall where
    put_ bh (CCall aa) = do
	    putByte bh 0
	    put_ bh aa
    put_ bh (DNCall ab) = do
	    putByte bh 1
	    put_ bh ab
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do aa <- get bh
		      return (CCall aa)
	      _ -> do ab <- get bh
		      return (DNCall ab)

instance Binary Safety where
    put_ bh (PlaySafe aa) = do
	    putByte bh 0
	    put_ bh aa
    put_ bh PlayRisky = do
	    putByte bh 1
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do aa <- get bh
		      return (PlaySafe aa)
	      _ -> do return PlayRisky

instance Binary CExportSpec where
    put_ bh (CExportStatic aa ab) = do
	    put_ bh aa
	    put_ bh ab
    get bh = do
	  aa <- get bh
	  ab <- get bh
	  return (CExportStatic aa ab)

instance Binary CCallSpec where
    put_ bh (CCallSpec aa ab ac) = do
	    put_ bh aa
	    put_ bh ab
	    put_ bh ac
    get bh = do
	  aa <- get bh
	  ab <- get bh
	  ac <- get bh
	  return (CCallSpec aa ab ac)

instance Binary CCallTarget where
    put_ bh (StaticTarget aa) = do
	    putByte bh 0
	    put_ bh aa
    put_ bh DynamicTarget = do
	    putByte bh 1
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do aa <- get bh
		      return (StaticTarget aa)
322
	      _ -> do return DynamicTarget
323 324 325 326 327 328 329 330 331 332 333 334 335

instance Binary CCallConv where
    put_ bh CCallConv = do
	    putByte bh 0
    put_ bh StdCallConv = do
	    putByte bh 1
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do return CCallConv
	      _ -> do return StdCallConv

instance Binary DNCallSpec where
sof's avatar
sof committed
336 337 338 339 340
    put_ bh (DNCallSpec isStatic kind ass nm _ _) = do
            put_ bh isStatic
	    put_ bh kind
	    put_ bh ass
	    put_ bh nm
341
    get bh = do
sof's avatar
sof committed
342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420
          isStatic <- get bh
	  kind     <- get bh
	  ass      <- get bh
	  nm       <- get bh
	  return (DNCallSpec isStatic kind ass nm [] undefined)

instance Binary DNKind where
    put_ bh DNMethod = do
	    putByte bh 0
    put_ bh DNField = do
	    putByte bh 1
    put_ bh DNConstructor = do
	    putByte bh 2
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do return DNMethod
	      1 -> do return DNField
	      _ -> do return DNConstructor

instance Binary DNType where
    put_ bh DNByte = do
	    putByte bh 0
    put_ bh DNBool = do
	    putByte bh 1
    put_ bh DNChar = do
	    putByte bh 2
    put_ bh DNDouble = do
	    putByte bh 3
    put_ bh DNFloat = do
	    putByte bh 4
    put_ bh DNInt = do
	    putByte bh 5
    put_ bh DNInt8 = do
	    putByte bh 6
    put_ bh DNInt16 = do
	    putByte bh 7
    put_ bh DNInt32 = do
	    putByte bh 8
    put_ bh DNInt64 = do
	    putByte bh 9
    put_ bh DNWord8 = do
	    putByte bh 10
    put_ bh DNWord16 = do
	    putByte bh 11
    put_ bh DNWord32 = do
	    putByte bh 12
    put_ bh DNWord64 = do
	    putByte bh 13
    put_ bh DNPtr = do
	    putByte bh 14
    put_ bh DNUnit = do
	    putByte bh 15
    put_ bh DNObject = do
	    putByte bh 16
    put_ bh DNString = do
	    putByte bh 17

    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> return DNByte
	      1 -> return DNBool
	      2 -> return DNChar
  	      3 -> return DNDouble
  	      4 -> return DNFloat
  	      5 -> return DNInt
  	      6 -> return DNInt8
  	      7 -> return DNInt16
  	      8 -> return DNInt32
	      9 -> return DNInt64
	      10 -> return DNWord8
	      11 -> return DNWord16
	      12 -> return DNWord32
	      13 -> return DNWord64
	      14 -> return DNPtr
	      15 -> return DNUnit
	      16 -> return DNObject
	      17 -> return DNString
421 422 423 424

--  Imported from other files :-

\end{code}