Add Functor and Applicative instances

Author: kleinreact

clash-testbench/example/Main.hs

@@ -9,7 +9,7 @@ import qualified Calculator (topEntity)
 myTestbench
   :: TB ()
 myTestbench = mdo
-  input <- inputFromList Pop [Imm 1, Push, Imm 2, Push, Pop, Pop, Pop, ADD]
+  input <- fromList Pop [Imm 1, Push, Imm 2, Push, Pop, Pop, Pop, ADD]
   output <- ("topEntity" @@ Calculator.topEntity) auto auto auto input
   watch input
   watch output

clash-testbench/src/Clash/Testbench/Input.hs

@@ -6,7 +6,7 @@ Maintainer:   QBayLogic B.V. <[email protected]>
 Input sources for simulating 'TB' defined testbenches.
 -}
 module Clash.Testbench.Input
-  ( inputFromList
+  ( fromList
   ) where
 
 import Control.Monad.State.Lazy
@@ -25,17 +25,16 @@ import Clash.Testbench.Internal.ID
 -- the list is finite and the number of simulation steps exceeds the
 -- length of the list, then the value of the first argument is
 -- used instead.
-inputFromList
+fromList
   :: (KnownDomain dom, BitPack a, NFDataX a) => a -> [a] -> TB (TBSignal dom a)
-inputFromList x xs = do
-  FreeID i <- nextFreeID
+fromList x xs = do
   ST{..} <- get
 
   listRef <- liftIO $ newIORef $ x : xs
   simStepCache <- liftIO (readIORef simStepRef >>= newIORef)
 
-  registerTBS $ IOInput
-    { signalId     = SignalID i
+  mindSignal $ IOInput
+    { signalId     = NoID
     , signalPrint  = Nothing
     , signalCurVal = do
         (r, rs) <- fromMaybe (x, []) . uncons <$> readIORef listRef

clash-testbench/src/Clash/Testbench/Internal/ID.hs

@@ -14,6 +14,7 @@ module Clash.Testbench.Internal.ID
   , isClockID
   , isResetID
   , isEnableID
+  , isNoID
   ) where
 
 import Clash.Prelude (Type)
@@ -83,6 +84,9 @@ data ID (stage :: Stage) a where
   ClockID  ::                IDSource stage CLOCK  -> ID stage CLOCK
   ResetID  ::                IDSource stage RESET  -> ID stage RESET
   EnableID ::                IDSource stage ENABLE -> ID stage ENABLE
+  -- signals that result from higher order applications may not be
+  -- explicitly available
+  NoID     ::                                         ID stage SIGNAL
   -- wrapper type for passing different ID types around. Note that IDs
   -- of the free id pool cannot be passed around this way.
   SomeID   :: (a ~ IDT a) => ID stage a            -> ID stage ()
@@ -100,6 +104,7 @@ instance AnyStage 'USER where
     ClockID  x -> f $ Right x
     ResetID x  -> f $ Right x
     EnableID x -> f $ Right x
+    NoID       -> f $ Left (-1)
     SomeID s   -> mapID f s
 
 instance AnyStage 'FINAL where
@@ -108,6 +113,7 @@ instance AnyStage 'FINAL where
     ClockID  x -> f $ Left x
     ResetID x  -> f $ Left x
     EnableID x -> f $ Left x
+    NoID       -> f $ Left (-1)
     SomeID s   -> mapID f s
 
 instance Num (ID 'USER Int) where
@@ -128,7 +134,9 @@ instance Show (ID s Int) where
   show (FreeID x) = show x
 
 instance Show (ID s SIGNAL) where
-  show (SignalID x) = 's' : show x
+  show = \case
+    SignalID x -> 's' : show x
+    NoID       -> "-"
 
 instance AnyStage s => Show (ID s CLOCK) where
   show x = 'c' : mapID showEither x
@@ -145,6 +153,7 @@ instance AnyStage s => Show (ID s ()) where
     ClockID{}  -> show x
     ResetID{}  -> show x
     EnableID{} -> show x
+    NoID{}     -> show x
 
 showEither :: (Show a, Show b) => Either a b -> String
 showEither = \case
@@ -158,17 +167,28 @@ idToInt = \case
   ClockID x  -> x
   ResetID x  -> x
   EnableID x -> x
+  NoID       -> -1
   SomeID s   -> idToInt s
 
 -- | Checks whether the given ID is a signal identifier.
 isSignalID :: ID s a -> Bool
 isSignalID = \case
   SignalID{} -> True
+  NoID{}     -> True
   SomeID s   -> case s of
     SignalID{} -> True
+    NoID{}     -> True
     _          -> False
   _          -> False
 
+isNoID :: ID s a -> Bool
+isNoID = \case
+  NoID{} -> True
+  SomeID s  -> case s of
+    NoID{} -> True
+    _      -> False
+  _         -> False
+
 -- | Checks whether the given ID is a clock identifier.
 isClockID :: ID s a -> Bool
 isClockID = \case

clash-testbench/src/Clash/Testbench/Internal/Monad.hs

@@ -2,7 +2,6 @@ module Clash.Testbench.Internal.Monad where
 
 import Control.Arrow (second)
 import Control.Monad.State.Lazy (StateT, liftIO, get, gets, modify, forM, evalStateT)
-import Data.Set (Set, toList, member, insert)
 import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
 
 import qualified Data.Map as M
@@ -47,13 +46,15 @@ instance Ord DomainSpecificIDSource where
   compare DSEnable{} _          = LT
   compare _          DSEnable{} = GT
 
+type KnownSignals (s :: Stage) = S.Set (SomeSignal s)
+
 data ST =
   ST
     { idCount    :: ID 'USER Int
-    , signals    :: Set (SomeSignal 'USER)
+    , signals    :: KnownSignals 'USER
     , simStepRef :: IORef Int
     , simMode    :: IORef Simulator
-    , domIds     :: M.Map String (Set DomainSpecificIDSource)
+    , domIds     :: M.Map String (S.Set DomainSpecificIDSource)
     }
 
 data Testbench =
@@ -68,7 +69,7 @@ instance Show ST where
   show ST{..} =
     "ST {"
     <> show idCount <> ", "
-    <> show (toList signals)
+    <> show (S.toAscList signals)
     <> "}"
 
 -- | The 'TB' monad defines the context in which the test bench gets
@@ -89,15 +90,24 @@ nextFreeID = do
   modify $ \st -> st { idCount = i + 1 }
   return i
 
-registerTBS ::
+mindSignal ::
   (NFDataX a, BitPack a, KnownDomain dom) =>
   TBSignal dom a ->
   TB (TBSignal dom a)
-registerTBS s = do
-  let s' = SomeSignal s
-  modify $ \st@ST{..} ->
-    st { signals = if s' `member` signals then signals else insert s' signals }
-  return s
+mindSignal s = case signalId s of
+  NoID -> do
+    FreeID i <- nextFreeID
+    let s' = s { signalId = SignalID i }
+    modify $ \st@ST{..} -> st { signals = S.insert (SomeSignal s') signals }
+    return s'
+  _ -> do
+    let s' = SomeSignal s
+    modify $ \st@ST{..} ->
+      st { signals = S.insert s' $ case S.lookupIndex s' signals of
+             Nothing -> signals
+             Just i  -> S.deleteAt i signals
+         }
+    return s
 
 type family ArgOf a where
   ArgOf (a -> b) = a
@@ -128,20 +138,16 @@ instance
  where
   (@@) = defTBLift
 
-  liftTB name deps exec s = do
-    FreeID i <- nextFreeID
+  liftTB signalName (reverse -> signalDeps) exec signal = do
     mode <- simMode <$> get
     extVal <- liftIO $ newIORef Nothing
 
     ST{..} <- get
     (signalRef, run) <- liftIO exec
     simStepCache <- liftIO (readIORef simStepRef >>= newIORef)
 
-    registerTBS $ Internal.TBSignal
-      { signal       = s
-      , signalId     = SignalID i
-      , signalDeps   = reverse deps
-      , signalName   = name
+    mindSignal $ Internal.TBSignal
+      { signalId     = NoID
       , signalCurVal = do
           readIORef mode >>= \case
             Internal -> do
@@ -160,9 +166,10 @@ instance
             External -> readIORef extVal >>= \case
               Nothing -> error "No Value"
               Just x  -> return x
-      , signalUpdate = writeIORef extVal . Just
+      , signalUpdate = Just (writeIORef extVal . Just)
       , signalPrint  = Nothing
       , vpiInstance  = Nothing
+      , ..
       }
 
 instance
@@ -231,13 +238,21 @@ runTB mode testbench = do
     ST { signals, simStepRef, simMode } <- get
     tbSignals <- forM (S.toAscList signals) $ \case
       SomeSignal s -> case s of
-        (IOInput {signalId = SignalID x, ..} :: TBSignal dom a) ->
+        (IOInput{..} :: TBSignal dom a) ->
           return $ SomeSignal
-            (IOInput { signalId = SignalID x, .. } :: Internal.TBSignal 'FINAL dom a)
-        Internal.TBSignal {signalId = SignalID x, ..} -> do
+            ( IOInput
+                { signalId = case signalId of
+                    NoID       -> NoID
+                    SignalID x -> SignalID x
+                , ..
+                } :: Internal.TBSignal 'FINAL dom a
+            )
+        Internal.TBSignal{..} -> do
           deps <- mapM fixAutoDomIds signalDeps
           return $ SomeSignal $ Internal.TBSignal
-            { signalId   = SignalID x
+            { signalId   = case signalId of
+                NoID       -> NoID
+                SignalID x -> SignalID x
             , signalDeps = deps
             , ..
             }
@@ -260,6 +275,7 @@ runTB mode testbench = do
 
   fixAutoDomIds :: ID 'USER () -> TB (ID 'FINAL ())
   fixAutoDomIds (SomeID s) = case s of
+    NoID       -> return $ SomeID $ NoID
     SignalID x -> return $ SomeID $ SignalID x
     ClockID x  -> updAutoDom DSClock  (SomeID . ClockID)  x
     ResetID x  -> updAutoDom DSReset  (SomeID . ResetID)  x

clash-testbench/src/Clash/Testbench/Internal/Signal.hs

@@ -37,7 +37,7 @@ data TBSignal (s :: Stage) (dom :: Domain) a =
       , signalName   :: String
       , signal       :: Signal dom a
       , signalCurVal :: IO a
-      , signalUpdate :: a -> IO ()
+      , signalUpdate :: Maybe (a -> IO ())
       , signalPrint  :: Maybe (a -> String)
       , vpiInstance  :: Maybe VPIInstance
       }
@@ -65,7 +65,49 @@ instance AnyStage s => Eq (TBSignal s dom a) where
 instance AnyStage s => Ord (TBSignal s dom a) where
   compare = compare `on` signalId
 
------------
+instance Functor (TBSignal 'USER dom) where
+  fmap f = \case
+    TBSignal{..} ->
+      TBSignal
+        { signalId     = NoID
+        , signal       = fmap f signal
+        , signalCurVal = f <$> signalCurVal
+          -- We cannot update the values of a mapped signal, which
+          -- makes sense, since a mapped signal cannot be simulated
+          -- externally. It is always defined as the result of
+          -- applying 'f' to the given source signal.
+        , signalUpdate = Nothing
+          -- we lose printing abilities at this point. This is fine,
+          -- since printing capabilities are recovered automatically
+          -- once the new signal gets watched.
+        , signalPrint  = Nothing
+        , ..
+        }
+    IOInput{..} ->
+      IOInput
+        { signalId     = NoID
+        , signalCurVal = f <$> signalCurVal
+          -- we lose printing abilities at this point. This is fine,
+          -- since printing capabilities are recovered automatically
+          -- once the new signal gets watched.
+        , signalPrint  = Nothing
+        , ..
+        }
+
+instance Applicative (TBSignal 'USER dom) where
+  pure x =
+    IOInput
+      { signalId     = NoID
+      , signalCurVal = pure x
+      , signalPrint  = Nothing
+      }
+
+  f <*> s =
+    IOInput
+      { signalId     = NoID
+      , signalCurVal = signalCurVal f <*> signalCurVal s
+      , signalPrint  = Nothing
+      }
 
 data TBClock (s :: Stage) (dom :: Domain) =
   TBClock

clash-testbench/src/Clash/Testbench/Output.hs

@@ -11,8 +11,7 @@ module Clash.Testbench.Output
   , watchWith
   ) where
 
-import Control.Monad.State.Lazy (modify)
-import Data.Set (lookupIndex, insert, deleteAt)
+import Control.Monad (void)
 
 import Clash.Prelude (KnownDomain(..), BitPack(..), NFDataX)
 
@@ -33,10 +32,4 @@ watchWith ::
   (KnownDomain dom, BitPack a, NFDataX a) =>
   (a -> String) -> TBSignal dom a -> TB ()
 watchWith toStr tbs =
-  modify $ \st@ST{..} ->
-    st { signals = case lookupIndex tbs' signals of
-           Nothing -> insert tbs' signals
-           Just i  -> insert tbs' $ deleteAt i signals
-       }
- where
-   tbs' = SomeSignal $ tbs { signalPrint = Just toStr }
+  void $ mindSignal tbs { signalPrint = Just toStr }

clash-testbench/src/Clash/Testbench/Simulate.hs

@@ -190,7 +190,7 @@ assignInputs = do
          ClockID  _TODO -> sendV port vpiClock
          ResetID  _TODO -> sendV port $ boolToBit vpiInit
          EnableID _TODO -> sendV port high
-         SignalID _TODO
+         _
            | vpiClock == high -> return ()
            | otherwise        ->
                (`onAllSignalTypes` vpiSignal sid) $ \s ->
@@ -212,8 +212,9 @@ readOutputs = do
       Nothing -> error "Cannot read from module"
       Just VPIInstance{..} ->
         receiveValue VectorFmt (port vpiOutputPort) >>= \case
-          BitVectorVal SNat v ->
-            liftIO $ signalUpdate $ unpack $ resize v
+          BitVectorVal SNat v -> case signalUpdate of
+            Just upd -> liftIO $ upd $ unpack $ resize v
+            Nothing  -> error "No signal update"
           _ -> error "Unexpected return format"
 
   -- print the watched signals