ghc-9.14.1: GHC/Types/ForeignCall.hs
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
\section[Foreign]{Foreign calls}
-}
{-# LANGUAGE DeriveDataTypeable #-}
module GHC.Types.ForeignCall (
ForeignCall(..), isSafeForeignCall,
Safety(..), playSafe, playInterruptible,
CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
CCallSpec(..),
CCallTarget(..), isDynamicTarget,
CCallConv(..), defaultCCallConv, ccallConvAttribute,
Header(..), CType(..),
) where
import GHC.Prelude
import GHC.Data.FastString
import GHC.Utils.Binary
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Unit.Module
import GHC.Types.SourceText ( SourceText, pprWithSourceText )
import Data.Char
import Data.Data
import Control.DeepSeq (NFData(..))
{-
************************************************************************
* *
\subsubsection{Data types}
* *
************************************************************************
-}
newtype ForeignCall = CCall CCallSpec
deriving Eq
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
ppr (CCall cc) = ppr cc
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. 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.
| 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.
-- Specifically:
--
-- * No GC
-- * No call backs
-- * No blocking
-- * No precise exceptions
--
deriving ( Eq, Show, Data, Enum )
-- Show used just for Show Lex.Token, I think
instance Outputable Safety where
ppr PlaySafe = text "safe"
ppr PlayInterruptible = text "interruptible"
ppr PlayRisky = text "unsafe"
playSafe :: Safety -> Bool
playSafe PlaySafe = True
playSafe PlayInterruptible = True
playSafe PlayRisky = False
playInterruptible :: Safety -> Bool
playInterruptible PlayInterruptible = True
playInterruptible _ = False
{-
************************************************************************
* *
\subsubsection{Calling C}
* *
************************************************************************
-}
data CExportSpec
= CExportStatic -- foreign export ccall foo :: ty
SourceText -- of the CLabelString.
-- See Note [Pragma source text] in "GHC.Types.SourceText"
CLabelString -- C Name of exported function
CCallConv
deriving Data
data CCallSpec
= CCallSpec CCallTarget -- What to call
CCallConv -- Calling convention to use.
Safety
deriving( Eq )
-- The call target:
-- | How to call a particular function in C-land.
data CCallTarget
-- An "unboxed" ccall# to named function in a particular package.
= StaticTarget
SourceText -- of the CLabelString.
-- See Note [Pragma source text] in "GHC.Types.SourceText"
CLabelString -- C-land name of label.
(Maybe Unit) -- 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" ..."
Bool -- True => really a function
-- False => a value; only
-- allowed in CAPI imports
| DynamicTarget
deriving( Eq, Data )
isDynamicTarget :: CCallTarget -> Bool
isDynamicTarget DynamicTarget = True
isDynamicTarget _ = False
{-
Stuff to do with calling convention:
ccall: Caller allocates parameters, *and* deallocates them.
See: http://www.programmersheaven.com/2/Calling-conventions
-}
-- any changes here should be replicated in the Callconv type in template haskell
data CCallConv
= CCallConv
| CApiConv
| StdCallConv
| PrimCallConv
| JavaScriptCallConv
deriving (Show, Eq, Data, Enum)
instance Outputable CCallConv where
ppr StdCallConv = text "stdcall"
ppr CCallConv = text "ccall"
ppr CApiConv = text "capi"
ppr PrimCallConv = text "prim"
ppr JavaScriptCallConv = text "javascript"
defaultCCallConv :: CCallConv
defaultCCallConv = CCallConv
{-
Generate the gcc attribute corresponding to the given
calling convention (used by PprAbsC):
-}
ccallConvAttribute :: CCallConv -> SDoc
ccallConvAttribute StdCallConv = panic "ccallConvAttribute StdCallConv"
ccallConvAttribute CCallConv = empty
ccallConvAttribute CApiConv = empty
ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv"
ccallConvAttribute JavaScriptCallConv = empty
type CLabelString = FastString -- A C label, completely unencoded
pprCLabelString :: CLabelString -> SDoc
pprCLabelString lbl = ftext lbl
isCLabelString :: CLabelString -> Bool -- Checks to see if this is a valid C label
isCLabelString lbl
= all ok (unpackFS lbl)
where
ok c = isAlphaNum c || c == '_' || c == '.' || c == '@'
-- The '.' appears in e.g. "foo.so" in the
-- module part of a ExtName. Maybe it should be separate
-- Printing into C files:
instance Outputable CExportSpec where
ppr (CExportStatic _ str _) = pprCLabelString str
instance Outputable CCallSpec where
ppr (CCallSpec fun cconv safety)
= hcat [ whenPprDebug callconv, ppr_fun fun, text " ::" ]
where
callconv = text "{-" <> ppr cconv <> text "-}"
gc_suf | playSafe safety = text "_safe"
| otherwise = text "_unsafe"
ppr_fun (StaticTarget st lbl mPkgId isFun)
= (if isFun then text "__ffi_static_ccall"
else text "__ffi_static_ccall_value")
<> gc_suf
<+> (case mPkgId of
Nothing -> empty
Just pkgId -> ppr pkgId)
<> text ":"
<> ppr lbl
<+> (pprWithSourceText st empty)
ppr_fun DynamicTarget
= text "__ffi_dyn_ccall" <> gc_suf <+> text "\"\""
-- The filename for a C header file
-- See Note [Pragma source text] in "GHC.Types.SourceText"
data Header = Header SourceText FastString
deriving (Eq, Data)
instance Outputable Header where
ppr (Header st h) = pprWithSourceText st (doubleQuotes $ ppr h)
-- | A C type, used in CAPI FFI calls
data CType = CType SourceText -- See Note [Pragma source text] in "GHC.Types.SourceText"
(Maybe Header) -- header to include for this type
(SourceText,FastString) -- the type itself
deriving (Eq, Data)
instance Outputable CType where
ppr (CType stp mh (stct,ct))
= pprWithSourceText stp (text "{-# CTYPE") <+> hDoc
<+> pprWithSourceText stct (doubleQuotes (ftext ct)) <+> text "#-}"
where hDoc = case mh of
Nothing -> empty
Just h -> ppr h
{-
************************************************************************
* *
\subsubsection{Misc}
* *
************************************************************************
-}
instance Binary ForeignCall where
put_ bh (CCall aa) = put_ bh aa
get bh = do aa <- get bh; return (CCall aa)
instance Binary Safety where
put_ bh PlaySafe =
putByte bh 0
put_ bh PlayInterruptible =
putByte bh 1
put_ bh PlayRisky =
putByte bh 2
get bh = do
h <- getByte bh
case h of
0 -> return PlaySafe
1 -> return PlayInterruptible
_ -> return PlayRisky
instance Binary CExportSpec where
put_ bh (CExportStatic ss aa ab) = do
put_ bh ss
put_ bh aa
put_ bh ab
get bh = do
ss <- get bh
aa <- get bh
ab <- get bh
return (CExportStatic ss aa ab)
instance Binary CCallSpec where
put_ bh (CCallSpec aa ab ac) = do
put_ bh aa
put_ bh ab
put_ bh ac
get bh = do
aa <- get bh
ab <- get bh
ac <- get bh
return (CCallSpec aa ab ac)
instance Binary CCallTarget where
put_ bh (StaticTarget ss aa ab ac) = do
putByte bh 0
put_ bh ss
put_ bh aa
put_ bh ab
put_ bh ac
put_ bh DynamicTarget =
putByte bh 1
get bh = do
h <- getByte bh
case h of
0 -> do ss <- get bh
aa <- get bh
ab <- get bh
ac <- get bh
return (StaticTarget ss aa ab ac)
_ -> return DynamicTarget
instance Binary CCallConv where
put_ bh CCallConv =
putByte bh 0
put_ bh StdCallConv =
putByte bh 1
put_ bh PrimCallConv =
putByte bh 2
put_ bh CApiConv =
putByte bh 3
put_ bh JavaScriptCallConv =
putByte bh 4
get bh = do
h <- getByte bh
case h of
0 -> return CCallConv
1 -> return StdCallConv
2 -> return PrimCallConv
3 -> return CApiConv
_ -> return JavaScriptCallConv
instance Binary CType where
put_ bh (CType s mh fs) = do put_ bh s
put_ bh mh
put_ bh fs
get bh = do s <- get bh
mh <- get bh
fs <- get bh
return (CType s mh fs)
instance Binary Header where
put_ bh (Header s h) = put_ bh s >> put_ bh h
get bh = do s <- get bh
h <- get bh
return (Header s h)
instance NFData ForeignCall where
rnf (CCall c) = rnf c
instance NFData Safety where
rnf PlaySafe = ()
rnf PlayInterruptible = ()
rnf PlayRisky = ()
instance NFData CCallSpec where
rnf (CCallSpec t c s) = rnf t `seq` rnf c `seq` rnf s
instance NFData CCallTarget where
rnf (StaticTarget s a b c) = rnf s `seq` rnf a `seq` rnf b `seq` rnf c
rnf DynamicTarget = ()
instance NFData CCallConv where
rnf CCallConv = ()
rnf StdCallConv = ()
rnf PrimCallConv = ()
rnf CApiConv = ()
rnf JavaScriptCallConv = ()
instance NFData CType where
rnf (CType s mh fs) = rnf s `seq` rnf mh `seq` rnf fs
instance NFData Header where
rnf (Header s h) = rnf s `seq` rnf h