-- 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
--- http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
+{-# LANGUAGE DeriveDataTypeable #-}
module ForeignCall (
ForeignCall(..),
- Safety(..), playSafe, playThreadSafe,
+ Safety(..), playSafe, playInterruptible,
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 FastString
import Binary
import Outputable
+import Module
+
+import Data.Char
+import Data.Data
\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.
+
+ | PlayInterruptible -- Like PlaySafe, but additionally
+ -- the worker thread running this foreign call may
+ -- be unceremoniously killed, so it must be scheduled
+ -- on an unbound thread.
| 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, Data, Typeable )
-- 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")
+ ppr (PlaySafe False) = ptext (sLit "safe")
+ ppr (PlaySafe True) = ptext (sLit "threadsafe")
+ ppr PlayInterruptible = ptext (sLit "interruptible")
+ ppr PlayRisky = ptext (sLit "unsafe")
playSafe :: Safety -> Bool
playSafe PlaySafe{} = True
+playSafe PlayInterruptible = True
playSafe PlayRisky = False
-playThreadSafe :: Safety -> Bool
-playThreadSafe (PlaySafe x) = x
-playThreadSafe _ = False
+playInterruptible :: Safety -> Bool
+playInterruptible PlayInterruptible = True
+playInterruptible _ = False
\end{code}
= CExportStatic -- foreign export ccall foo :: ty
CLabelString -- C Name of exported function
CCallConv
+ deriving (Data, Typeable)
{-! derive: Binary !-}
data CCallSpec
The call target:
\begin{code}
+
+-- | How to call a particular function in C-land.
data CCallTarget
- = StaticTarget CLabelString -- An "unboxed" ccall# to `fn'.
- | DynamicTarget -- First argument (an Addr#) is the function pointer
- deriving( Eq )
+ -- An "unboxed" ccall# to named function in a particular package.
+ = StaticTarget
+ CLabelString -- C-land name of label.
+
+ (Maybe PackageId) -- What package the function is in.
+ -- If Nothing, then it's taken to be in the current package.
+ -- Note: This information is only used for PrimCalls on Windows.
+ -- See CLabel.labelDynamic and CoreToStg.coreToStgApp
+ -- for the difference in representation between PrimCalls
+ -- and ForeignCalls. If the CCallTarget is representing
+ -- a regular ForeignCall then it's safe to set this to Nothing.
+
+ -- The first argument of the import is the name of a function pointer (an Addr#).
+ -- Used when importing a label as "foreign import ccall "dynamic" ..."
+ | DynamicTarget
+
+ deriving( Eq, Data, Typeable )
{-! derive: Binary !-}
isDynamicTarget :: CCallTarget -> Bool
isDynamicTarget DynamicTarget = True
-isDynamicTarget other = False
+isDynamicTarget _ = 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
- deriving (Eq)
+data CCallConv = CCallConv | StdCallConv | CmmCallConv | PrimCallConv
+ deriving (Eq, Data, Typeable)
{-! derive: Binary !-}
instance Outputable CCallConv where
- ppr StdCallConv = ptext SLIT("stdcall")
- ppr CCallConv = ptext SLIT("ccall")
- ppr CmmCallConv = ptext SLIT("C--")
+ ppr StdCallConv = ptext (sLit "stdcall")
+ ppr CCallConv = ptext (sLit "ccall")
+ ppr CmmCallConv = ptext (sLit "C--")
+ ppr PrimCallConv = ptext (sLit "prim")
defaultCCallConv :: CCallConv
defaultCCallConv = CCallConv
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}
+ ppr_fun (StaticTarget fn Nothing)
+ = text "__pkg_ccall" <> gc_suf <+> pprCLabelString fn
+ ppr_fun (StaticTarget fn (Just pkgId))
+ = text "__pkg_ccall" <> gc_suf <+> ppr pkgId <+> pprCLabelString fn
-%************************************************************************
-%* *
-\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 '"'
+ ppr_fun DynamicTarget
+ = text "__dyn_ccall" <> gc_suf <+> text "\"\""
\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 aa
- put_ bh PlayRisky = do
+ put_ bh PlayInterruptible = do
putByte bh 1
+ put_ bh PlayRisky = do
+ putByte bh 2
get bh = do
h <- getByte bh
case h of
0 -> do aa <- get bh
return (PlaySafe aa)
+ 1 -> do return PlayInterruptible
_ -> do return PlayRisky
instance Binary CExportSpec where
return (CCallSpec aa ab ac)
instance Binary CCallTarget where
- put_ bh (StaticTarget aa) = do
+ put_ bh (StaticTarget aa ab) = do
putByte bh 0
put_ bh aa
+ put_ bh ab
put_ bh DynamicTarget = do
putByte bh 1
get bh = do
h <- getByte bh
case h of
0 -> do aa <- get bh
- return (StaticTarget aa)
+ ab <- get bh
+ return (StaticTarget aa ab)
_ -> do return DynamicTarget
instance Binary CCallConv where
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
+ put_ bh PrimCallConv = 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}
projects / ghc-hetmet.git / blobdiff