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

\begin{code}
7
{-# OPTIONS -w #-}
8 9 10
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
Ian Lynagh's avatar
Ian Lynagh committed
11
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
12 13
-- for details

14 15
module ForeignCall (
	ForeignCall(..),
sof's avatar
sof committed
16
	Safety(..), playSafe, playThreadSafe,
17

18
	CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
19
	CCallSpec(..), 
20
	CCallTarget(..), isDynamicTarget,
21 22
	CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,

sof's avatar
sof committed
23
	DNCallSpec(..), DNKind(..), DNType(..),
24
	withDNTypes
25 26 27 28
    ) where

#include "HsVersions.h"

29 30
import FastString	( FastString, unpackFS )
import Char		( isAlphaNum )
31
import Binary
32 33 34 35 36 37 38 39 40 41 42 43 44
import Outputable
\end{code}


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

\begin{code}
data ForeignCall
  = CCall	CCallSpec
45
  | DNCall	DNCallSpec
46 47
  deriving( Eq )		-- We compare them when seeing if an interface
				-- has changed (for versioning purposes)
48
  {-! derive: Binary !-}
49 50 51 52

-- 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
53
  ppr (CCall cc)  = ppr cc		
54
  ppr (DNCall dn) = ppr dn
55 56 57 58 59 60 61 62
\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
63 64 65 66
	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.]
67 68 69 70 71

  | 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
72
  {-! derive: Binary !-}
73 74

instance Outputable Safety where
sof's avatar
sof committed
75 76
  ppr (PlaySafe False) = ptext SLIT("safe")
  ppr (PlaySafe True)  = ptext SLIT("threadsafe")
77 78
  ppr PlayRisky = ptext SLIT("unsafe")

sof's avatar
sof committed
79 80 81 82 83 84 85
playSafe :: Safety -> Bool
playSafe PlaySafe{} = True
playSafe PlayRisky  = False

playThreadSafe :: Safety -> Bool
playThreadSafe (PlaySafe x) = x
playThreadSafe _ = False
86 87 88 89 90 91 92 93 94 95
\end{code}


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

\begin{code}
96 97 98 99
data CExportSpec
  = CExportStatic		-- foreign export ccall foo :: ty
	CLabelString		-- C Name of exported function
	CCallConv
100
  {-! derive: Binary !-}
101

102 103 104 105 106
data CCallSpec
  =  CCallSpec	CCallTarget	-- What to call
		CCallConv	-- Calling convention to use.
		Safety
  deriving( Eq )
107
  {-! derive: Binary !-}
108 109 110 111 112 113 114 115 116
\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 )
117
  {-! derive: Binary !-}
118

119
isDynamicTarget :: CCallTarget -> Bool
120 121
isDynamicTarget DynamicTarget = True
isDynamicTarget other	      = False
122 123 124
\end{code}


125 126 127 128 129 130 131 132 133 134 135
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.
136 137

\begin{code}
138
data CCallConv = CCallConv | StdCallConv | CmmCallConv
139 140
  deriving (Eq)
  {-! derive: Binary !-}
141 142

instance Outputable CCallConv where
chak's avatar
chak committed
143 144
  ppr StdCallConv = ptext SLIT("stdcall")
  ppr CCallConv   = ptext SLIT("ccall")
145
  ppr CmmCallConv = ptext SLIT("C--")
146 147 148 149 150 151 152 153 154 155 156 157 158 159

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
160
ccallConvAttribute StdCallConv = "__attribute__((__stdcall__))"
161 162 163
ccallConvAttribute CCallConv   = ""
\end{code}

164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179
\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}


180 181 182
Printing into C files:

\begin{code}
183 184 185
instance Outputable CExportSpec where
  ppr (CExportStatic str _) = pprCLabelString str

186
instance Outputable CCallSpec where
187 188
  ppr (CCallSpec fun cconv safety)
    = hcat [ ifPprDebug callconv, ppr_fun fun ]
189
    where
190 191 192 193 194 195 196
      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
197 198 199 200 201
\end{code}


%************************************************************************
%*									*
sof's avatar
sof committed
202
\subsubsection{.NET interop}
203 204 205 206
%*									*
%************************************************************************

\begin{code}
sof's avatar
sof committed
207 208 209 210 211 212 213 214 215 216 217 218 219 220 221
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 )
222
  {-! derive: Binary !-}
223

sof's avatar
sof committed
224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249
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

250
instance Outputable DNCallSpec where
sof's avatar
sof committed
251 252 253 254 255 256 257
  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 '"'
258 259 260 261 262 263 264 265 266 267
\end{code}



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

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 322 323 324 325 326 327 328
\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)
329
	      _ -> do return DynamicTarget
330 331 332 333 334 335 336 337 338 339 340 341 342

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
343 344 345 346 347
    put_ bh (DNCallSpec isStatic kind ass nm _ _) = do
            put_ bh isStatic
	    put_ bh kind
	    put_ bh ass
	    put_ bh nm
348
    get bh = do
sof's avatar
sof committed
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 421 422 423 424 425 426 427
          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
428 429 430 431

--  Imported from other files :-

\end{code}