Runtime.hs

{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}
-- |
-- Module      : Data.Array.Accelerate.LLVM.Native.Link.Runtime
-- Copyright   : [2022] The Accelerate Team
-- License     : BSD3
--
-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--
-- Utilities for linking object code to shared objects and loading those
-- generated shared objects on Unix-like systems.
--

module Data.Array.Accelerate.LLVM.Native.Link.Runtime (

  loadSharedObject

) where

import Data.Array.Accelerate.Error
import Data.Array.Accelerate.Lifetime

import Data.Array.Accelerate.LLVM.Native.Link.Object
import qualified Data.Array.Accelerate.LLVM.Native.Debug            as Debug

import Control.Monad
import Data.ByteString.Short.Char8                                  ( ShortByteString )
import Formatting
import qualified Data.ByteString.Short.Char8                        as B8

#if defined(mingw32_HOST_OS)
import Foreign.Ptr                                                  ( castPtrToFunPtr )
import System.Win32.DLL
#else
import System.Posix.DynamicLinker
#endif


-- Dynamic object loading
-- ----------------------

-- Load the shared object file and return pointers to the executable
-- functions defined within
--
loadSharedObject :: HasCallStack => [ShortByteString] -> FilePath -> IO (FunctionTable, ObjectCode)
loadSharedObject nms path = do
#if defined(mingw32_HOST_OS)
  -- shims for win32 api compatibility
  let dlopen' path' = loadLibrary path'
      dlsym dll sym = castPtrToFunPtr <$> getProcAddress dll sym
      dlclose dll   = freeLibrary dll
#else
  let dlopen' path' = dlopen path' [RTLD_LAZY, RTLD_LOCAL]
#endif
  --
  so      <- dlopen' path
  fun_tab <- fmap FunctionTable $ forM nms $ \nm -> do
    let s = B8.unpack nm
    Debug.traceM Debug.dump_ld ("ld: looking up symbol " % string) s
    sym <- dlsym so s
    return (nm, sym)

  object_code <- newLifetime so
  addFinalizer object_code $ do
    -- XXX: Should we disable unloading objects in tracy mode? Tracy might
    -- still need access to e.g. embedded string data
    Debug.traceM Debug.dump_gc ("gc: unload module: " % formatFunctionTable) fun_tab
    dlclose so

  return (fun_tab, object_code)