content: {-
  (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
  