Add more verbose versions of clockTicks

Can be used to supply simulators such as Verilator with accurate timing
information, which it in turn can use to produce accurate VCDs.

.github/workflows/ci.yml

@@ -163,6 +163,11 @@ jobs:
       - name: Extract VexRiscv Integration Tests
         run: |
           tar -x -f vexriscv-test-binaries.tar
-      - name: Run unittests
+
+      - name: Run `clash-vexriscv` unittests
+        run: |
+          cabal run clash-vexriscv:unittests
+
+      - name: Run `clash-vexriscv-sim` unittests
         run: |
           cabal run clash-vexriscv-sim:unittests

clash-vexriscv/clash-vexriscv.cabal

@@ -102,6 +102,7 @@ library
   default-language: Haskell2010
   exposed-modules:
     VexRiscv
+    VexRiscv.ClockTicks
     VexRiscv.FFI
     VexRiscv.TH
   build-depends:
@@ -118,3 +119,24 @@ library
     Glob,
   extra-libraries: VexRiscvFFI, stdc++
   include-dirs: src/
+
+test-suite unittests
+  import: common-options
+  hs-source-dirs: tests/unittests
+  type: exitcode-stdio-1.0
+  main-is: main.hs
+  ghc-options: -Wall -Wcompat -threaded -rtsopts
+  other-modules:
+    Tests.Extra
+    Tests.VexRiscv.ClockTicks
+  build-depends:
+    HUnit,
+    base,
+    clash-vexriscv,
+    bytestring,
+    hedgehog >= 1.0 && < 1.1,
+    tasty >= 1.4 && < 1.5,
+    tasty-hedgehog >= 1.2 && < 1.3,
+    tasty-hunit,
+    tasty-th,
+    template-haskell,

clash-vexriscv/src/VexRiscv/ClockTicks.hs

@@ -0,0 +1,279 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
+-- | Utilities dealing with clock ticks and edges in Clash.
+--
+-- TODO: Figure out whether we want to upstream as is, or whether we want to
+--       generalize to /N/ clocks first.
+module VexRiscv.ClockTicks
+  ( ClockEdgeAB(..)
+  , clockTicksAbsolute
+  , clockTicksRelative
+  , clockEdgesAbsolute
+  , clockEdgesRelative
+  ) where
+
+import Prelude
+
+import Data.Coerce (coerce)
+import Data.Int (Int64)
+import Data.List (mapAccumL)
+import Data.Ord ()
+
+import Clash.Promoted.Nat (snatToNum)
+import Clash.Signal
+  ( ActiveEdge(..), KnownDomain, Clock, SDomainConfiguration(..), knownDomain
+  , SActiveEdge(..), activeEdge
+  )
+import Clash.Signal.Internal (Signal((:-)), ClockAB(..), Femtoseconds(..), Clock(..))
+
+-- | Given two clocks, produce a list of clock ticks indicating which clock
+-- (or both) ticked. Can be used in components handling multiple clocks, such
+-- as @unsafeSynchronizer@ or dual clock FIFOs. In contrast to 'clockTicks',
+-- this version also produces the absolute time at which the tick happened.
+--
+-- If your primitive does not care about coincided clock edges, it should - by
+-- convention - replace it by @ClockB:ClockA:@.
+--
+-- Returned time is in /femtoseconds/.
+clockTicksAbsolute ::
+  (KnownDomain domA, KnownDomain domB) =>
+  Clock domA ->
+  Clock domB ->
+  [(Int64, ClockAB)]
+clockTicksAbsolute clkA clkB =
+  clockTicksEitherAbsolute (toEither clkA) (toEither clkB)
+
+-- | Given two clocks, produce a list of clock ticks indicating which clock
+-- (or both) ticked. Can be used in components handling multiple clocks, such
+-- as @unsafeSynchronizer@ or dual clock FIFOs. In contrast to 'clockTicks',
+-- this version also produces the time since the last tick. Note that the first
+-- "time since last tick" is always zero.
+--
+-- If your primitive does not care about coincided clock edges, it should - by
+-- convention - replace it by @ClockB:ClockA:@.
+--
+-- Returned time is in /femtoseconds/.
+clockTicksRelative ::
+  (KnownDomain domA, KnownDomain domB) =>
+  Clock domA ->
+  Clock domB ->
+  [(Int64, ClockAB)]
+clockTicksRelative clkA clkB =
+  clockTicksEitherRelative (toEither clkA) (toEither clkB)
+
+-- | Given two clocks, produce a list of clock ticks indicating which clock
+-- (or both) ticked. Can be used in components handling multiple clocks, such
+-- as @unsafeSynchronizer@ or dual clock FIFOs.
+--
+-- If your primitive does not care about coincided clock edges, it should - by
+-- convention - replace it by @ClockB:ClockA:@.
+--
+-- Returned time is in /femtoseconds/.
+clockEdgesAbsolute ::
+  forall domA domB .
+  (KnownDomain domA, KnownDomain domB) =>
+  Clock domA ->
+  Clock domB ->
+  [(Int64, ClockEdgeAB)]
+clockEdgesAbsolute clkA clkB =
+  clockEdgesEitherAbsolute
+    (toActiveEdge (activeEdge @domA)) (toActiveEdge (activeEdge @domB))
+    (toEither clkA) (toEither clkB)
+
+-- | Given two clocks, produce a list of clock ticks indicating which clock
+-- (or both) ticked. Can be used in components handling multiple clocks, such
+-- as @unsafeSynchronizer@ or dual clock FIFOs.
+--
+-- If your primitive does not care about coincided clock edges, it should - by
+-- convention - replace it by @ClockB:ClockA:@.
+--
+-- Returned time is in /femtoseconds/.
+clockEdgesRelative ::
+  forall domA domB .
+  (KnownDomain domA, KnownDomain domB) =>
+  Clock domA ->
+  Clock domB ->
+  [(Int64, ClockEdgeAB)]
+clockEdgesRelative clkA clkB =
+  clockEdgesEitherRelative
+    (toActiveEdge (activeEdge @domA)) (toActiveEdge (activeEdge @domB))
+    (toEither clkA) (toEither clkB)
+
+-- | GADT version of 'ActiveEdge' to 'ActiveEdge' conversion
+toActiveEdge :: SActiveEdge edge -> ActiveEdge
+toActiveEdge SRising = Rising
+toActiveEdge SFalling = Falling
+
+toEither ::
+  forall dom.
+  KnownDomain dom =>
+  Clock dom ->
+  Either Int64 (Signal dom Int64)
+toEither (Clock _ maybePeriods)
+  | Just periods <- maybePeriods =
+      Right (unFemtosecondsSignal periods)
+  | SDomainConfiguration{sPeriod} <- knownDomain @dom =
+      -- Convert to femtoseconds - dynamic clocks use them
+      Left (1000 * snatToNum sPeriod)
+ where
+  -- Coerce whole signal instead of `fmap coerce` to prevent useless constructor
+  -- packing and unpacking.
+  unFemtosecondsSignal :: Signal dom Femtoseconds -> Signal dom Int64
+  unFemtosecondsSignal = coerce
+
+-- | Given two clock periods, produce a list of clock ticks indicating which clock
+-- (or both) ticked. Can be used in components handling multiple clocks, such
+-- as @unsafeSynchronizer@ or dual clock FIFOs. In contrast to 'clockTicksEither',
+-- this version also produces the absolute time at which the event happened.
+--
+-- If your primitive does not care about coincided clock edges, it should - by
+-- convention - replace it by @ClockB:ClockA:@.
+clockTicksEitherAbsolute ::
+  Either Int64 (Signal domA Int64) ->
+  Either Int64 (Signal domB Int64) ->
+  [(Int64, ClockAB)]
+clockTicksEitherAbsolute clkA clkB =
+  case (clkA, clkB) of
+    (Left  tA, Left  tB) | tA == tB -> zip (iterate (+tA) 0) (repeat ClockAB)
+    (Left  tA, Left  tB) -> goStatic 0 0 tA tB
+    (Right tA, Right tB) -> goDynamic 0 0 tA tB
+    (Left  tA, Right tB) -> clockTicksEitherAbsolute (Right (pure tA)) (Right tB)
+    (Right tA, Left  tB) -> clockTicksEitherAbsolute (Right tA) (Right (pure tB))
+ where
+  goStatic :: Int64 -> Int64 -> Int64 -> Int64 -> [(Int64, ClockAB)]
+  goStatic absTimeA absTimeB tA tB =
+    case compare absTimeA absTimeB of
+      LT -> (absTimeA, ClockA)  : goStatic (absTimeA + tA) absTimeB        tA tB
+      EQ -> (absTimeA, ClockAB) : goStatic (absTimeA + tA) (absTimeB + tB) tA tB
+      GT -> (absTimeB, ClockB)  : goStatic absTimeA        (absTimeB + tB) tA tB
+
+  goDynamic :: Int64 -> Int64 -> Signal domA Int64 -> Signal domB Int64 -> [(Int64, ClockAB)]
+  goDynamic absTimeA absTimeB tsA@(~(tA :- tsA0)) tsB@(~(tB :- tsB0)) =
+    -- Even though we lazily match on the signal's constructor, this shouldn't
+    -- build up a significant chain of chunks as 'absTimeX' gets evaluated
+    -- every iteration.
+    case compare absTimeA absTimeB of
+      LT -> (absTimeA, ClockA)  : goDynamic (absTimeA + tA) absTimeB        tsA0 tsB
+      EQ -> (absTimeA, ClockAB) : goDynamic (absTimeA + tA) (absTimeB + tB) tsA0 tsB0
+      GT -> (absTimeB, ClockB)  : goDynamic absTimeA        (absTimeB + tB) tsA  tsB0
+
+-- | Given two clock periods, produce a list of clock ticks indicating which clock
+-- (or both) ticked. Can be used in components handling multiple clocks, such
+-- as @unsafeSynchronizer@ or dual clock FIFOs. In contrast to 'clockTicksEither',
+-- this version also produces the time since the last event.
+--
+-- If your primitive does not care about coincided clock edges, it should - by
+-- convention - replace it by @ClockB:ClockA:@.
+clockTicksEitherRelative ::
+  Either Int64 (Signal domA Int64) ->
+  Either Int64 (Signal domB Int64) ->
+  [(Int64, ClockAB)]
+clockTicksEitherRelative clkA clkB = zip relativeTimestamps ticks
+ where
+  relativeTimestamps = 0 : zipWith (-) (tail timestamps) timestamps
+  (timestamps, ticks) = unzip (clockTicksEitherAbsolute clkA clkB)
+
+-- | Flip edge from rising to falling, and vice versa
+oppositeEdge :: ActiveEdge -> ActiveEdge
+oppositeEdge Rising = Falling
+oppositeEdge Falling = Rising
+
+data ClockEdgeAB
+  = ClockEdgeA !ActiveEdge
+  | ClockEdgeB !ActiveEdge
+  | ClockEdgeAB !ActiveEdge !ActiveEdge
+  deriving (Show, Eq)
+
+-- | Given two clock periods, produce a list of clock ticks indicating which clock
+-- (or both) ticked. Can be used in components handling multiple clocks, such
+-- as @unsafeSynchronizer@ or dual clock FIFOs. In contrast to 'clockTicksEither',
+-- this version also produces the absolute time at which the event happened.
+--
+-- If your primitive does not care about coincided clock edges, it should - by
+-- convention - replace it by @ClockB:ClockA:@.
+clockEdgesEitherAbsolute ::
+  ActiveEdge ->
+  -- ^ First active edge for clock A
+  ActiveEdge ->
+  -- ^ First active edge for clock B
+  Either Int64 (Signal domA Int64) ->
+  -- ^ Clock periods for clock A
+  Either Int64 (Signal domB Int64) ->
+  -- ^ Clock periods for clock B
+  [(Int64, ClockEdgeAB)]
+clockEdgesEitherAbsolute firstEdgeA firstEdgeB clkA clkB =
+  case (clkA, clkB) of
+    (Left  tA, Left  tB) | tA == tB -> goSame (halve tA)
+    (Left  tA, Left  tB) -> goStatic  0 0 firstEdgeA firstEdgeB (halve tA) (halve tB)
+    (Right tA, Right tB) -> goDynamic 0 0 firstEdgeA firstEdgeB (halves tA) (halves tB)
+    (Left  tA, Right tB) ->
+      clockEdgesEitherAbsolute firstEdgeA firstEdgeB (Right (pure tA)) (Right tB)
+    (Right tA, Left  tB) ->
+      clockEdgesEitherAbsolute firstEdgeA firstEdgeB (Right tA) (Right (pure tB))
+ where
+  halves = go . fmap halve
+   where
+    go ((t0, t1) :- ts) = t0 :- t1 :- go ts
+
+  halve t =
+    ( t `div` 2
+    , t - (t `div` 2)
+    )
+
+  goSame :: (Int64, Int64) -> [(Int64, ClockEdgeAB)]
+  goSame (t0, t1) =
+    zip
+      (snd $ mapAccumL (\acc t -> (acc + t, acc)) 0 (cycle [t0, t1]))
+      (cycle [ ClockEdgeAB firstEdgeA firstEdgeB
+             , ClockEdgeAB (oppositeEdge firstEdgeA) (oppositeEdge firstEdgeB)
+             ])
+
+  goStatic ::
+    Int64 -> Int64 ->
+    ActiveEdge -> ActiveEdge ->
+    (Int64, Int64) -> (Int64, Int64) ->
+    [(Int64, ClockEdgeAB)]
+  goStatic absTimeA absTimeB !edgeA !edgeB (tA0, tA1) (tB0, tB1) =
+    case compare absTimeA absTimeB of
+      -- XXX: Sorry for breaking the 80/90 limit. I have no idea how to break this
+      --      over multiple lines without sacrificing readability.
+      LT -> (absTimeA, ClockEdgeA edgeA)        : goStatic (absTimeA + tA0) absTimeB         (oppositeEdge edgeA) edgeB                (tA1, tA0) (tB0, tB1)
+      EQ -> (absTimeA, ClockEdgeAB edgeA edgeB) : goStatic (absTimeA + tA0) (absTimeB + tB0) (oppositeEdge edgeA) (oppositeEdge edgeB) (tA1, tA0) (tB1, tB0)
+      GT -> (absTimeB, ClockEdgeB edgeB)        : goStatic absTimeA         (absTimeB + tB0) edgeA                (oppositeEdge edgeB) (tA0, tA1) (tB1, tB0)
+
+  goDynamic ::
+    Int64 -> Int64 ->
+    ActiveEdge -> ActiveEdge ->
+    Signal domA Int64 -> Signal domB Int64 ->
+    [(Int64, ClockEdgeAB)]
+  goDynamic absTimeA absTimeB edgeA edgeB tsA@(~(tA :- tsA0)) tsB@(~(tB :- tsB0)) =
+    -- Even though we lazily match on the signal's constructor, this shouldn't
+    -- build up a significant chain of chunks as 'absTimeX' gets evaluated
+    -- every iteration.
+    case compare absTimeA absTimeB of
+      -- XXX: Sorry for breaking the 80/90 limit. I have no idea how to break this
+      --      over multiple lines without sacrificing readability.
+      LT -> (absTimeA, ClockEdgeA edgeA)        : goDynamic (absTimeA + tA) absTimeB        (oppositeEdge edgeA) edgeB                tsA0 tsB
+      EQ -> (absTimeA, ClockEdgeAB edgeA edgeB) : goDynamic (absTimeA + tA) (absTimeB + tB) (oppositeEdge edgeA) (oppositeEdge edgeB) tsA0 tsB0
+      GT -> (absTimeB, ClockEdgeB edgeB)        : goDynamic absTimeA        (absTimeB + tB) edgeA                (oppositeEdge edgeB) tsA  tsB0
+
+-- | Given two clock periods, produce a list of clock ticks indicating which clock
+-- (or both) ticked. Can be used in components handling multiple clocks, such
+-- as @unsafeSynchronizer@ or dual clock FIFOs. In contrast to 'clockTicksEither',
+-- this version also produces the time since the last event. For the first edge
+-- the time since the last event is set to zero.
+--
+-- If your primitive does not care about coincided clock edges, it should - by
+-- convention - replace it by @ClockB:ClockA:@.
+clockEdgesEitherRelative ::
+  ActiveEdge ->
+  -- ^ First active edge for clock A
+  ActiveEdge ->
+  -- ^ First active edge for clock B
+  Either Int64 (Signal domA Int64) ->
+  Either Int64 (Signal domB Int64) ->
+  [(Int64, ClockEdgeAB)]
+clockEdgesEitherRelative firstEdgeA firstEdgeB clkA clkB = zip relativeTimestamps ticks
+ where
+  relativeTimestamps = 0 : zipWith (-) (tail timestamps) timestamps
+  (timestamps, ticks) = unzip (clockEdgesEitherAbsolute firstEdgeA firstEdgeB clkA clkB)

clash-vexriscv/tests/unittests/Tests/Extra.hs

@@ -0,0 +1,31 @@
+module Tests.Extra where
+
+import Prelude
+
+import Data.Functor ((<&>))
+import Language.Haskell.TH (mkName)
+import Language.Haskell.TH.Lib
+
+-- | Generate a do-expression where each statement is a call to @test@ and the
+-- arguments are determined by the carthesian product of given argument names.
+--
+-- For example:
+--
+-- >   carthesianProductTests ["x", "y"]
+-- > ======>
+-- >   do
+-- >     test x x
+-- >     test x y
+-- >     test y x
+-- >     test y y
+--
+carthesianProductTests :: [String] -> ExpQ
+carthesianProductTests names = doE $
+  cartProd names <&> \(aName, bName) -> noBindS $
+    let
+      aExp = varE (mkName aName)
+      bExp = varE (mkName bName)
+    in
+      [| test $aExp $bExp |]
+ where
+  cartProd xs = [(a, b) | a <- xs, b <- xs]