kairos.c

#include <stdio.h>
#include <vulkan/vulkan.h>
#include <vulkan/vk_layer.h>
#include <assert.h>

#include "HsFFI.h"
#include "Kairos_stub.h"


__attribute__((constructor))
static void __Kairos_construct() {
    printf("linking kairos\n");
    hs_init(0,0);
}

__attribute__((destructor))
static void __Kairos_destruct() {
    hs_exit();
}

VkLayerInstanceCreateInfo *get_chain_info(const VkInstanceCreateInfo *pCreateInfo, VkLayerFunction func) {
    VkLayerInstanceCreateInfo *chain_info = (VkLayerInstanceCreateInfo *)pCreateInfo->pNext;
    while (chain_info && !(chain_info->sType == VK_STRUCTURE_TYPE_LOADER_INSTANCE_CREATE_INFO && chain_info->function == func)) {
        chain_info = (VkLayerInstanceCreateInfo *)chain_info->pNext;
    }
    assert(chain_info != NULL);
    return chain_info;
}

extern VkResult VKAPI_CALL Kairos_CreateInstance(
    const VkInstanceCreateInfo*                 pCreateInfo,
    const VkAllocationCallbacks*                pAllocator,
    VkInstance*                                 pInstance) {
  VkLayerInstanceCreateInfo *chain_info =
        get_chain_info(pCreateInfo, VK_LAYER_LINK_INFO);

    assert(chain_info->u.pLayerInfo);
    PFN_vkGetInstanceProcAddr fpGetInstanceProcAddr =
        chain_info->u.pLayerInfo->pfnNextGetInstanceProcAddr;
    PFN_vkCreateInstance fpCreateInstance =
        (PFN_vkCreateInstance)fpGetInstanceProcAddr(NULL, "vkCreateInstance");
    if (fpCreateInstance == NULL) {
        return VK_ERROR_INITIALIZATION_FAILED;
    }

    // Advance the link info for the next element of the chain.
    // This ensures that the next layer gets it's layer info and not
    // the info for our current layer.
    chain_info->u.pLayerInfo = chain_info->u.pLayerInfo->pNext;

    // Continue call down the chain
    VkResult result = fpCreateInstance(pCreateInfo, pAllocator, pInstance);
    if (result != VK_SUCCESS)
        return result;

  // fetch our own dispatch table for the functions we need, into the next layer
  return Kairos_hsCreateInstance(
      *pInstance,
      (HsFunPtr)fpGetInstanceProcAddr
  );
}

extern VkResult VKAPI_CALL Kairos_CreateDevice(
    VkPhysicalDevice                            physicalDevice,
    const VkDeviceCreateInfo*                   pCreateInfo,
    const VkAllocationCallbacks*                pAllocator,
    VkDevice*                                   pDevice)
{
  VkLayerDeviceCreateInfo *layerCreateInfo = (VkLayerDeviceCreateInfo *)pCreateInfo->pNext;

  // step through the chain of pNext until we get to the link info
  while(layerCreateInfo && (layerCreateInfo->sType != VK_STRUCTURE_TYPE_LOADER_DEVICE_CREATE_INFO ||
                            layerCreateInfo->function != VK_LAYER_LINK_INFO))
  {
    layerCreateInfo = (VkLayerDeviceCreateInfo *)layerCreateInfo->pNext;
  }

  if(layerCreateInfo == NULL)
  {
    // No loader instance create info
    return VK_ERROR_INITIALIZATION_FAILED;
  }

  printf("createDevice3\n");
  PFN_vkGetInstanceProcAddr fpGetInstanceProcAddr = layerCreateInfo->u.pLayerInfo->pfnNextGetInstanceProcAddr;
  PFN_vkGetDeviceProcAddr fpGetDeviceProcAddr = layerCreateInfo->u.pLayerInfo->pfnNextGetDeviceProcAddr;
  // move chain on for next layer
  layerCreateInfo->u.pLayerInfo = layerCreateInfo->u.pLayerInfo->pNext;

  PFN_vkCreateDevice fpCreateDevice = (PFN_vkCreateDevice)fpGetInstanceProcAddr(VK_NULL_HANDLE, "vkCreateDevice");

  printf("createDevice4\n");
  VkResult ret = fpCreateDevice(physicalDevice, pCreateInfo, pAllocator, pDevice);

  printf("createDevice2\n");
  return Kairos_hsCreateDevice(
      *pDevice,
      (HsFunPtr)fpGetDeviceProcAddr
  );
}

Kairos.hs

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedLabels #-}

module Kairos where


import Data.IORef
import Data.Word
import Data.Int
import qualified Data.HashMap.Strict as Map

import qualified Vulkan as Vk
import           Vulkan ((:::))
import qualified Vulkan.CStruct.Extends as Vk
import qualified Vulkan.Dynamic as Vk
import qualified Vulkan.Zero as Vk
import Foreign.Ptr
import Foreign.C.Types
import Foreign.C.String
import Foreign.Storable

import GHC.Exts
import System.IO.Unsafe

import Control.Concurrent
import Control.Monad
import GHC.Generics
import GHC.Clock
import Text.Printf
import Optics

class Dispatchable a where
  getDispatchPtr :: a -> IO Word64

instance Dispatchable (Ptr Vk.Instance_T) where
  getDispatchPtr handle = do
    peek $ castPtr handle

instance Dispatchable (Ptr Vk.Device_T) where
  getDispatchPtr handle = do
    peek $ castPtr handle

instance Dispatchable (Ptr Vk.Queue_T) where
  getDispatchPtr handle = do
    peek $ castPtr handle

type InstanceTables = Map.HashMap (Word64) (Map.HashMap String Vk.PFN_vkVoidFunction)
type DeviceTables   = Map.HashMap (Word64) (Map.HashMap String Vk.PFN_vkVoidFunction)

{-# NOINLINE instanceTables #-}
instanceTables :: IORef InstanceTables
instanceTables = unsafePerformIO $ newIORef (Map.empty)

{-# NOINLINE deviceTables #-}
deviceTables :: IORef DeviceTables
deviceTables = unsafePerformIO $ newIORef (Map.empty)


data TimeStats = TimeStats
  { tCpu   :: Int64 -- Time at start of function call
  , tGpu   :: Int64 -- Time after QueuePresent
  , tIdle  :: Int64 -- Time after Sleeping
  , tIdleD :: Int64 -- the measured sleep time of previous frame
  , tSlew   :: Int64 -- the excess sleep time
  } deriving (Eq, Show, Generic)


data TimePoint = TimePoint
  { tCurrent :: Int64
  , tPrev    :: Int64
  } deriving (Eq, Show)


{-# NOINLINE timeStats #-}
timeStats :: IORef TimeStats
timeStats = unsafePerformIO $ newIORef (TimeStats 0 0 0 0 0)

type FN_vkGetInstanceProcAddr
  = Ptr Vk.Instance_T
  -> ("pName" ::: CString)
  -> IO Vk.PFN_vkVoidFunction

type PFN_vkGetInstanceProcAddr = FunPtr FN_vkGetInstanceProcAddr

foreign import ccall "dynamic"
  mkVkGetInstanceProcAddr :: PFN_vkGetInstanceProcAddr -> FN_vkGetInstanceProcAddr

foreign import ccall "&Kairos_GetInstanceProcAddr" pGetInstanceProcAddr
  :: PFN_vkGetInstanceProcAddr
foreign export ccall "Kairos_GetInstanceProcAddr" c_getInstanceProcAddr
  :: FN_vkGetInstanceProcAddr

c_getInstanceProcAddr :: FN_vkGetInstanceProcAddr
c_getInstanceProcAddr inst name' = do
  name <- peekCString name'

  case name of
    "vkCreateInstance"  -> return $ castFunPtr pCreateInstance
    "vkDestroyInstance" -> return $ castFunPtr pDestroyInstance
    "vkCreateDevice"    -> return $ castFunPtr pCreateDevice
    "vkDestroyDevice"   -> return $ castFunPtr pDestroyDevice
    "vkQueuePresentKHR" -> return $ castFunPtr pQueuePresent
    --"vkEnumeratePhysicalDevices" -> pEnumeratePhysicalDevices
    _ -> do
      key  <- getDispatchPtr inst
      table <- readIORef instanceTables
      case Map.lookup key table of
        Just m -> case Map.lookup "vkGetInstanceProcAddr" m of
          Just pgipa -> let gipa = mkVkGetInstanceProcAddr (castFunPtr pgipa)
                        in gipa inst name'
          Nothing -> error "what"
        Nothing -> error "what2"

foreign import ccall "kairos.h &Kairos_CreateInstance"
  pCreateInstance :: Vk.PFN_vkVoidFunction

foreign export ccall "Kairos_hsCreateInstance" createInstance
  :: Ptr Vk.Instance_T
  -> PFN_vkGetInstanceProcAddr
  -> IO Vk.Result

createInstance :: Ptr Vk.Instance_T -> PFN_vkGetInstanceProcAddr -> IO Vk.Result
createInstance pInst fp = do
  let vkGetInstanceProcAddr' = mkVkGetInstanceProcAddr fp
  key  <- getDispatchPtr pInst
  vkGetInstanceProcAddr <- vkGetInstanceProcAddr' pInst (Ptr "vkGetInstanceProcAddr"#)
  vkDestroyInstance     <- vkGetInstanceProcAddr' pInst (Ptr "vkDestroyInstance"#)
  --vkEnumerateDeviceExtensionProperties <- castFunPtr <$> vkGetInstanceProcAddr' pInst (Ptr "vkEnumerateDeviceExtensionProperties"#)
  let table = Map.fromList [
          ("vkGetInstanceProcAddr", vkGetInstanceProcAddr)
        , ("vkDestroyInstance", vkDestroyInstance)
  --      , ("vkEnumerateDeviceExtensionProperties", vkEnumerateDeviceExtensionProperties)
        ]
  atomicModifyIORef' instanceTables $ \m -> (Map.insert key table m, ())
  return Vk.SUCCESS

foreign import ccall "&Kairos_DestroyInstance" pDestroyInstance
  :: FunPtr a

foreign export ccall "Kairos_DestroyInstance" destroyInstance
  :: Ptr Vk.Instance_T
  -> Ptr (Vk.AllocationCallbacks)
  -> IO ()
destroyInstance :: Ptr Vk.Instance_T -> Ptr Vk.AllocationCallbacks -> IO ()
destroyInstance pInst allocaCb = do
        return ()

type FN_vkGetDeviceProcAddr = Ptr Vk.Device_T
  -> ("pName" ::: CString)
  -> IO Vk.PFN_vkVoidFunction

type PFN_vkGetDeviceProcAddr = FunPtr FN_vkGetDeviceProcAddr

foreign import ccall "dynamic"
  mkVkGetDeviceProcAddr :: PFN_vkGetDeviceProcAddr -> FN_vkGetDeviceProcAddr

foreign import ccall "&Kairos_GetDeviceProcAddr" pGetDeviceProcAddr
  :: PFN_vkGetDeviceProcAddr
foreign export ccall "Kairos_GetDeviceProcAddr" getDeviceProcAddr
  :: FN_vkGetDeviceProcAddr

getDeviceProcAddr :: FN_vkGetDeviceProcAddr
getDeviceProcAddr device name' = do
  name <- peekCString name'

  case name of
    "vkCreateDevice"  -> return $ castFunPtr pCreateDevice
    "vkDestroyDevice" -> return $ castFunPtr pDestroyDevice
    "vkQueuePresentKHR" -> return $ castFunPtr pQueuePresent
    _ -> do
      key  <- getDispatchPtr device
      table <- readIORef deviceTables
      itable <- readIORef instanceTables
      case Map.lookup key table of
        Just m -> case Map.lookup "vkGetDeviceProcAddr" m of
          Just pgdpa -> let gdpa = mkVkGetDeviceProcAddr (castFunPtr pgdpa)
                        in gdpa device name'
          Nothing -> error $ "can't find DeviceProcAddr " ++ show m ++ "\n" ++ show itable
        Nothing -> error $ "getDeviceProcAddr failed: " ++ show table ++ "\n" ++ show itable


foreign import ccall "&Kairos_CreateDevice" pCreateDevice
  :: Vk.PFN_vkVoidFunction

foreign export ccall "Kairos_hsCreateDevice" createDevice
  :: Ptr Vk.Device_T
  -> PFN_vkGetDeviceProcAddr
  -> IO Vk.Result

createDevice  :: Ptr Vk.Device_T
  -> PFN_vkGetDeviceProcAddr
  -> IO Vk.Result
createDevice device fp = do
  let vkGetDeviceProcAddr' = mkVkGetDeviceProcAddr fp
  key  <- getDispatchPtr device
  vkGetDeviceProcAddr <- vkGetDeviceProcAddr' device (Ptr "vkGetDeviceProcAddr"#)
  vkQueuePresentKHR   <- vkGetDeviceProcAddr' device (Ptr "vkQueuePresentKHR"#)
  let table = Map.fromList [
          ("vkGetDeviceProcAddr", vkGetDeviceProcAddr)
        , ("vkQueuePresentKHR",vkQueuePresentKHR)
        ]
  atomicModifyIORef' deviceTables $ \m -> (Map.insert key table m, ())
  return Vk.SUCCESS

foreign import ccall "&Kairos_DestroyDevice" pDestroyDevice
  :: Vk.PFN_vkVoidFunction

foreign export ccall "Kairos_DestroyDevice" destroyDevice
  :: Ptr Vk.Device_T
  -> Ptr Vk.AllocationCallbacks
  -> IO ()

destroyDevice
  :: Ptr Vk.Device_T
  -> Ptr Vk.AllocationCallbacks
  -> IO ()
destroyDevice device acbs = do
  return ()

type FN_vkQueuePresentKHR
  = Ptr Vk.Queue_T
  -> ("pPresentInfo" ::: Ptr (Vk.SomeStruct Vk.PresentInfoKHR))
  -> IO Vk.Result

foreign import ccall "dynamic"
  mkVkQueuePresentKHR :: FunPtr FN_vkQueuePresentKHR -> FN_vkQueuePresentKHR

foreign import ccall "&Kairos_QueuePresentKHR" pQueuePresent
  :: FunPtr a

foreign export ccall "Kairos_QueuePresentKHR" queuePresent
  :: FN_vkQueuePresentKHR
queuePresent :: FN_vkQueuePresentKHR
queuePresent queue pPresentInfo = do
  tCpuCurr <- fromIntegral <$> getMonotonicTimeNSec
  _ <- atomicModifyIORef' timeStats $ \old ->
    (old & #tCpu .~ tCpuCurr, ())

  key <- getDispatchPtr queue
  tables <- readIORef deviceTables
  r <- case Map.lookup key tables of
    Nothing -> return Vk.ERROR_UNKNOWN
    Just table -> case Map.lookup "vkQueuePresentKHR" table of
      Nothing -> putStrLn ("Can't find vkQueuePresentKHR " ++ show table) >> return Vk.ERROR_UNKNOWN
      Just fp -> let childQP = mkVkQueuePresentKHR (castFunPtr fp)
                 in childQP queue pPresentInfo

  tGpuCurr <- fromIntegral <$> getMonotonicTimeNSec
  tGpuPrev <- atomicModifyIORef' timeStats $ \old ->
    (old & #tGpu .~ tGpuCurr, old ^. #tGpu)

  (tIdleD, tIdlePrev, slewPrev) <- (,,) <$> view #tIdleD <*> view #tIdle <*> view #tSlew <$> readIORef timeStats
  let
    cpu = tCpuCurr - tIdlePrev
    gpu = tGpuCurr - tCpuCurr
    max' = 20 * 1000 * 1000 - (tGpuCurr - tIdlePrev) -- 20 ms / 48 fps
    min' = 8  * 1000 * 1000 - (tGpuCurr - tIdlePrev) -- 8ms / 120fps
    dyn  = (100 * max (gpu - cpu) (tIdleD - cpu)) `div` 100
    delay = max 0 $ (min max' -- don't delay too much
            $ (max min' -- framerate cap
            dyn) - (max 0 slewPrev))

  when (delay > 0) $ threadDelay . fromIntegral $ delay `div` 1000

  tIdleCurr :: Int64 <- fromIntegral <$> getMonotonicTimeNSec
  atomicModifyIORef' timeStats $ \old ->
    (old & #tIdle .~ tIdleCurr, ())

  let
    idle = tIdleCurr - tGpuCurr
    slew = idle - delay
  putStr $ printTime "idle" idle
        ++ printTime "delay" delay
        ++ printTime "cpu" cpu
        ++ printTime "gpu" cpu
        ++ printTimeLn "slew" slew

  atomicModifyIORef' timeStats $ \old ->
    (old & #tSlew .~ slew, ())

  atomicModifyIORef' timeStats $ \old ->
    (old & #tIdleD .~ idle, ())
  return r

  where
    printTime = printTime_ False
    printTimeLn = printTime_ True
    printTime_ nl n t = let
      (ms, us) = (t `div` 1000) `divMod` 1000
      end = if nl then "\n" else " "
      in n ++ printf (" %d.%03d ms" ++ end) ms us