+++ /dev/null
-%
-% (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}
projects / ghc-hetmet.git / blobdiff