ForeignCall.lhs 10.8 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(..),
16
	Safety(..), playSafe,
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
    ) where

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


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

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

-- 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
51
  ppr (CCall cc)  = ppr cc		
52
  ppr (DNCall dn) = ppr dn
53 54 55 56 57 58 59
\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
60 61 62 63 64 65 66 67
			-- tidy before the call. Additionally, in the threaded
			-- RTS we arrange for the external call to be executed
			-- by a separate OS thread, i.e., _concurrently_ to the
			-- execution of other Haskell threads.

      Bool              -- Indicates the deprecated "threadsafe" annotation
                        -- which is now an alias for "safe". This information
                        -- is never used except to emit a deprecation warning.
68 69 70 71 72

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

instance Outputable Safety where
Ian Lynagh's avatar
Ian Lynagh committed
76 77 78
  ppr (PlaySafe False) = ptext (sLit "safe")
  ppr (PlaySafe True)  = ptext (sLit "threadsafe")
  ppr PlayRisky = ptext (sLit "unsafe")
79

sof's avatar
sof committed
80 81 82
playSafe :: Safety -> Bool
playSafe PlaySafe{} = True
playSafe PlayRisky  = False
83 84 85 86 87 88 89 90 91 92
\end{code}


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

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

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

116
isDynamicTarget :: CCallTarget -> Bool
117
isDynamicTarget DynamicTarget = True
Ian Lynagh's avatar
Ian Lynagh committed
118
isDynamicTarget _             = False
119 120 121
\end{code}


122 123 124 125 126 127 128 129 130 131 132
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.
133 134
 
See: http://www.programmersheaven.com/2/Calling-conventions
135 136

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

instance Outputable CCallConv where
Ian Lynagh's avatar
Ian Lynagh committed
142 143 144
  ppr StdCallConv = ptext (sLit "stdcall")
  ppr CCallConv   = ptext (sLit "ccall")
  ppr CmmCallConv = ptext (sLit "C--")
145
  ppr PrimCallConv = ptext (sLit "prim")
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

instance Binary CCallConv where
    put_ bh CCallConv = do
	    putByte bh 0
    put_ bh StdCallConv = do
	    putByte bh 1
336 337
    put_ bh PrimCallConv = do
	    putByte bh 2
338 339 340 341
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do return CCallConv
342 343
	      1 -> do return StdCallConv
	      _ -> do return PrimCallConv
344 345

instance Binary DNCallSpec where
sof's avatar
sof committed
346 347 348 349 350
    put_ bh (DNCallSpec isStatic kind ass nm _ _) = do
            put_ bh isStatic
	    put_ bh kind
	    put_ bh ass
	    put_ bh nm
351
    get bh = do
sof's avatar
sof committed
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 428 429 430
          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
431 432 433 434

--  Imported from other files :-

\end{code}