path: root/compiler/prelude/ForeignCall.lhs

%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[Foreign]{Foreign calls}

\begin{code}
module ForeignCall (
	ForeignCall(..),
	Safety(..), playSafe, playThreadSafe,

	CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
	CCallSpec(..), 
	CCallTarget(..), isDynamicTarget,
	CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,

	DNCallSpec(..), DNKind(..), DNType(..),
	withDNTypes
    ) where

#include "HsVersions.h"

import FastString	( FastString, unpackFS )
import Char		( isAlphaNum )
import Binary
import Outputable
\end{code}


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

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

-- We may need more clues to distinguish foreign calls
-- but this simple printer will do for now
instance Outputable ForeignCall where
  ppr (CCall cc)  = ppr cc		
  ppr (DNCall dn) = ppr dn
\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
	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.]

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

instance Outputable Safety where
  ppr (PlaySafe False) = ptext SLIT("safe")
  ppr (PlaySafe True)  = ptext SLIT("threadsafe")
  ppr PlayRisky = ptext SLIT("unsafe")

playSafe :: Safety -> Bool
playSafe PlaySafe{} = True
playSafe PlayRisky  = False

playThreadSafe :: Safety -> Bool
playThreadSafe (PlaySafe x) = x
playThreadSafe _ = False
\end{code}


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

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

data CCallSpec
  =  CCallSpec	CCallTarget	-- What to call
		CCallConv	-- Calling convention to use.
		Safety
  deriving( Eq )
  {-! derive: Binary !-}
\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 )
  {-! derive: Binary !-}

isDynamicTarget :: CCallTarget -> Bool
isDynamicTarget DynamicTarget = True
isDynamicTarget other	      = False
\end{code}


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.

\begin{code}
data CCallConv = CCallConv | StdCallConv
  deriving (Eq)
  {-! derive: Binary !-}

instance Outputable CCallConv where
  ppr StdCallConv = ptext SLIT("stdcall")
  ppr CCallConv   = ptext SLIT("ccall")

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

\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}


Printing into C files:

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

instance Outputable CCallSpec where
  ppr (CCallSpec fun cconv safety)
    = hcat [ ifPprDebug callconv, ppr_fun fun ]
    where
      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
\end{code}


%************************************************************************
%*									*
\subsubsection{.NET interop}
%*									*
%************************************************************************

\begin{code}
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 )
  {-! derive: Binary !-}

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

instance Outputable DNCallSpec where
  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 '"'
\end{code}



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

\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)
	      _ -> do return DynamicTarget

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
    put_ bh (DNCallSpec isStatic kind ass nm _ _) = do
            put_ bh isStatic
	    put_ bh kind
	    put_ bh ass
	    put_ bh nm
    get bh = do
          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

--  Imported from other files :-

\end{code}