X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fprelude%2FForeignCall.lhs;h=a92cabdec054a7d542d78a917790527a0624b34b;hp=cec415b46ce489b48641a6295d228e489477886a;hb=83d563cb9ede0ba792836e529b1e2929db926355;hpb=ad94d40948668032189ad22a0ad741ac1f645f50 diff --git a/compiler/prelude/ForeignCall.lhs b/compiler/prelude/ForeignCall.lhs index cec415b..a92cabd 100644 --- a/compiler/prelude/ForeignCall.lhs +++ b/compiler/prelude/ForeignCall.lhs @@ -8,28 +8,27 @@ -- 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} @@ -40,18 +39,14 @@ import Outputable %************************************************************************ \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} @@ -59,30 +54,40 @@ instance Outputable ForeignCall where 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} @@ -97,6 +102,7 @@ data CExportSpec = CExportStatic -- foreign export ccall foo :: ty CLabelString -- C Name of exported function CCallConv + deriving (Data, Typeable) {-! derive: Binary !-} data CCallSpec @@ -110,15 +116,31 @@ 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} @@ -133,16 +155,19 @@ stdcall: Caller allocates parameters, callee deallocates. 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 @@ -192,73 +217,17 @@ instance Outputable CCallSpec where 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} @@ -268,31 +237,23 @@ instance Outputable DNCallSpec where \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 @@ -316,16 +277,18 @@ instance Binary CCallSpec 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 @@ -333,99 +296,12 @@ 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}