module ForeignCall (
ForeignCall(..),
- Safety(..), playSafe, playThreadSafe,
+ Safety(..), playSafe,
CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
CCallSpec(..),
CCallTarget(..), isDynamicTarget,
CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,
-
- DNCallSpec(..), DNKind(..), DNType(..),
- withDNTypes
) where
import FastString
-import Char ( isAlphaNum )
import Binary
import Outputable
+
+import Data.Char
\end{code}
%************************************************************************
\begin{code}
-data ForeignCall
- = CCall CCallSpec
- | DNCall DNCallSpec
- deriving( Eq ) -- We compare them when seeing if an interface
- -- has changed (for versioning purposes)
+newtype ForeignCall = CCall CCallSpec
+ deriving Eq
{-! 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}
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.]
+ -- 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.
| PlayRisky -- None of the above can happen; the call will return
-- without interacting with the runtime system at all
- deriving( Eq, Show )
+ deriving ( Eq, Show )
-- Show used just for Show Lex.Token, I think
{-! derive: Binary !-}
playSafe :: Safety -> Bool
playSafe PlaySafe{} = True
playSafe PlayRisky = False
-
-playThreadSafe :: Safety -> Bool
-playThreadSafe (PlaySafe x) = x
-playThreadSafe _ = False
\end{code}
ToDo: The stdcall calling convention is x86 (win32) specific,
so perhaps we should emit a warning if it's being used on other
platforms.
+
+See: http://www.programmersheaven.com/2/Calling-conventions
\begin{code}
-data CCallConv = CCallConv | StdCallConv | CmmCallConv
+data CCallConv = CCallConv | StdCallConv | CmmCallConv | PrimCallConv
deriving (Eq)
{-! derive: Binary !-}
ppr StdCallConv = ptext (sLit "stdcall")
ppr CCallConv = ptext (sLit "ccall")
ppr CmmCallConv = ptext (sLit "C--")
+ ppr PrimCallConv = ptext (sLit "prim")
defaultCCallConv :: CCallConv
defaultCCallConv = CCallConv
%************************************************************************
%* *
-\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)
+ put_ bh (CCall aa) = put_ bh aa
+ get bh = do aa <- get bh; return (CCall aa)
instance Binary Safety where
put_ bh (PlaySafe aa) = 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
+ put_ bh PrimCallConv = 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 :-
-
+ 0 -> do return CCallConv
+ 1 -> do return StdCallConv
+ _ -> do return PrimCallConv
\end{code}