content: {-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}
  module BluesimLoader ( BluesimModel(..)
                       , loadBluesimModel
                       , unloadBluesimModel
                       , BSClock, bad_clock_handle
                       , BSClockValue(..)
                       , BSValue(..)
                       , BSEdgeDirection(..)
                       , BSTime
                       , BSStatus(..)
                       , BSSymbol, BSIndex, bad_symbol
                       , getClockInfo
                       , setActiveClock
                       , getCurDirStr
                       , getCurDirSym
                       ) where
  
  -- This module allows dynamically loading a Bluesim shared object
  -- into a Haskell program, and exposes the API of the model as a
  -- BluesimModel structure.
  
  import FileNameUtil(dirName,baseName)
  import ErrorUtil(internalError)
  import HTcl
  import SimCCBlock(pfxModel)
  
  import System.Posix.DynamicLinker
  import Data.Bits
  import Data.List(intercalate, isPrefixOf)
  import Data.Int
  import Data.Word
  import Data.Time.Clock
  import Data.Time.Clock.POSIX
  import Foreign.C
  import Foreign.Ptr
  import Foreign.Storable
  import Foreign.Marshal
  import Numeric(showHex)
  
  -- import Debug.Trace
  
  -- Some Haskell versions of Bluesim kernel types and constants
  
  type BSClock = Word32
  
  bad_clock_handle :: BSClock
  bad_clock_handle = complement 0
  
  data BSClockValue = CLK_LOW | CLK_HIGH
    deriving (Eq,Show)
  
  data BSEdgeDirection = NEGEDGE | POSEDGE
    deriving (Eq,Show)
  
  type BSTime = Word64
  
  data BSStatus = OK | Error Int32
    deriving (Eq)
  
  type BSSymbol = WordPtr
  type BSIndex  = Word64
  
  bad_symbol :: BSSymbol
  bad_symbol = ptrToWordPtr (nullPtr)
  
  data BSValue = Value { num_bits :: !Word32, value :: !Integer }
               | NoValue
    deriving (Eq)
  
  instance Show BSValue where
    show NoValue = "**NOVALUE**"
    show v = (show (num_bits v)) ++ "'h" ++ (showHex (value v) "")
  
  read_value :: CUInt -> Ptr CUInt -> IO Integer
  read_value bits ptr =
      do let uint_bytes = sizeOf (undefined :: CUInt)
             uint_bits  = 8 * uint_bytes
             num_uints  = ((fromIntegral bits) + uint_bits - 1) `quot` uint_bits
             offs = [0..(num_uints-1)]
             get_piece n = do { x <- peekElemOff ptr n; return (toInteger x) }
         vals <- mapM get_piece offs
         let i = foldl (.|.) 0 (zipWith shiftL vals [0,uint_bits..])
             mask = (1 `shiftL` (fromIntegral bits)) - 1
         return (i .&. mask)
  
  data BSSymTag = SYM_UNKNOWN | SYM_MODULE   | SYM_DEF
                | SYM_PARAM   | SYM_PORT     | SYM_RULE
                | SYM_RANGE   | SYM_COMPUTED
    deriving (Eq)
  
  instance Show BSSymTag where
    show SYM_UNKNOWN  = "?"
    show SYM_MODULE   = "module"
    show SYM_DEF      = "signal"
    show SYM_PARAM    = "parameter"
    show SYM_PORT     = "port"
    show SYM_RULE     = "rule"
    show SYM_RANGE    = "array"
    show SYM_COMPUTED = "value"
  
  instance Read BSSymTag where
    readsPrec _ x
        | "module" `isPrefixOf` x    = [(SYM_MODULE,drop 6 x)]
        | "signal" `isPrefixOf` x    = [(SYM_DEF,drop 6 x)]
        | "parameter" `isPrefixOf` x = [(SYM_PARAM,drop 9 x)]
        | "port" `isPrefixOf` x      = [(SYM_PORT,drop 4 x)]
        | "rule" `isPrefixOf` x      = [(SYM_RULE,drop 4 x)]
        | "array" `isPrefixOf` x     = [(SYM_RANGE,drop 5 x)]
        | "value" `isPrefixOf` x     = [(SYM_COMPUTED,drop 5 x)]
        | "?" `isPrefixOf` x         = [(SYM_UNKNOWN,drop 1 x)]
        | otherwise                  = []
  
  instance  TclObjCvt BSClockValue where
      toTclObj v = toTclObj (v == CLK_HIGH)
  
  instance  TclObjCvt BSValue where
      toTclObj v = toTclObj (show v)
  
  instance  TclObjCvt BSSymTag where
      toTclObj t = toTclObj (show t)
  
  -- Some useful constants for working with C types
  
  type C_tBool          = CUChar
  type C_tClock         = CUInt
  type C_tClockValue    = CInt
  type C_tEdgeDirection = CInt
  type C_tTime          = CULLong
  type C_tStatus        = CInt
  type C_tSymTag        = CUChar
  
  -- Utilities for working with C structures
  
  field :: (Storable a) => a -> (Int,Int)
  field x = (sizeOf x, alignment x)
  
  compute_offsets :: [(Int,Int)] -> [Int]
  compute_offsets fs = helper nullPtr fs
      where helper _   []         = []
            helper ptr ((s,a):xs) =
                let off = (alignPtr ptr a) `minusPtr` nullPtr
                in off:(helper (ptr `plusPtr` s) xs)
  
  get_ptr :: [Int] -> Int -> Ptr a -> Ptr b
  get_ptr offs n ptr = castPtr (ptr `plusPtr` (offs!!n))
  
  fromCString :: CString -> IO String
  fromCString cs | cs == nullPtr = return ""
                 | otherwise     = peekCString cs
  
  -- Storable definition for CVersionInfo structure
  
  data CVersionInfo = CVersionInfo { cvi_name  :: CString
                                   , cvi_build :: CString
                                   , cvi_time  :: CTime
                                   }
  cvi_fields :: [(Int,Int)]
  cvi_fields = [ field (undefined :: CString)
               , field (undefined :: CString)
               , field (undefined :: CTime)
               ]
  
  cvi_offsets :: [Int]
  cvi_offsets = compute_offsets cvi_fields
  
  instance Storable CVersionInfo where
    sizeOf    _ = (last cvi_offsets) + (fst (last cvi_fields))
    alignment _ = snd (head cvi_fields)
    peek ptr = do name  <- peek (get_ptr cvi_offsets 0 ptr)
                  build <- peek (get_ptr cvi_offsets 1 ptr)
                  t     <- peek (get_ptr cvi_offsets 2 ptr)
                  return $ CVersionInfo name build t
    poke ptr cvi = do poke (get_ptr cvi_offsets 0 ptr) (cvi_name cvi)
                      poke (get_ptr cvi_offsets 1 ptr) (cvi_build cvi)
                      poke (get_ptr cvi_offsets 2 ptr) (cvi_time cvi)
  
  -- A typeclass useful for converting values from Haskell to C and back
  
  class AutoC h c where
    toC   :: h -> c
    fromC :: c -> h
  
  instance AutoC Bool C_tBool where
    toC False = 0
    toC True  = 1
    fromC 0 = False
    fromC _ = True
  
  instance AutoC BSStatus C_tStatus where
    toC OK        = 0
    toC (Error n) = toC n
    fromC 0 = OK
    fromC n = Error (fromC n)
  
  instance AutoC Int32 CInt where
    toC   = fromInteger . toInteger
    fromC = fromInteger .toInteger
  
  instance AutoC Word32 CUInt where
    toC   = fromInteger . toInteger
    fromC = fromInteger .toInteger
  
  instance AutoC Word64 CULLong where
    toC   = fromInteger . toInteger
    fromC = fromInteger . toInteger
  
  instance (AutoC a c, AutoC b d) => AutoC (a -> b) (c -> d) where
    toC   f = toC . f . fromC
    fromC f = fromC . f . toC
  
  instance AutoC BSClockValue C_tClockValue where
    toC CLK_LOW = 0
    toC CLK_HIGH = 1
    fromC 0 = CLK_LOW
    fromC 1 = CLK_HIGH
    fromC n = internalError $ "BSClockValue.fromC: invalid enum value: " ++ (show n)
  
  instance AutoC BSEdgeDirection C_tEdgeDirection where
    toC NEGEDGE = 0
    toC POSEDGE = 1
    fromC 0 = NEGEDGE
    fromC 1 = POSEDGE
    fromC n = internalError $ "BSEdgeDirection.fromC: invalid enum value: " ++ (show n)
  
  -- this magic came from Simon Marlow
  instance AutoC UTCTime CTime where
    toC   t = error "cannot convert from UTCTime to CTime"
    fromC t = posixSecondsToUTCTime (fromRational (toRational t))
  
  -- Note: can't have instance AutoC a a because AutoC (IO h) (IO c) would
  -- overlap.
  
  instance AutoC () () where
    toC   = id
    fromC = id
  
  instance AutoC CUInt CUInt where
    toC   = id
    fromC = id
  
  instance AutoC CULLong CULLong where
    toC   = id
    fromC = id
  
  instance AutoC WordPtr (Ptr CUInt) where
    toC   = wordPtrToPtr
    fromC = ptrToWordPtr
  
  instance (AutoC h c) => AutoC (IO h) (IO c) where
    toC   x = x >>= (return . toC)
    fromC x = x >>= (return . fromC)
  
  instance AutoC BSSymTag C_tSymTag where
    toC SYM_UNKNOWN  = 0
    toC SYM_MODULE   = 1
    toC SYM_DEF      = 2
    toC SYM_PARAM    = 3
    toC SYM_PORT     = 4
    toC SYM_RULE     = 5
    toC SYM_RANGE    = 6
    toC SYM_COMPUTED = 7
    fromC 1 = SYM_MODULE
    fromC 2 = SYM_DEF
    fromC 3 = SYM_PARAM
    fromC 4 = SYM_PORT
    fromC 5 = SYM_RULE
    fromC 6 = SYM_RANGE
    fromC 7 = SYM_COMPUTED
    fromC _ = SYM_UNKNOWN
  
  -- FFI routines for importing various kinds of dynamically-loaded C functions
  
  -- returning void
  foreign import ccall "dynamic"
    dl_ptr_ret_void :: FunPtr (Ptr CUInt -> IO ()) -> (Ptr CUInt -> IO ())
  
  foreign import ccall "dynamic"
    dl_ptr_str_ret_void :: FunPtr (Ptr CUInt -> CString -> IO ()) ->
                           (Ptr CUInt -> CString -> IO ())
  
  foreign import ccall "dynamic"
    dl_ptr_str_ullong_ret_int :: FunPtr (Ptr CUInt -> CString -> CULLong -> IO CInt) ->
                                 (Ptr CUInt -> CString -> CULLong -> IO CInt)
  
  foreign import ccall "dynamic"
    dl_ptr_version_ret_void :: FunPtr (Ptr CUInt -> Ptr CVersionInfo -> IO ()) ->
                               (Ptr CUInt -> Ptr CVersionInfo -> IO ())
  
  -- returning uchar
  foreign import ccall "dynamic"
    dl_ptr_ret_uchar :: FunPtr (Ptr CUInt -> IO CUChar) -> (Ptr CUInt -> IO CUChar)
  
  -- returning uint
  foreign import ccall "dynamic"
    dl_ptr_uint_ret_uint :: FunPtr (Ptr CUInt -> CUInt -> IO CUInt) ->
                            (Ptr CUInt -> CUInt -> IO CUInt)
  
  foreign import ccall "dynamic"
    dl_ptr_str_ret_uint :: FunPtr (Ptr CUInt -> CString -> IO CUInt) ->
                           (Ptr CUInt -> CString -> IO CUInt)
  
  foreign import ccall "dynamic"
    dl_ptr_ret_uint :: FunPtr (Ptr CUInt -> IO CUInt) -> (Ptr CUInt -> IO CUInt)
  
  -- returning int
  foreign import ccall "dynamic"
    dl_ptr_ret_int :: FunPtr (Ptr CUInt -> IO CInt) -> (Ptr CUInt -> IO CInt)
  
  foreign import ccall "dynamic"
    dl_ptr_uchar_ret_int :: FunPtr (Ptr CUInt -> CUChar -> IO CInt) ->
                            (Ptr CUInt -> CUChar -> IO CInt)
  
  foreign import ccall "dynamic"
    dl_ptr_uint_ret_int :: FunPtr (Ptr CUInt -> CUInt -> IO CInt) ->
                           (Ptr CUInt -> CUInt -> IO CInt)
  
  foreign import ccall "dynamic"
    dl_ptr_ullong_ret_int :: FunPtr (Ptr CUInt -> CULLong -> IO CInt) ->
                             (Ptr CUInt -> CULLong -> IO CInt)
  
  foreign import ccall "dynamic"
    dl_ptr_str_ret_int :: FunPtr (Ptr CUInt -> CString -> IO CInt) ->
                          (Ptr CUInt -> CString -> IO CInt)
  
  foreign import ccall "dynamic"
    dl_ptr_uchar_ret_ptr :: FunPtr (Ptr CUInt -> CUChar -> IO (Ptr CUInt)) ->
                            (Ptr CUInt -> CUChar -> IO (Ptr CUInt))
  
  foreign import ccall "dynamic"
    dl_ptr_uint_int_ullong_ret_int :: FunPtr (Ptr CUInt -> CUInt -> CInt -> CULLong -> IO CInt) ->
                                      (Ptr CUInt -> CUInt -> CInt -> CULLong -> IO CInt)
  
  -- returning ullong
  foreign import ccall "dynamic"
    dl_ptr_ret_ullong :: FunPtr (Ptr CUInt -> IO CULLong) -> (Ptr CUInt -> IO CULLong)
  
  foreign import ccall "dynamic"
    dl_ptr_uint_ret_ullong :: FunPtr (Ptr CUInt -> CUInt -> IO CULLong) ->
                              (Ptr CUInt -> CUInt -> IO CULLong)
  
  foreign import ccall "dynamic"
    dl_ptr_uint_int_ret_ullong :: FunPtr (Ptr CUInt -> CUInt -> CInt -> IO CULLong) ->
                                  (Ptr CUInt -> CUInt -> CInt -> IO CULLong)
  
  -- returning str
  foreign import ccall "dynamic"
    dl_ptr_ret_str :: FunPtr (Ptr CUInt -> IO CString) -> (Ptr CUInt -> IO CString)
  
  foreign import ccall "dynamic"
    dl_ptr_uint_ret_str :: FunPtr (Ptr CUInt -> CUInt -> IO CString) -> (Ptr CUInt -> CUInt -> IO CString)
  
  -- returning ptr
  foreign import ccall "dynamic"
    dl_ret_ptr :: FunPtr (IO (Ptr CUInt)) -> IO (Ptr CUInt)
  
  foreign import ccall "dynamic"
    dl_ptr_ret_ptr :: FunPtr (Ptr CUInt -> IO (Ptr CUInt)) -> (Ptr CUInt -> IO (Ptr CUInt))
  
  foreign import ccall "dynamic"
    dl_ptr_uint_ret_ptr :: FunPtr (Ptr CUInt -> CUInt -> IO (Ptr CUInt)) ->
                           (Ptr CUInt -> CUInt -> IO (Ptr CUInt))
  
  foreign import ccall "dynamic"
    dl_ptr_ullong_ret_ptr :: FunPtr (Ptr CUInt -> CULLong -> IO (Ptr CUInt)) ->
                             (Ptr CUInt -> CULLong -> IO (Ptr CUInt))
  
  foreign import ccall "dynamic"
    dl_ptr_str_ret_ptr :: FunPtr (Ptr CUInt -> CString -> IO (Ptr CUInt)) ->
                          (Ptr CUInt -> CString -> IO (Ptr CUInt))
  
  -- returning other types
  type DefClkFn = Ptr CUInt -> CString -> C_tClockValue -> CUChar -> C_tTime -> C_tTime -> C_tTime -> IO C_tClock
  foreign import ccall "dynamic"
    dl_def_clk_fn :: FunPtr DefClkFn -> DefClkFn
  
  -- Definition of the BluesimModel structure
  -- The fields of the model represent Bluesim kernel API functions for
  -- the model which have been dynamically linked and converted to use
  -- normal Haskell types, so that it presents an abstract Haskell view
  -- of the Bluesim model.
  
  data BluesimModel =
      BS { model_so               :: DL
         , model_hdl              :: WordPtr
         , sim_hdl                :: WordPtr
         , current_clock          :: BSClock
         , active_vcd_file        :: Maybe String
         , current_directory      :: [BSSymbol]
         , cleanup_handlers       :: [IO ()]
           -- configuration state
         , is_interactive         :: Bool
           -- imported API functions
         , bk_now                 :: IO BSTime
         , bk_set_timescale       :: String -> BSTime -> IO BSStatus
         , bk_version             :: IO (String, String, UTCTime)
         , bk_append_argument     :: String -> IO ()
         , bk_define_clock        :: String -> BSClockValue -> Bool -> BSTime -> BSTime -> BSTime -> IO BSClock
         , bk_num_clocks          :: IO Word32
         , bk_get_nth_clock       :: Word32 -> IO BSClock
         , bk_get_clock_by_name   :: String -> IO BSClock
         , bk_clock_name          :: BSClock -> IO String
         , bk_clock_initial_value :: BSClock -> IO BSClockValue
         , bk_clock_first_edge    :: BSClock -> IO BSTime
         , bk_clock_duration      :: BSClock -> BSClockValue -> IO BSTime
         , bk_clock_val           :: BSClock -> IO BSClockValue
         , bk_clock_cycle_count   :: BSClock -> IO Word64
         , bk_clock_edge_count    :: BSClock -> BSEdgeDirection -> IO Word64
         , bk_clock_last_edge     :: BSClock -> IO BSTime
         , bk_quit_after_edge     :: BSClock -> BSEdgeDirection -> Word64 -> IO Int32
         , bk_schedule_ui_event   :: BSTime -> IO BSStatus
         , bk_remove_ui_event     :: BSTime -> IO BSStatus
         , bk_set_interactive     :: IO ()
         , bk_advance             :: Bool -> IO BSStatus
         , bk_is_running          :: IO Bool
         , bk_sync                :: IO BSTime
         , bk_abort_now           :: IO ()
         , bk_finished            :: IO Bool
         , bk_exit_status         :: IO Int32
         , bk_top_symbol          :: IO BSSymbol
         , bk_lookup_symbol       :: BSSymbol -> String -> IO BSSymbol
         , bk_get_key             :: BSSymbol -> IO String
         , bk_is_module           :: BSSymbol -> IO Bool
         , bk_is_rule             :: BSSymbol -> IO Bool
         , bk_is_single_value     :: BSSymbol -> IO Bool
         , bk_is_value_range      :: BSSymbol -> IO Bool
         , bk_peek_symbol_value   :: BSSymbol -> IO BSValue
         , bk_get_range_min_addr  :: BSSymbol -> IO BSIndex
         , bk_get_range_max_addr  :: BSSymbol -> IO BSIndex
         , bk_peek_range_value    :: BSSymbol -> BSIndex -> IO BSValue
         , bk_num_symbols         :: BSSymbol -> IO Word32
         , bk_get_nth_symbol      :: BSSymbol -> Word32 -> IO BSSymbol
         , bk_set_VCD_file        :: String -> IO BSStatus
         , bk_enable_VCD_dumping  :: IO Bool
         , bk_disable_VCD_dumping :: IO ()
         , bk_shutdown            :: IO ()
         }
  
  -- Routine which dynamically loads a Bluesim .so file and creates
  -- a BluesimModel value which allows access to the Bluesim object.
  -- Returns Nothing if an error occurs during loading
  
  loadBluesimModel :: String -> String -> IO (Maybe BluesimModel)
  loadBluesimModel fname top_name = do
    -- load the shared object
    let fname' = (dirName fname) ++ "/" ++ (baseName fname)
    dl <- dlopen fname' [RTLD_NOW]
    -- lookup symbols in the shared object
    c_new_model              <- dlsym dl ("new_" ++ pfxModel ++ top_name)
    c_bk_init                <- dlsym dl "bk_init"
    c_bk_now                 <- dlsym dl "bk_now"
    c_bk_set_timescale       <- dlsym dl "bk_set_timescale"
    c_bk_version             <- dlsym dl "bk_version"
    c_bk_append_argument     <- dlsym dl "bk_append_argument"
    c_bk_define_clock        <- dlsym dl "bk_define_clock"
    c_bk_num_clocks          <- dlsym dl "bk_num_clocks"
    c_bk_get_nth_clock       <- dlsym dl "bk_get_nth_clock"
    c_bk_clock_name          <- dlsym dl "bk_clock_name"
    c_bk_get_clock_by_name   <- dlsym dl "bk_get_clock_by_name"
    c_bk_clock_initial_value <- dlsym dl "bk_clock_initial_value"
    c_bk_clock_first_edge    <- dlsym dl "bk_clock_first_edge"
    c_bk_clock_duration      <- dlsym dl "bk_clock_duration"
    c_bk_clock_val           <- dlsym dl "bk_clock_val"
    c_bk_clock_cycle_count   <- dlsym dl "bk_clock_cycle_count"
    c_bk_clock_edge_count    <- dlsym dl "bk_clock_edge_count"
    c_bk_clock_last_edge     <- dlsym dl "bk_clock_last_edge"
    c_bk_quit_after_edge     <- dlsym dl "bk_quit_after_edge"
    c_bk_schedule_ui_event   <- dlsym dl "bk_schedule_ui_event"
    c_bk_remove_ui_event     <- dlsym dl "bk_remove_ui_event"
    c_bk_set_interactive     <- dlsym dl "bk_set_interactive"
    c_bk_advance             <- dlsym dl "bk_advance"
    c_bk_is_running          <- dlsym dl "bk_is_running"
    c_bk_sync                <- dlsym dl "bk_sync"
    c_bk_abort_now           <- dlsym dl "bk_abort_now"
    c_bk_finished            <- dlsym dl "bk_finished"
    c_bk_exit_status         <- dlsym dl "bk_exit_status"
    c_bk_top_symbol          <- dlsym dl "bk_top_symbol"
    c_bk_lookup_symbol       <- dlsym dl "bk_lookup_symbol"
    c_bk_get_size            <- dlsym dl "bk_get_size"
    c_bk_get_key             <- dlsym dl "bk_get_key"
    c_bk_is_module           <- dlsym dl "bk_is_module"
    c_bk_is_rule             <- dlsym dl "bk_is_rule"
    c_bk_is_single_value     <- dlsym dl "bk_is_single_value"
    c_bk_is_value_range      <- dlsym dl "bk_is_value_range"
    c_bk_peek_symbol_value   <- dlsym dl "bk_peek_symbol_value"
    c_bk_get_range_min_addr  <- dlsym dl "bk_get_range_min_addr"
    c_bk_get_range_max_addr  <- dlsym dl "bk_get_range_max_addr"
    c_bk_peek_range_value    <- dlsym dl "bk_peek_range_value"
    c_bk_num_symbols         <- dlsym dl "bk_num_symbols"
    c_bk_get_nth_symbol      <- dlsym dl "bk_get_nth_symbol"
    c_bk_set_VCD_file        <- dlsym dl "bk_set_VCD_file"
    c_bk_enable_VCD_dumping  <- dlsym dl "bk_enable_VCD_dumping"
    c_bk_disable_VCD_dumping <- dlsym dl "bk_disable_VCD_dumping"
    c_bk_shutdown            <- dlsym dl "bk_shutdown"
    -- convert functions to Haskell types and build BluesimModel
    let new_model :: IO WordPtr
        new_model = fromC $ dl_ret_ptr c_new_model
        bk_init :: WordPtr -> Bool -> IO WordPtr
        bk_init = fromC $ dl_ptr_uchar_ret_ptr c_bk_init
        -- string return must be handled specially for bk_clock_name, etc.
        clk_name_fn :: WordPtr -> BSClock -> IO String
        clk_name_fn simHdl c =
            do cstr <- dl_ptr_uint_ret_str c_bk_clock_name (toC simHdl) (toC c)
               fromCString cstr
        sym_name_fn ptr =
            if (ptr == bad_symbol)
            then return "BAD_SYMBOL"
            else do cstr <- dl_ptr_ret_str c_bk_get_key (toC ptr)
                    fromCString cstr
        -- string argument must be handled specially for bk_define_clock, etc.
        def_clk_fn :: WordPtr -> String -> BSClockValue -> Bool -> BSTime -> BSTime -> BSTime -> IO BSClock
        def_clk_fn simHdl s iv hi st fe ne =
            let fn = dl_def_clk_fn c_bk_define_clock
            in withCString s (\cs -> fromC $ fn (toC simHdl) cs (toC iv) (toC hi) (toC st) (toC fe) (toC ne))
        get_clk_fn :: WordPtr -> String -> IO BSClock
        get_clk_fn simHdl s =
            let fn = dl_ptr_str_ret_uint c_bk_get_clock_by_name
            in withCString s (fromC . fn (toC simHdl))
        set_vcd_fn :: WordPtr -> String -> IO BSStatus
        set_vcd_fn simHdl s =
            let fn = dl_ptr_str_ret_int c_bk_set_VCD_file
            in withCString s (fromC . fn (toC simHdl))
        plusarg_fn :: WordPtr -> String -> IO ()
        plusarg_fn simHdl s =
            let fn = dl_ptr_str_ret_void c_bk_append_argument
            in withCString s (fromC . fn (toC simHdl))
        set_timescale_fn :: WordPtr -> String -> BSTime -> IO BSStatus
        set_timescale_fn simHdl ts_unit ts_factor =
            let fn = dl_ptr_str_ullong_ret_int c_bk_set_timescale
            in withCString ts_unit
                 (\cs -> fromC $ fn (toC simHdl) cs (toC ts_factor))
        lookup_fn :: BSSymbol -> String -> IO BSSymbol
        lookup_fn sym s =
            withCString s
              (fromC . dl_ptr_str_ret_ptr c_bk_lookup_symbol (toC sym))
        -- version structure needs full-on Storable support
        version_fn :: WordPtr -> IO (String, String, UTCTime)
        version_fn simHdl =
            do let fn = dl_ptr_version_ret_void c_bk_version
               alloca (\ptr -> do fn (toC simHdl) ptr
                                  (CVersionInfo nstr bstr t) <- peek ptr
                                  name  <- fromCString nstr
                                  build <- fromCString bstr
                                  return (name, build, fromC t))
        -- bk_peek_symbol_value
        peek_symbol_fn :: BSSymbol -> IO BSValue
        peek_symbol_fn p =
            do let size_fn = dl_ptr_ret_uint c_bk_get_size
                   peek_fn = dl_ptr_ret_ptr c_bk_peek_symbol_value
               sz <- size_fn (toC p)
               vptr <- peek_fn (toC p)
               if (fromC vptr /= bad_symbol)
                then do v <- read_value sz vptr
                        return $ Value { num_bits = (fromC sz), value = v }
                else return NoValue
        -- bk_peek_range_value
        peek_range_fn :: BSSymbol -> BSIndex -> IO BSValue
        peek_range_fn p addr =
            do let size_fn = dl_ptr_ret_uint c_bk_get_size
                   peek_fn = dl_ptr_ullong_ret_ptr c_bk_peek_range_value
               sz <- size_fn (toC p)
               vptr <- peek_fn (toC p) (toC addr)
               if (fromC vptr /= bad_symbol)
                then do v <- read_value sz vptr
                        return $ Value { num_bits = (fromC sz), value = v }
                else return NoValue
    model_hdl <- new_model
    sim_hdl <- bk_init model_hdl True
    if (sim_hdl == ptrToWordPtr nullPtr)
     then return Nothing
     else do
          top_symbol <- (fromC $ dl_ptr_ret_ptr c_bk_top_symbol) sim_hdl
          return $ Just (BS { model_so               = dl
                            , model_hdl              = model_hdl
                            , sim_hdl                = sim_hdl
                            , current_clock          = 0  -- default clock handle
                            , active_vcd_file        = Nothing
                            , current_directory      = [top_symbol]
                            , cleanup_handlers       = []
                            , is_interactive         = False
                            , bk_now                 = (fromC $ dl_ptr_ret_ullong c_bk_now) sim_hdl
                            , bk_set_timescale       = set_timescale_fn sim_hdl
                            , bk_version             = version_fn sim_hdl
                            , bk_append_argument     = plusarg_fn sim_hdl
                            , bk_define_clock        = def_clk_fn sim_hdl
                            , bk_num_clocks          = (fromC $ dl_ptr_ret_uint c_bk_num_clocks) sim_hdl
                            , bk_get_nth_clock       = (fromC $ dl_ptr_uint_ret_uint c_bk_get_nth_clock) sim_hdl
                            , bk_get_clock_by_name   = get_clk_fn sim_hdl
                            , bk_clock_name          = clk_name_fn sim_hdl
                            , bk_clock_initial_value = (fromC $ dl_ptr_uint_ret_int c_bk_clock_initial_value) sim_hdl
                            , bk_clock_first_edge    = (fromC $ dl_ptr_uint_ret_ullong c_bk_clock_first_edge) sim_hdl
                            , bk_clock_duration      = (fromC $ dl_ptr_uint_int_ret_ullong c_bk_clock_duration) sim_hdl
                            , bk_clock_val           = (fromC $ dl_ptr_uint_ret_int c_bk_clock_val) sim_hdl
                            , bk_clock_cycle_count   = (fromC $ dl_ptr_uint_ret_ullong c_bk_clock_cycle_count) sim_hdl
                            , bk_clock_edge_count    = (fromC $ dl_ptr_uint_int_ret_ullong c_bk_clock_edge_count) sim_hdl
                            , bk_clock_last_edge     = (fromC $ dl_ptr_uint_ret_ullong c_bk_clock_last_edge) sim_hdl
                            , bk_quit_after_edge     = (fromC $ dl_ptr_uint_int_ullong_ret_int c_bk_quit_after_edge) sim_hdl
                            , bk_schedule_ui_event   = (fromC $ dl_ptr_ullong_ret_int c_bk_schedule_ui_event) sim_hdl
                            , bk_remove_ui_event     = (fromC $ dl_ptr_ullong_ret_int c_bk_remove_ui_event) sim_hdl
                            , bk_set_interactive     = (fromC $ dl_ptr_ret_void c_bk_set_interactive) sim_hdl
                            , bk_advance             = (fromC $ dl_ptr_uchar_ret_int c_bk_advance) sim_hdl
                            , bk_is_running          = (fromC $ dl_ptr_ret_uchar c_bk_is_running) sim_hdl
                            , bk_sync                = (fromC $ dl_ptr_ret_ullong c_bk_sync) sim_hdl
                            , bk_abort_now           = (fromC $ dl_ptr_ret_void c_bk_abort_now) sim_hdl
                            , bk_finished            = (fromC $ dl_ptr_ret_uchar c_bk_finished) sim_hdl
                            , bk_exit_status         = (fromC $ dl_ptr_ret_int c_bk_exit_status) sim_hdl
                            , bk_top_symbol          = (fromC $ dl_ptr_ret_ptr c_bk_top_symbol) sim_hdl
                            , bk_lookup_symbol       = lookup_fn
                            , bk_get_key             = sym_name_fn
                            , bk_is_module           = (fromC . dl_ptr_ret_uchar c_bk_is_module . toC)
                            , bk_is_rule             = (fromC . dl_ptr_ret_uchar c_bk_is_rule . toC)
                            , bk_is_single_value     = (fromC . dl_ptr_ret_uchar c_bk_is_single_value . toC)
                            , bk_is_value_range      = (fromC . dl_ptr_ret_uchar c_bk_is_value_range . toC)
                            , bk_peek_symbol_value   = peek_symbol_fn
                            , bk_get_range_min_addr  = (fromC . dl_ptr_ret_ullong c_bk_get_range_min_addr . toC)
                            , bk_get_range_max_addr  = (fromC . dl_ptr_ret_ullong c_bk_get_range_max_addr . toC)
                            , bk_peek_range_value    = peek_range_fn
                            , bk_num_symbols         = (fromC . dl_ptr_ret_uint c_bk_num_symbols . toC)
                            , bk_get_nth_symbol      = (fromC . dl_ptr_uint_ret_ptr c_bk_get_nth_symbol . toC)
                            , bk_set_VCD_file        = set_vcd_fn sim_hdl
                            , bk_enable_VCD_dumping  = (fromC $ dl_ptr_ret_uchar c_bk_enable_VCD_dumping) sim_hdl
                            , bk_disable_VCD_dumping = (fromC $ dl_ptr_ret_void c_bk_disable_VCD_dumping) sim_hdl
                            , bk_shutdown            = (fromC $ dl_ptr_ret_void c_bk_shutdown) sim_hdl
                            })
  
  unloadBluesimModel :: BluesimModel -> IO ()
  unloadBluesimModel bs = do bk_shutdown bs
                             dlclose (model_so bs)
  
  -- fields are: clock handle, currently active, name, initial value,
  --             first edge, low duration, high_duration, cycles elapsed,
  --             current value, last edge time
  getClockInfo :: BluesimModel -> IO [(BSClock,Bool,String,BSClockValue,BSTime,BSTime,BSTime,Word64,BSClockValue,BSTime)]
  getClockInfo bs =
      do n <- bk_num_clocks bs
         mapM helper [0..n-1]
      where helper x = do clk <- bk_get_nth_clock bs x
                          let is_active = (current_clock bs == clk)
                          name <- bk_clock_name bs clk
                          ival <- bk_clock_initial_value bs clk
                          delay <- bk_clock_first_edge bs clk
                          lo <- bk_clock_duration bs clk CLK_LOW
                          hi <- bk_clock_duration bs clk CLK_HIGH
                          cycles <- bk_clock_cycle_count bs clk
                          val <- bk_clock_val bs clk
                          etime <- bk_clock_last_edge bs clk
                          return ( clk
                                 , is_active
                                 , name
                                 , ival
                                 , delay
                                 , lo
                                 , hi
                                 , cycles
                                 , val
                                 , etime
                                 )
  
  setActiveClock :: BluesimModel -> String -> IO (Maybe BluesimModel)
  setActiveClock bs name =
      do clk <- bk_get_clock_by_name bs name
         if (clk == bad_clock_handle)
          then return Nothing
          else return $ Just (bs { current_clock = clk })
  
  getCurDirStr :: BluesimModel -> IO String
  getCurDirStr bs =
      do let ds = current_directory bs
         segments <- mapM (bk_get_key bs) ds
         let dir = intercalate "." (reverse segments)
         return $ if (null dir) then "." else dir
  
  getCurDirSym :: BluesimModel -> IO BSSymbol
  getCurDirSym bs =
      do let ds = current_directory bs
         return $ head ds
  