{-
(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, ccallConvToInt, ccallConvAttribute,

        Header(..), CType(..),
    ) where

import GHC.Prelude

import GHC.Data.FastString
import GHC.Utils.Binary
import GHC.Utils.Outputable
import GHC.Unit.Module
import GHC.Types.Basic ( SourceText, pprWithSourceText )

import Data.Char
import Data.Data

{-
************************************************************************
*                                                                      *
\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 )
        -- 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.Basic
        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.Basic
        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.

stdcall:        Caller allocates parameters, callee deallocates.
                Function name has @N after it, where N is number of arg bytes
                e.g.  _Foo@8. This convention is x86 (win32) specific.

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 (Eq, Data)

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

ccallConvToInt :: CCallConv -> Int
ccallConvToInt StdCallConv = 0
ccallConvToInt CCallConv   = 1
ccallConvToInt CApiConv    = panic "ccallConvToInt CApiConv"
ccallConvToInt (PrimCallConv {}) = panic "ccallConvToInt PrimCallConv"
ccallConvToInt JavaScriptCallConv = panic "ccallConvToInt JavaScriptCallConv"

{-
Generate the gcc attribute corresponding to the given
calling convention (used by PprAbsC):
-}

ccallConvAttribute :: CCallConv -> SDoc
ccallConvAttribute StdCallConv       = text "__attribute__((__stdcall__))"
ccallConvAttribute CCallConv         = empty
ccallConvAttribute CApiConv          = empty
ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv"
ccallConvAttribute JavaScriptCallConv = panic "ccallConvAttribute JavaScriptCallConv"

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 == '.'
        -- 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)
        = text (if isFun then "__ffi_static_ccall"
                         else "__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
-- Note [Pragma source text] in GHC.Types.Basic
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
--
--  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'{-\# CTYPE'@,
--        'GHC.Parser.Annotation.AnnHeader','GHC.Parser.Annotation.AnnVal',
--        'GHC.Parser.Annotation.AnnClose' @'\#-}'@,

-- For details on above see note [Api annotations] in "GHC.Parser.Annotation"
data CType = CType SourceText -- Note [Pragma source text] in GHC.Types.Basic
                   (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 = do
            putByte bh 0
    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 return PlaySafe
              1 -> do return PlayInterruptible
              _ -> do 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 = do
            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)
              _ -> do return DynamicTarget

instance Binary CCallConv where
    put_ bh CCallConv = do
            putByte bh 0
    put_ bh StdCallConv = do
            putByte bh 1
    put_ bh PrimCallConv = do
            putByte bh 2
    put_ bh CApiConv = do
            putByte bh 3
    put_ bh JavaScriptCallConv = do
            putByte bh 4
    get bh = do
            h <- getByte bh
            case h of
              0 -> do return CCallConv
              1 -> do return StdCallConv
              2 -> do return PrimCallConv
              3 -> do return CApiConv
              _ -> do 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)