X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fprelude%2FForeignCall.lhs;h=87bb94a14862c5167a55e6e913de8241703c4597;hp=578ab3c0df8ec8b9af040528020a14ec80a16fcf;hb=86add45dbfb6f962b65e371143dd467ae783f9e7;hpb=7854ec4b11e117f8514553890851d14a66690fbb diff --git a/compiler/prelude/ForeignCall.lhs b/compiler/prelude/ForeignCall.lhs index 578ab3c..87bb94a 100644 --- a/compiler/prelude/ForeignCall.lhs +++ b/compiler/prelude/ForeignCall.lhs @@ -10,10 +10,11 @@ -- 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, + ForeignCall(..), isSafeForeignCall, + Safety(..), playSafe, playInterruptible, CExportSpec(..), CLabelString, isCLabelString, pprCLabelString, CCallSpec(..), @@ -27,6 +28,7 @@ import Outputable import Module import Data.Char +import Data.Data \end{code} @@ -41,6 +43,9 @@ newtype ForeignCall = CCall CCallSpec deriving Eq {-! derive: Binary !-} +isSafeForeignCall :: ForeignCall -> Bool +isSafeForeignCall (CCall (CCallSpec _ _ safe)) = playSafe safe + -- We may need more clues to distinguish foreign calls -- but this simple printer will do for now instance Outputable ForeignCall where @@ -61,20 +66,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} @@ -89,6 +105,7 @@ data CExportSpec = CExportStatic -- foreign export ccall foo :: ty CLabelString -- C Name of exported function CCallConv + deriving (Data, Typeable) {-! derive: Binary !-} data CCallSpec @@ -103,19 +120,25 @@ The call target: \begin{code} --- | How to call a particular function in C land. +-- | How to call a particular function in C-land. data CCallTarget - -- An "unboxed" ccall# to named function - = StaticTarget CLabelString + -- 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 - - -- An "unboxed" ccall# to a named function from a particular package. - | PackageTarget CLabelString (Maybe PackageId) - deriving( Eq ) + deriving( Eq, Data, Typeable ) {-! derive: Binary !-} isDynamicTarget :: CCallTarget -> Bool @@ -140,7 +163,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 @@ -197,17 +220,14 @@ instance Outputable CCallSpec where gc_suf | playSafe safety = text "_GC" | otherwise = empty - ppr_fun DynamicTarget - = text "__dyn_ccall" <> gc_suf <+> text "\"\"" - - ppr_fun (PackageTarget fn Nothing) + ppr_fun (StaticTarget fn Nothing) = text "__pkg_ccall" <> gc_suf <+> pprCLabelString fn - ppr_fun (PackageTarget fn (Just pkgId)) + ppr_fun (StaticTarget fn (Just pkgId)) = text "__pkg_ccall" <> gc_suf <+> ppr pkgId <+> pprCLabelString fn - ppr_fun (StaticTarget fn) - = text "__ccall" <> gc_suf <+> pprCLabelString fn + ppr_fun DynamicTarget + = text "__dyn_ccall" <> gc_suf <+> text "\"\"" \end{code} @@ -227,13 +247,16 @@ 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 @@ -257,24 +280,19 @@ 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 - put_ bh (PackageTarget aa ab) = do - putByte bh 2 - put_ bh aa - put_ bh ab get bh = do h <- getByte bh case h of 0 -> do aa <- get bh - return (StaticTarget aa) - 1 -> do return DynamicTarget - _ -> do aa <- get bh - ab <- get bh - return (PackageTarget aa ab) + ab <- get bh + return (StaticTarget aa ab) + _ -> do return DynamicTarget instance Binary CCallConv where put_ bh CCallConv = do