hsXenCtrl-0.0.6: System/Xen/CBindings.hsc

module System.Xen.CBindings
    ( xc_interface_open
    , xc_interface_close
    , xc_find_device_number
    , xc_domain_create
    , xc_domain_dumpcore
    , xc_domain_dumpcore_via_callback
    , xc_domain_max_vcpus
    , xc_domain_pause
    , xc_domain_unpause
    , xc_domain_destroy
    , xc_domain_resume
    , xc_domain_shutdown
    , xc_vcpu_setaffinity
    , xc_vcpu_getaffinity
    , xc_domain_getinfo
    , xc_domain_getinfolist
    , xc_domain_hvm_getcontext
    , xc_domain_hvm_setcontext
    , xc_domain_setcpuweight
    , xc_domain_get_cpu_usage
    , xc_domain_sethandle
    , xc_sedf_domain_set
    , xc_domain_send_trigger
    , xc_vcpu_getinfo
    , VCPUInfo(..)
    -- Start Event Channel Functions
    , xc_evtchn_alloc_unbound
    , xc_evtchn_reset
    , xc_evtchn_open
    , xc_evtchn_close
    , xc_evtchn_fd
    , xc_evtchn_notify
    , xc_evtchn_bind_unbound_port
    , xc_evtchn_bind_interdomain
    , xc_evtchn_bind_virq
    , xc_evtchn_unbind
    , xc_evtchn_pending
    , xc_evtchn_unmask
    , xc_physdev_pci_access_modify
    , xc_readconsolering
    , xc_send_debug_keys
    , xc_physinfo
    , xc_sched_id
    , xc_getcpuinfo
    , xc_domain_setmaxmem
    , xc_domain_set_memmap_limit
    , xc_domain_set_time_offset
    , xc_domain_memory_increase_reservation
    , xc_domain_memory_decrease_reservation
    , xc_domain_memory_populate_physmap
    , xc_domain_ioport_permission
    , xc_domain_irq_permission
    , xc_make_page_below_4G
    , xc_perfc_control
    , xc_map_foreign_range
    , xc_map_foreign_batch
    , xc_translate_foreign_address
    , xc_get_pfn_list
#if defined(__ia64__)
    , xc_ia64_fpsr_default
    , xc_ia64_get_pfn_list
#endif
    , xc_copy_to_domain_page
    , xc_clear_domain_page
    , xc_mmuext_op
    , xc_memory_op
    , xc_get_pfn_type_batch
    , xc_get_tot_pages
    -- Trace buffer operations
    , xc_tbuf_enable
    , xc_tbuf_disable
    , xc_tbuf_get_size
    , xc_tbuf_set_cpu_mask
    , xc_tbuf_set_evt_mask
    , xc_domctl
    , xc_sysctl
    , xc_version
    , xc_acm_op
    -- Grant table operations
    , GTHandle (..)
    , xc_gnttab_open
    , xc_gnttab_close
    , xc_gnttab_map_grant_ref
    , xc_gnttab_map_grant_refs
    , xc_gnttab_munmap
    , DomId_t
    , xc_hvm_set_pci_intx_level
    , xc_hvm_set_isa_irq_level
    , xc_hvm_set_pci_link_route
    -- Error handling operations
    , XCErrorCode(..)
    , xcMaxErrorMsgLen
    , XCError(..)
    , xc_get_last_error
    , xc_clear_last_error
    , XCErrorHandler
    , xc_default_error_handler
    , xc_error_code_to_desc
    , xc_set_error_handler
    , xc_set_hvm_param
    , xc_get_hvm_param
    , xc_alloc_real_mode_area
#if defined(__ia64__)
    , xc_ia64_save_to_nvram
    , xc_ia64_nvram_init
#endif
    -- Start data types
    , xc_CORE_MAGIC
    , xc_CORE_MAGIC_HVM
    , DomId(..)
    , XCHandle(..)
    , EventChanPortOrError
    , XCEHandle(..)
    , EventChannelPort(..)
    , XCPhysInfo(..)
    , XCCPUInfo(..)
    , XCperfcDesc(..)
    , XCperfcVal
    , XenPFN
    , PerfcOp
    , perfcOpReset
    , perfcOpQuery
    , MemoryProtectionFlags
    , MMUExtOp(..)
    ) where

import Data.Bits
import Data.List (foldl1')
import Data.Word
import Data.Int
import qualified Data.ByteString as B
import Data.Array.IArray
import Foreign.C
import Foreign.Ptr
import Foreign.Storable
import Foreign.Marshal.Array (peekArray, pokeArray)

#include <xenctrl.h>
#include <xen/sysctl.h>
#include <xen/domctl.h>

xc_CORE_MAGIC :: CInt
xc_CORE_MAGIC = 0xF00FEBED

xc_CORE_MAGIC_HVM :: CInt
xc_CORE_MAGIC_HVM = 0xF00FEBEE

data DomainFlag = Dying | Crashed | Shutdown | Paused | Blocked | Running | HVM | Debugged deriving (Eq, Ord, Show, Enum)

instance Storable [DomainFlag] where
    sizeOf _ = sizeOf (undefined :: CUInt)
    alignment _ = alignment (undefined :: CUInt)
    peek ptr = do
        v <- peek (castPtr ptr)
        return $ fromBits v
    poke ptr a = poke (castPtr ptr) (toBits a)

toBits :: [DomainFlag] -> CUInt
toBits flgs = foldl1' (.|.) (map (bit . fromEnum) flgs)

fromBits :: CUInt -> [DomainFlag]
fromBits v = map (toEnum . fst) flagsSet
  where
  flagsSet :: [(Int,Bool)]
  flagsSet = filter ((==True) . snd) (zip [0..] flgVals)
  flgVals :: [Bool]
  flgVals = map (uncurry testBit) (zip (repeat v) [0..31])

data XC_DomInfo = XC_DomInfo {
    diDomId           :: Word32,
    diSSIDRef         :: Word32,
    diFlags           :: [DomainFlag],
    diShutdownReason  :: XCShutdown,
    diNrPages         :: CUInt,
    diSharedInfoFrame :: CUInt,
    diCpuTime         :: Word64,
    diMaxMemKB        :: CULong,
    diNrOnlineVCPUs   :: CUInt,
    diMaxVCPUId       :: CUInt,
    diDomHandle       :: [XenDomainHandle]
  } deriving (Eq, Ord, Show)

type XenDomainHandle = Word8
type XenDomainHandleT = Ptr Word8

instance Storable XC_DomInfo where
    sizeOf _= (#size xc_dominfo_t)
    alignment _ = alignment (undefined :: Word64)
    peek ptr = do
         domId    <- (#peek xc_dominfo_t, domid) ptr
         ssidRef  <- (#peek xc_dominfo_t, ssidref) ptr
         flags <- peekByteOff ptr (sizeOf domId + sizeOf ssidRef)
         sr    <- (#peek xc_dominfo_t, shutdown_reason) ptr
         nrPgs <- (#peek xc_dominfo_t, nr_pages) ptr
         infoF <- (#peek xc_dominfo_t, shared_info_frame) ptr
         cpuT  <- (#peek xc_dominfo_t, cpu_time) ptr
         maxM  <- (#peek xc_dominfo_t, max_memkb) ptr
         nrOC  <- (#peek xc_dominfo_t, nr_online_vcpus) ptr
         maxCI <- (#peek xc_dominfo_t, max_vcpu_id) ptr
         dh    <- peekArray 16 (plusPtr ptr (#offset xc_dominfo_t, handle))
         return $ XC_DomInfo domId ssidRef flags sr nrPgs infoF cpuT maxM nrOC maxCI dh
    poke ptr a = do
        (#poke xc_dominfo_t, domid) ptr (diDomId a)
        (#poke xc_dominfo_t, ssidref) ptr (diSSIDRef a)
        pokeByteOff ptr (sizeOf (diDomId a) + sizeOf (diSSIDRef a)) (diFlags a)
        (#poke xc_dominfo_t, shutdown_reason) ptr (diShutdownReason a)
        (#poke xc_dominfo_t, nr_pages) ptr (diNrPages a)
        (#poke xc_dominfo_t, shared_info_frame) ptr (diSharedInfoFrame a)
        (#poke xc_dominfo_t, cpu_time) ptr (diCpuTime a)
        (#poke xc_dominfo_t, max_memkb) ptr (diMaxMemKB a)
        (#poke xc_dominfo_t, nr_online_vcpus) ptr (diNrOnlineVCPUs a)
        (#poke xc_dominfo_t, max_vcpu_id) ptr (diMaxVCPUId a)
        let p = plusPtr ptr 76
            domHandles = take 16 $ diDomHandle a ++ repeat 0
        pokeArray p domHandles

-- |SHUTDOWN constants matching those found in <xen/sched.h>
data XCShutdown = SHUTDOWN_poweroff | SHUTDOWN_reboot | SHUTDOWN_suspend | SHUTDOWN_crash
    deriving (Eq, Ord, Show, Read, Enum)

instance Storable XCShutdown where
    sizeOf _ = sizeOf (undefined :: CInt)
    alignment _ = alignment (undefined :: CInt)
    peek ptr = peek (castPtr ptr :: Ptr CInt) >>= return . toEnum . fromIntegral
    poke ptr a = poke (castPtr ptr :: Ptr CInt) (fromIntegral (fromEnum a))

-- |Xen Control Handle identifies the IO channel through which must functions will pass their messages.
newtype XCHandle = XCHdl CInt deriving (Eq, Ord, Show)

instance Storable XCHandle where
    sizeOf _ = sizeOf (undefined :: CInt)
    alignment _ = alignment (undefined :: CInt)
    peek ptr = peek (castPtr ptr) >>= return . XCHdl
    poke ptr (XCHdl h) = poke (castPtr ptr) h

-- |DomId identifies the Xen VM
newtype DomId = DomId Word32 deriving (Eq, Ord, Show)

instance Storable DomId where
    sizeOf _ = sizeOf (undefined :: Word32)
    alignment _ = alignment (undefined :: Word32)
    peek ptr = peek (castPtr ptr) >>= return . DomId
    poke ptr i = poke (castPtr ptr) i

foreign import ccall unsafe "xc_interface_open"
    xc_interface_open :: IO XCHandle

foreign import ccall unsafe "xc_interface_close"
    xc_interface_close :: XCHandle -> IO CInt

foreign import ccall unsafe "xc_find_device_number"
    xc_find_device_number :: CString -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_domain_create"
    xc_domain_create :: XCHandle -> DomId -> XenDomainHandleT -> Word32 -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_domain_dumpcore"
    xc_domain_dumpcore :: XCHandle -> DomId -> CString -> IO CInt

type Dumpcore_rtn_t = FunPtr (Ptr Word8 -> CString -> CUInt -> IO CInt)

foreign import ccall safe "xenctrl.h xc_domain_dumpcore_via_callback"
    xc_domain_dumpcore_via_callback :: XCHandle -> DomId -> Ptr Word8 -> IO Dumpcore_rtn_t

foreign import ccall unsafe "xenctrl.h xc_domain_max_vcpus"
    xc_domain_max_vcpus :: XCHandle -> DomId -> CUInt -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_domain_pause"
    xc_domain_pause :: XCHandle -> DomId -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_domain_unpause"
    xc_domain_unpause :: XCHandle -> DomId -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_domain_destroy"
    xc_domain_destroy :: XCHandle -> DomId -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_domain_resume"
    xc_domain_resume :: XCHandle -> DomId -> CInt -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_domain_shutdown"
     xc_domain_shutdown :: XCHandle -> DomId -> CInt -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_vcpu_setaffinity"
    xc_vcpu_setaffinity :: XCHandle -> DomId -> CInt -> Word64 -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_vcpu_getaffinity"
    xc_vcpu_getaffinity :: XCHandle -> DomId -> CInt -> Ptr Word64 -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_domain_getinfo"
    xc_domain_getinfo :: XCHandle -> DomId -> CUInt -> Ptr XC_DomInfo -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_domain_getinfolist"
    xc_domain_getinfolist :: XCHandle -> DomId -> CUInt -> Ptr XC_DomInfo -> CInt

foreign import ccall unsafe "xenctrl.h xc_domain_hvm_getcontext"
    xc_domain_hvm_getcontext :: XCHandle -> DomId -> Ptr Word8 -> Word32 -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_domain_hvm_setcontext"
    xc_domain_hvm_setcontext :: XCHandle -> DomId -> Ptr Word8 -> Word32 -> IO CInt

-- vcpu_info_t == xen_domctl_getvcpuinfo_t
data VCPUInfo =
    VCPUInfo {
        viVCPU    :: Word32,
        viOnline  :: Word8,
        viBlocked :: Word8,
        viRunning :: Word8,
        viCPUTime :: Word64,
        viCPU     :: Word32
    } deriving (Eq, Ord, Show)

instance Storable VCPUInfo where
    sizeOf _ = (#size xen_domctl_getvcpuinfo_t)
    alignment _ = alignment (undefined :: Word64)
    peek ptr = do
        v <- (#peek xen_domctl_getvcpuinfo_t, vcpu) ptr
        o <- (#peek xen_domctl_getvcpuinfo_t, online) ptr 
        b <- (#peek xen_domctl_getvcpuinfo_t, blocked) ptr
        r <- (#peek xen_domctl_getvcpuinfo_t, running) ptr
        t <- (#peek xen_domctl_getvcpuinfo_t, cpu_time) ptr
        c <- (#peek xen_domctl_getvcpuinfo_t, cpu) ptr
        return $ VCPUInfo v o b r t c
    poke ptr (VCPUInfo v o b r t c) = do
        (#poke xen_domctl_getvcpuinfo_t, vcpu) ptr v
        (#poke xen_domctl_getvcpuinfo_t, online) ptr o
        (#poke xen_domctl_getvcpuinfo_t, blocked) ptr b
        (#poke xen_domctl_getvcpuinfo_t, running) ptr r
        (#poke xen_domctl_getvcpuinfo_t, cpu_time) ptr t
        (#poke xen_domctl_getvcpuinfo_t, cpu) ptr c

-- TODO need to base VCPU_Guest_Context on arch specific info
--
-- foreign import ccall unsafe "xenctrl.h xc_vcpu_setcontext"
--     xc_vcpu_setcontext :: XCHandle -> DomId -> Word32 -> Ptr VCPU_Guest_Context -> IO CInt
--
-- foreign import ccall unsafe"xenctrl.h xc_vcpu_getcontext"
--    xc_vcpu_getcontext :: XCHandle -> DomId -> Word32 -> Ptr VCPU_Guest_Context -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_vcpu_getinfo"
    xc_vcpu_getinfo :: XCHandle -> DomId -> Word32 -> Ptr VCPUInfo -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_domain_setcpuweight"
    xc_domain_setcpuweight :: XCHandle -> DomId -> CFloat -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_domain_get_cpu_usage"
    xc_domain_get_cpu_usage :: XCHandle -> DomId -> CInt -> IO CLLong

foreign import ccall unsafe "xenctrl.h xc_domain_sethandle"
    xc_domain_sethandle :: XCHandle -> DomId -> XenDomainHandleT -> IO CInt

{-
 - FIXME make ShadowOpStats and instance for Storable
 - foreign import ccall unsafe "xenctrl.h xc_shadow_control"
 -    xc_shadow_control :: XCHandle -> DomId -> CUInt -> Ptr CULong -> CULong -> Ptr CULong -> Word32 -> Ptr ShadowOpStats -> IO CInt
 -}

foreign import ccall unsafe "xenctrl.h xc_sedf_domain_set"
    xc_sedf_domain_set :: XCHandle -> DomId -> Word64 -> Word64 -> Word64 -> Word64 -> Word16 -> Word16 -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_sedf_domain_get"
    xc_sedf_domain_get :: XCHandle -> DomId -> Ptr Word64 -> Ptr Word64 -> Ptr Word64 -> Ptr Word64 -> Ptr Word16 -> Ptr Word16 -> IO CInt

{- FIXME make XenDomCtrlSchedCredit (in c: xen_domctrl_sched_credit) and Storable instance
 -
 - foreign import ccall unsafe "xenctrl.h xc_sched_credit_domain_set"
 -     xc_sched_credit_domain_set :: XCHandle -> DomId -> Ptr XenDomCtrlSchedCredit -> IO CInt
 -
 - foreign import ccall unsafe "xenctrl.h xc_sched_credit_domain_get"
 -     xc_sched_credit_domain_get :: XCHandle -> DomId -> Ptr XenDomCtrlSchedCredit -> IO CInt
 -}

foreign import ccall unsafe "xenctrl.h xc_domain_send_trigger"
    xc_domain_send_trigger :: XCHandle -> DomId -> Word32 -> Word32 -> IO CInt

-- EVENT CHANNEL FUNCTIONS --
type EventChanPortOrError = CInt

newtype XCEHandle = XCEHdl CInt deriving (Eq, Ord, Show)

instance Storable XCEHandle where
    sizeOf _ = sizeOf (undefined :: CInt)
    alignment _ = alignment (undefined :: CInt)
    peek ptr = peek (castPtr ptr) >>= return . XCEHdl
    poke ptr (XCEHdl h) = poke (castPtr ptr) h

foreign import ccall unsafe "xenctrl.h xc_evtchn_alloc_unbound"
    xc_evtchn_alloc_unbound :: XCHandle -> DomId -> DomId -> IO EventChanPortOrError

foreign import ccall unsafe "xenctrl.h xc_evtchn_reset"
    xc_evtchn_reset :: XCHandle -> DomId -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_evtchn_open"
    xc_evtchn_open :: IO CInt

foreign import ccall unsafe "xenctrl.h xc_evtchn_close"
    xc_evtchn_close :: XCEHandle -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_evtchn_fd"
    xc_evtchn_fd :: CInt -> IO CInt

newtype EventChannelPort = ECPort Word32 deriving (Eq, Ord, Show)

instance Storable EventChannelPort where
    sizeOf _ = sizeOf (undefined :: Word32)
    alignment _ = alignment (undefined :: Word32)
    peek ptr = peek (castPtr ptr) >>= return . ECPort
    poke ptr (ECPort p) = poke (castPtr ptr) p

foreign import ccall unsafe "xenctrl.h xc_evtchn_notify"
    xc_evtchn_notify :: XCEHandle -> EventChannelPort -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_evtchn_bind_unbound_port"
    xc_evtchn_bind_unbound_port :: XCEHandle -> DomId -> IO EventChanPortOrError

foreign import ccall unsafe "xenctrl.h xc_evtchn_bind_interdomain"
    xc_evtchn_bind_interdomain :: XCEHandle -> DomId -> EventChannelPort -> IO EventChanPortOrError

foreign import ccall unsafe "xenctrl.h xc_evtchn_bind_virq"
    xc_evtchn_bind_virq :: XCEHandle -> CUInt -> IO EventChanPortOrError

foreign import ccall unsafe "xenctrl.h xc_evtchn_unbind"
    xc_evtchn_unbind :: XCEHandle -> EventChannelPort -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_evtchn_pending"
    xc_evtchn_pending :: XCEHandle -> IO EventChanPortOrError

foreign import ccall unsafe "xenctrl.h xc_evtchn_unmask"
    xc_evtchn_unmask :: XCEHandle -> IO EventChanPortOrError

type Bus = CInt
type Dev = CInt
type Function = CInt
type Enable = CInt
foreign import ccall unsafe "xenctrl.h xc_physdev_pci_access_modify"
    xc_physdev_pci_access_modify :: XCHandle -> DomId -> Bus -> Dev -> Function -> Enable -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_readconsolering"
    xc_readconsolering :: XCHandle -> Ptr CString -> Ptr CUInt -> CInt -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_send_debug_keys"
    xc_send_debug_keys :: XCHandle -> CString -> IO CInt

data XCPhysInfo = XCPhysInfo {
    piThreadsPerCore :: Word32,
    piCoresPerSocket :: Word32,
    piNrCPUs         :: Word32,
    piNrNodes        :: Word32,
    piCPUkhz         :: Word32,
    piTotalPages     :: Word64,
    piFreePages      :: Word64,
    piScrubPages     :: Word64,
    piHWCap          :: [Word32]
    } deriving (Eq, Ord, Show)

instance Storable XCPhysInfo where
    sizeOf _ = (#size xen_sysctl_physinfo_t)
    alignment _ = alignment (undefined :: Word64)
    peek ptr = do
        t   <- (#peek xen_sysctl_physinfo_t, threads_per_core) ptr
        c   <- (#peek xen_sysctl_physinfo_t, cores_per_socket) ptr
#if XEN_SYSCTL_INTERFACE_VERSION < 6
        s   <- (#peek xen_sysctl_physinfo_t, sockets_per_node) ptr
#else
        s   <- (#peek xen_sysctl_physinfo_t, nr_cpus) ptr
#endif
        nr  <- (#peek xen_sysctl_physinfo_t, nr_nodes) ptr
        cpu <- (#peek xen_sysctl_physinfo_t, cpu_khz) ptr
        tp  <- (#peek xen_sysctl_physinfo_t, total_pages) ptr
        fp  <- (#peek xen_sysctl_physinfo_t, free_pages) ptr
        sp  <- (#peek xen_sysctl_physinfo_t, scrub_pages) ptr
        let p = castPtr (plusPtr ptr (#offset xen_sysctl_physinfo_t, hw_cap)) :: Ptr Word32
        hw  <- (peekArray 8 p) :: IO [Word32]
        return $ XCPhysInfo t c s nr cpu tp fp sp hw
    poke ptr (XCPhysInfo t c s nr cpu tp fp sp hw) = do
        (#poke xen_sysctl_physinfo_t, threads_per_core) ptr t
        (#poke xen_sysctl_physinfo_t, cores_per_socket) ptr c
#if XEN_SYSCTL_INTERFACE_VERSION < 6
        (#poke xen_sysctl_physinfo_t, sockets_per_node) ptr s
#else
        (#poke xen_sysctl_physinfo_t, nr_cpus) ptr s
#endif
        (#poke xen_sysctl_physinfo_t, nr_nodes) ptr nr
        (#poke xen_sysctl_physinfo_t, cpu_khz) ptr cpu
        (#poke xen_sysctl_physinfo_t, total_pages) ptr tp
        (#poke xen_sysctl_physinfo_t, free_pages) ptr fp
        (#poke xen_sysctl_physinfo_t, scrub_pages) ptr sp
        let p = castPtr $ plusPtr ptr (#offset xen_sysctl_physinfo_t, hw_cap)
        pokeArray p hw

foreign import ccall unsafe "xenctrl.h xc_physinfo"
    xc_physinfo :: XCHandle -> Ptr XCPhysInfo -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_sched_id"
    xc_sched_id :: XCHandle -> Ptr CInt -> IO CInt

data XCCPUInfo = XCCPUInfo { ciIdleTime :: Word64 } deriving (Eq, Ord, Show)

instance Storable XCCPUInfo where
    sizeOf _ = (#size xen_sysctl_cpuinfo_t)
    alignment _ = alignment (undefined :: Word64)
    peek ptr = (#peek xen_sysctl_cpuinfo_t, idletime) ptr >>= return . XCCPUInfo
    poke ptr (XCCPUInfo i) = (#poke xen_sysctl_cpuinfo_t, idletime) ptr i

foreign import ccall unsafe "xenctrl.h xc_getcpuinfo"
    xc_getcpuinfo :: XCHandle -> CInt -> Ptr XCCPUInfo -> Ptr CInt -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_domain_setmaxmem"
    xc_domain_setmaxmem :: XCHandle -> DomId -> CUInt -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_domain_set_memmap_limit"
    xc_domain_set_memmap_limit :: XCHandle -> DomId -> CULong -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_domain_set_time_offset"
    xc_domain_set_time_offset :: XCHandle -> DomId -> Int32 -> IO CInt

#if defined(__powerpc__)
type XenPFN = CULLong
#else
-- x86, x86_64, ia64
type XenPFN = CULong
#endif

foreign import ccall unsafe "xenctrl.h xc_domain_memory_increase_reservation"
    xc_domain_memory_increase_reservation :: XCHandle -> DomId -> CULong -> CUInt -> CUInt -> Ptr XenPFN -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_domain_memory_decrease_reservation"
    xc_domain_memory_decrease_reservation :: XCHandle -> DomId -> CULong -> CUInt -> Ptr XenPFN -> IO CInt


foreign import ccall unsafe "xenctrl.h xc_domain_memory_populate_physmap"
    xc_domain_memory_populate_physmap :: XCHandle -> DomId -> CULong -> CUInt -> CUInt -> Ptr XenPFN -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_domain_ioport_permission"
    xc_domain_ioport_permission :: XCHandle -> DomId -> Word32 -> Word32 -> Word32 -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_domain_irq_permission"
    xc_domain_irq_permission :: XCHandle -> DomId -> Word8 -> Word8 -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_domain_iomem_permission"
    xc_domain_iomem_permission :: XCHandle -> DomId -> CULong -> CULong -> Word8 -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_make_page_below_4G"
    xc_make_page_below_4G :: XCHandle -> DomId -> CULong -> IO CULong

data XCperfcDesc = XCperfcDesc B.ByteString Word32

type XCperfcVal = Word32

instance Storable XCperfcDesc where
    sizeOf _ = (#size xen_sysctl_perfc_desc_t)
    alignment _ = alignment (undefined :: Word32)
    peek ptr = do
        bs <- B.packCStringLen (castPtr ptr,80)
        w <- (#peek xen_sysctl_perfc_desc_t, nr_vals) ptr
        return $ XCperfcDesc bs w
    poke ptr (XCperfcDesc bs w) = do
        pokeArray (castPtr ptr) (take 80 (B.unpack bs ++ repeat 0))
        (#poke xen_sysctl_perfc_desc_t, nr_vals) ptr w

type PerfcOp = Word32
perfcOpReset = 1
perfcOpQuery = 2

-- |Must mlock() the XCperfc data structures after poking and before calling this function.
foreign import ccall unsafe "xenctrl.h xc_perfc_control"
    xc_perfc_control :: XCHandle -> PerfcOp -> Ptr XCperfcDesc -> Ptr XCperfcVal -> Ptr CInt -> Ptr CInt -> IO CInt

type MemoryProtectionFlags = CInt

foreign import ccall unsafe "xenctrl.h xc_map_foreign_range"
    xc_map_foreign_range :: XCHandle -> DomId -> CInt -> MemoryProtectionFlags -> CULong -> IO ()

foreign import ccall unsafe "xenctrl.h xc_map_foreign_batch"
    xc_map_foreign_batch :: XCHandle -> DomId -> MemoryProtectionFlags -> Ptr XenPFN -> CInt -> IO ()


foreign import ccall unsafe "xenctrl.h xc_translate_foreign_address"
    xc_translate_foreign_address :: XCHandle -> DomId -> CInt -> CULLong -> IO CULong

foreign import ccall unsafe "xenctrl.h xc_get_pfn_list"
    xc_get_pfn_list :: XCHandle -> DomId -> Ptr Word64 -> CULong -> IO CInt

#if defined(__ia64__)
foreign import ccall unsafe "xenctrl.h xc_ia64_fpsr_default"
    xc_ia64_fpsr_default :: IO ()

foreign import ccall unsafe "xenctrl.h xc_ia64_get_pfn_list"
    xc_ia64_get_pfn_list :: XCHandle -> DomId -> Ptr XenPFN -> CUInt -> CUInt -> IO CInt
#endif

foreign import ccall unsafe "xenctrl.h xc_copy_to_domain_page"
    xc_copy_to_domain_page :: XCHandle -> DomId -> CULong -> CString -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_clear_domain_page"
    xc_clear_domain_page :: XCHandle -> DomId -> CULong -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_get_max_pages"
    xc_get_max_pages :: XCHandle -> DomId -> IO CLong

-- |The user of MMUExtOp must perform their own marshaling operations, note the lack of a Storable instance.
data MMUExtOp =
    MMUExtOp { opCmd    :: CUInt,
               opArg1   :: Either XenPFN CULong,
               opArg2   :: Either CUInt (Ptr ())
    } deriving (Eq, Ord, Show)

foreign import ccall unsafe "xenctrl.h xc_mmuext_op"
    xc_mmuext_op :: XCHandle -> Ptr MMUExtOp -> CUInt -> DomId -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_memory_op"
    xc_memory_op :: XCHandle -> CInt -> Ptr () -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_get_pfn_type_batch"
    xc_get_pfn_type_batch :: XCHandle -> DomId -> CInt -> Ptr Word32 -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_get_tot_pages"
    xc_get_tot_pages :: XCHandle -> DomId -> IO CLong

-- Trace buffer operations
foreign import ccall unsafe "xenctrl.h xc_tbuf_enable"
    xc_tbuf_enable :: XCHandle -> CULong -> Ptr CULong -> Ptr CULong -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_tbuf_disable"
    xc_tbuf_disable :: XCHandle -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_tbuf_get_size"
    xc_tbuf_get_size :: XCHandle -> Ptr CULong -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_tbuf_set_cpu_mask"
    xc_tbuf_set_cpu_mask :: XCHandle -> Word32 -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_tbuf_set_evt_mask"
    xc_tbuf_set_evt_mask :: XCHandle -> Word32 -> IO CInt

data XenDomCtl = XenDomCtl
data XenSysCtl = XenSysCtl

foreign import ccall unsafe "xenctrl.h xc_domctl"
    xc_domctl :: XCHandle -> Ptr XenDomCtl -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_sysctl"
    xc_sysctl :: XCHandle -> Ptr XenSysCtl -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_version"
    xc_version :: XCHandle -> CInt -> Ptr () -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_acm_op"
    xc_acm_op :: XCHandle -> CInt -> Ptr () -> CULong -> IO CInt

-- Grant Table Operations

newtype GTHandle = GTHandle CInt deriving (Eq, Ord, Show)

instance Storable GTHandle where
    sizeOf _ = sizeOf (undefined :: CInt)
    alignment _ = alignment (undefined :: CInt)
    peek ptr = peek (castPtr ptr) >>= return . GTHandle
    poke ptr (GTHandle h) = poke (castPtr ptr) h

foreign import ccall unsafe "xenctrl.h xc_gnttab_open"
    xc_gnttab_open :: IO CInt -- Does not return GTHandle because (-1) can be returned.

foreign import ccall unsafe "xenctrl.h xc_gnttab_close"
    xc_gnttab_close :: GTHandle -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_gnttab_map_grant_ref"
    xc_gnttab_map_grant_ref :: GTHandle -> DomId -> Word32 -> CInt -> IO (Ptr a)

foreign import ccall unsafe "xenctrl.h xc_gnttab_map_grant_refs"
   xc_gnttab_map_grant_refs :: GTHandle -> Word32 -> Ptr Word32 -> Ptr Word32 -> CInt -> IO (Ptr a)

foreign import ccall unsafe "xenctrl.h xc_gnttab_munmap"
    xc_gnttab_munmap :: GTHandle -> Ptr a -> Word32 -> IO CInt

-- FIXME: Why does much of Xen use uint32_t for 'dom' args then have a 16 bit domid_t?
type DomId_t = Word16 

foreign import ccall unsafe "xenctrl.h xc_hvm_set_pci_intx_level"
    xc_hvm_set_pci_intx_level :: XCHandle -> DomId_t -> Word8 -> Word8 -> Word8 -> Word8 -> CUInt -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_hvm_set_isa_irq_level"
      xc_hvm_set_isa_irq_level :: XCHandle -> DomId_t -> Word8 -> CUInt -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_hvm_set_pci_link_route"
      xc_hvm_set_pci_link_route :: XCHandle -> DomId_t -> Word8 -> Word8 -> IO CInt

data XCErrorCode = XCErrorNone | XCInternalError | XCInvalidKernel | XCInvalidParam | XCOutOfMemory
    deriving (Eq, Ord, Show, Enum)

instance Storable XCErrorCode where
    sizeOf _ = sizeOf (undefined :: CInt)
    alignment _ = alignment (undefined :: CInt)
    peek ptr = peek (castPtr ptr :: Ptr CInt) >>= return . toEnum . fromIntegral
    poke ptr a = poke (castPtr ptr) (fromIntegral (fromEnum a) :: CInt)

xcMaxErrorMsgLen = 1024

data XCError = XCError { xceCode :: XCErrorCode, xceMsg :: B.ByteString } deriving (Eq, Ord, Show)

foreign import ccall unsafe "xenctrl.h xc_get_last_error"
      xc_get_last_error :: IO (Ptr XCError)

foreign import ccall unsafe "xenctrl.h xc_clear_last_error"
      xc_clear_last_error :: IO ()

type XCErrorHandler = FunPtr (XCError -> IO ())

foreign import ccall unsafe "xenctrl.h xc_default_error_handler"
      xc_default_error_handler :: Ptr XCErrorHandler -> IO ()

-- arg1 should be XCErrorCode, but GHC rejects that
foreign import ccall unsafe "xenctrl.h xc_error_code_to_desc"
      xc_error_code_to_desc_c :: CInt -> IO CString

xc_error_code_to_desc :: XCErrorCode -> IO CString
xc_error_code_to_desc c = do
    xc_error_code_to_desc_c (fromIntegral $ fromEnum c)

foreign import ccall unsafe "xenctrl.h xc_set_error_handler"
      xc_set_error_handler :: XCErrorHandler -> IO XCErrorHandler

foreign import ccall unsafe "xenctrl.h xc_set_hvm_param"
      xc_set_hvm_param :: XCHandle -> DomId_t -> CInt -> CULong -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_get_hvm_param"
      xc_get_hvm_param :: XCHandle -> DomId_t -> CInt -> Ptr CULong -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_alloc_real_mode_area"
      xc_alloc_real_mode_area :: XCHandle -> DomId -> CUInt -> IO CInt

#if defined(__ia64__)
foreign import ccall unsafe "xenctrl.h xc_ia64_save_to_nvram"
      xc_ia64_save_to_nvram :: XCHandle -> DomId -> IO CInt

foreign import ccall unsafe "xenctrl.h xc_ia64_nvram_init"
      xc_ia64_nvram_init :: XCHandle -> CString -> DomId -> IO CInt
#endif

-- Data and functions for debugging
data XC_Core_Header = XC_Core_Header {
      xchMagic       :: CInt
    , xchNrVCPUs     :: CInt
    , xchNrPages     :: CInt
    , xchCTXTOffset  :: CInt
    , xchIndexOffset :: CInt
    , xchPagesOffset :: CInt } deriving (Eq, Ord, Show)

instance Storable XC_Core_Header where
    sizeOf _ = (#size xc_core_header_t)
    alignment _ = alignment (undefined :: CInt)
    peek ptr = do
        m <- (#peek xc_core_header_t, xch_magic) ptr
        v <- (#peek xc_core_header_t, xch_nr_vcpus) ptr
        p <- (#peek xc_core_header_t, xch_nr_pages) ptr
        c <- (#peek xc_core_header_t, xch_ctxt_offset) ptr
        i <- (#peek xc_core_header_t, xch_index_offset) ptr
        g <- (#peek xc_core_header_t, xch_pages_offset) ptr
        return (XC_Core_Header m v p c i g)
    poke ptr (XC_Core_Header m v p c i g) = do
        (#poke xc_core_header_t, xch_magic) ptr m
        (#poke xc_core_header_t, xch_nr_vcpus) ptr v
        (#poke xc_core_header_t, xch_nr_pages) ptr p
        (#poke xc_core_header_t, xch_ctxt_offset) ptr c
        (#poke xc_core_header_t, xch_index_offset) ptr i
        (#poke xc_core_header_t, xch_pages_offset) ptr g