{-# OPTIONS -w #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
{-# LANGUAGE DeriveDataTypeable #-}

module ForeignCall (
        ForeignCall(..), isSafeForeignCall,
	Safety(..), playSafe, playInterruptible,

	CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
	CCallSpec(..), 
	CCallTarget(..), isDynamicTarget,
	CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,
    ) where

import FastString
import Binary
import Outputable
import Module

import Data.Char
import Data.Data

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
  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
  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

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 !-}

-- | 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 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
  
  deriving( Eq, Data, Typeable )
  {-! derive: Binary !-}

isDynamicTarget :: CCallTarget -> Bool
isDynamicTarget DynamicTarget = True
isDynamicTarget _             = False

data CCallConv = CCallConv | StdCallConv | CmmCallConv | PrimCallConv
  deriving (Eq, Data, Typeable)
  {-! derive: Binary !-}

instance Outputable CCallConv where
  ppr StdCallConv = ptext (sLit "stdcall")
  ppr CCallConv   = ptext (sLit "ccall")
  ppr CmmCallConv = ptext (sLit "C--")
  ppr PrimCallConv = ptext (sLit "prim")

defaultCCallConv :: CCallConv
defaultCCallConv = CCallConv

ccallConvToInt :: CCallConv -> Int
ccallConvToInt StdCallConv = 0
ccallConvToInt CCallConv   = 1

ccallConvAttribute :: CCallConv -> String
ccallConvAttribute StdCallConv = "__attribute__((__stdcall__))"
ccallConvAttribute CCallConv   = ""

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

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 Nothing)
     	= text "__pkg_ccall" <> gc_suf <+> pprCLabelString fn

      ppr_fun (StaticTarget fn (Just pkgId))
     	= text "__pkg_ccall" <> gc_suf <+> ppr pkgId <+> pprCLabelString fn

      ppr_fun DynamicTarget     
        = text "__dyn_ccall" <> gc_suf <+> text "\"\""

{-* 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) = do
	    putByte bh 0
	    put_ bh aa
            put_ bh ab
    put_ bh DynamicTarget = do
	    putByte bh 1
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do aa <- get bh
                      ab <- get bh
		      return (StaticTarget aa ab)
	      _ -> 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
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do return CCallConv
	      1 -> do return StdCallConv
	      _ -> do return PrimCallConv