content: {-
  (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
  
  \section[Foreign]{Foreign calls}
  -}
  
  {-# LANGUAGE DeriveDataTypeable #-}
  
  module Eta.Prelude.ForeignCall (
          ForeignCall(..), isSafeForeignCall,
          Safety(..), playSafe, playInterruptible,
  
          CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
          CCallSpec(..),
          CCallTarget(..), isDynamicTarget,
          CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,
  
          JavaCallSpec(..), JavaTarget(..), MethodKind(..),
  
          Header(..), CType(..),
      ) where
  
  import Codec.JVM.Types
  import Eta.Utils.FastString
  import Eta.Utils.Binary
  import Eta.Utils.Outputable
  import Eta.BasicTypes.Module
  import Eta.BasicTypes.BasicTypes ( SourceText )
  
  import Data.Char
  import Data.Data
  
  {-
  ************************************************************************
  *                                                                      *
  \subsubsection{Data types}
  *                                                                      *
  ************************************************************************
  -}
  
  data ForeignCall = CCall CCallSpec
    --                 TODO: Disabled ot avoid cascade of changes
    --               | JavaCall JavaCallSpec
    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
    ppr (CCall cc)    = ppr cc
    -- ppr (JavaCall jj) = ppr jj
  
  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
    deriving ( Eq, Show, Data, Typeable )
          -- Show used just for Show Lex.Token, I think
    {-! derive: Binary !-}
  
  instance Outputable Safety where
    ppr PlaySafe = ptext (sLit "safe")
    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
  
  {-
  ************************************************************************
  *                                                                      *
  \subsubsection{Calling Java}
  *                                                                      *
  ************************************************************************
  -}
  
  data JavaCallSpec =
    JavaCallSpec { jcsHasObject  :: Bool
                 , jcsClassName  :: FastString
                 , jcsCallTarget :: JavaTarget }
  
  data JavaTarget =
      MethodTarget { mcsName      :: FastString
                   , mcsKind      :: MethodKind
                   , mcsArgTypes  :: [FieldType]
                   , mcsResType   :: Maybe FieldType }
    | FieldTarget  { fcsName   :: FastString
                   , fcsStatic :: Bool
                   , fcsGet    :: Bool
                   , fcsType   :: FieldType }
    deriving( Eq )
  
  data MethodKind = ConstructorMethod | InstanceMethod | StaticMethod | InterfaceMethod
    deriving Eq
  
  
  {-
  ************************************************************************
  *                                                                      *
  \subsubsection{Calling C}
  *                                                                      *
  ************************************************************************
  -}
  
  data CExportSpec
    = CExportStatic               -- foreign export ccall foo :: ty
          CLabelString            -- C Name of exported function
          CCallConv
    deriving (Data, Typeable)
    {-! derive: Binary !-}
  
  data CCallSpec
    =  CCallSpec  CCallTarget     -- What to call
                  CCallConv       -- Calling convention to use.
                  Safety
    deriving( Eq )
    {-! derive: Binary !-}
  
  -- 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
          CLabelString                    -- C-land name of label.
  
          (Maybe UnitId)                  -- 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, Typeable )
    {-! derive: Binary !-}
  
  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
  
  ToDo: The stdcall calling convention is x86 (win32) specific,
  so perhaps we should emit a warning if it's being used on other
  platforms.
  
  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 | JavaCallConv
    deriving (Eq, Data, Typeable)
    {-! derive: Binary !-}
  
  instance Outputable CCallConv where
    ppr StdCallConv = ptext (sLit "stdcall")
    ppr CCallConv   = ptext (sLit "ccall")
    ppr CApiConv    = ptext (sLit "capi")
    ppr PrimCallConv = ptext (sLit "prim")
    ppr JavaScriptCallConv = ptext (sLit "javascript")
    ppr JavaCallConv = ptext (sLit "java")
  
  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"
  ccallConvToInt JavaCallConv = panic "ccallConvToInt JavaCallConv"
  
  {-
  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"
  ccallConvAttribute JavaCallConv       = panic "ccallConvAttribute JavaCallConv"
  
  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 [ ifPprDebug callconv, ppr_fun fun ]
      where
        callconv = text "{-" <> ppr cconv <> text "-}"
  
        gc_suf | playSafe safety = text "_GC"
               | otherwise       = empty
  
        ppr_fun (StaticTarget fn mPkgId isFun)
          = text (if isFun then "__pkg_ccall"
                           else "__pkg_ccall_value")
         <> gc_suf
         <+> (case mPkgId of
              Nothing -> empty
              Just pkgId -> ppr pkgId)
         <+> pprCLabelString fn
  
        ppr_fun DynamicTarget
          = text "__dyn_ccall" <> gc_suf <+> text "\"\""
  
  -- The filename for a C header file
  newtype Header = Header FastString
      deriving (Eq, Data, Typeable)
  
  instance Outputable Header where
      ppr (Header h) = quotes $ ppr h
  
  -- | A C type, used in CAPI FFI calls
  --
  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CTYPE'@,
  --        'ApiAnnotation.AnnHeader','ApiAnnotation.AnnVal',
  --        'ApiAnnotation.AnnClose' @'\#-}'@,
  
  -- For details on above see note [Api annotations] in ApiAnnotation
  data CType = CType SourceText -- Note [Pragma source text] in BasicTypes
                     (Maybe Header) -- header to include for this type
                     FastString     -- the type itself
      deriving (Data, Typeable)
  
  instance Outputable CType where
      ppr (CType _ mh ct) = hDoc <+> ftext ct
          where hDoc = case mh of
                       Nothing -> empty
                       Just h -> ppr h
  
  {-
  ************************************************************************
  *                                                                      *
  \subsubsection{Misc}
  *                                                                      *
  ************************************************************************
  -}
  
  {-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
  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 aa ab) = do
              put_ bh aa
              put_ bh ab
      get bh = do
            aa <- get bh
            ab <- get bh
            return (CExportStatic 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 aa ab ac) = do
              putByte bh 0
              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 aa <- get bh
                        ab <- get bh
                        ac <- get bh
                        return (StaticTarget 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
      put_ bh JavaCallConv = do
              putByte bh 5
      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
                4 -> do return JavaScriptCallConv
                _ -> do return JavaCallConv
  
  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 h) = put_ bh h
      get bh = do h <- get bh
                  return (Header h)
  