X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fprelude%2FForeignCall.lhs;h=a92cabdec054a7d542d78a917790527a0624b34b;hp=015b28e2fe3403f74156aa9186006316bed18166;hb=83d563cb9ede0ba792836e529b1e2929db926355;hpb=71aa4a4723e95b4f27fccf93dcc0a33000010974 diff --git a/compiler/prelude/ForeignCall.lhs b/compiler/prelude/ForeignCall.lhs index 015b28e..a92cabd 100644 --- a/compiler/prelude/ForeignCall.lhs +++ b/compiler/prelude/ForeignCall.lhs @@ -10,24 +10,25 @@ -- any warnings in the module. See -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details +{-# LANGUAGE DeriveDataTypeable #-} module ForeignCall ( ForeignCall(..), - Safety(..), playSafe, + Safety(..), playSafe, playInterruptible, 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 Module + +import Data.Char +import Data.Data \end{code} @@ -38,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} @@ -66,20 +63,31 @@ data Safety -- 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 PlayInterruptible = ptext (sLit "interruptible") ppr PlayRisky = ptext (sLit "unsafe") playSafe :: Safety -> Bool playSafe PlaySafe{} = True +playSafe PlayInterruptible = True playSafe PlayRisky = False + +playInterruptible :: Safety -> Bool +playInterruptible PlayInterruptible = True +playInterruptible _ = False \end{code} @@ -94,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 @@ -107,10 +116,26 @@ 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 @@ -135,7 +160,7 @@ See: http://www.programmersheaven.com/2/Calling-conventions \begin{code} data CCallConv = CCallConv | StdCallConv | CmmCallConv | PrimCallConv - deriving (Eq) + deriving (Eq, Data, Typeable) {-! derive: Binary !-} instance Outputable CCallConv where @@ -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 -%************************************************************************ -%* * -\subsubsection{.NET interop} -%* * -%************************************************************************ + ppr_fun (StaticTarget fn (Just pkgId)) + = text "__pkg_ccall" <> gc_suf <+> ppr pkgId <+> pprCLabelString fn -\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 @@ -341,94 +304,4 @@ instance Binary CCallConv where 0 -> do return CCallConv 1 -> do return StdCallConv _ -> do return PrimCallConv - -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}