diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,17 @@ # Changelog for the Clash project + +## 1.6.2 *Fed 25th 2022* +Fixed: + * Clash now compiles for users of Clang - i.e., all macOS users. + * The `trueDualPortBlockRam` model did not accurately simulate concurrent active ports, thus causing a Haskell/HDL simulation mismatch for `asyncFIFOSynchronizer`. + * `trueDualPortBlockRam` Haskell/HDL simulation mismatch for port enable. + * Sometimes `trueDualPortBlockRam` swapped the names of the ports in exception messages. [#2102](https://github.com/clash-lang/clash-compiler/pull/2102) + * The evaluator rule for unpack{Float,Double}# are now corrected to return boxed float and double instead of unboxed literals. [#2097](https://github.com/clash-lang/clash-compiler/issues/2097) + +Changed: + * The `trueDualPortBlockRam` model now only models read/write conflicts for concurrent active ports + * The `trueDualPortBlockRam` model now models write/write conflicts for concurrent active ports + ## 1.6.1 *Feb 11th 2022* Changed: * We accidentally released `v1.6.0` with the Cabal flag `multiple-hidden` enabled. This is an experimental feature, supposed to be disabled by default for releases. `v1.6.1` disables it again. diff --git a/clash-prelude.cabal b/clash-prelude.cabal --- a/clash-prelude.cabal +++ b/clash-prelude.cabal @@ -1,6 +1,6 @@ Cabal-version: 2.2 Name: clash-prelude -Version: 1.6.1 +Version: 1.6.2 Synopsis: Clash: a functional hardware description language - Prelude library Description: Clash is a functional hardware description language that borrows both its diff --git a/src/Clash/Explicit/BlockRam.hs b/src/Clash/Explicit/BlockRam.hs --- a/src/Clash/Explicit/BlockRam.hs +++ b/src/Clash/Explicit/BlockRam.hs @@ -1201,29 +1201,11 @@ data MaybeX a = IsX | IsDefined !a data Conflict = Conflict - { cfWrite :: !(MaybeX Bool) + { cfRWA :: !(MaybeX Bool) -- ^ Read/Write conflict for output A + , cfRWB :: !(MaybeX Bool) -- ^ Read/Write conflict for output B + , cfWW :: !(MaybeX Bool) -- ^ Write/Write conflict , cfAddress :: !(MaybeX Int) } -instance Semigroup Conflict where - (<>) = mergeConflicts - --- | "Stronger" conflict wins: --- --- * Writes over read --- * Undefineds over anything --- -mergeConflicts :: Conflict -> Conflict -> Conflict -mergeConflicts conflict1 conflict2 = Conflict - { cfWrite = mergeWrite (cfWrite conflict1) (cfWrite conflict2) - , cfAddress = mergeAddress (cfAddress conflict1) (cfAddress conflict2) } - where - mergeX _ IsX _ = IsX - mergeX _ _ IsX = IsX - mergeX f (IsDefined a) (IsDefined b) = IsDefined (f a b) - - mergeWrite a b = mergeX (||) a b - mergeAddress a b = mergeX const a b - -- [Note: eta port names for trueDualPortBlockRam] -- -- By naming all the arguments and setting the -fno-do-lambda-eta-expansion GHC @@ -1278,9 +1260,12 @@ -- port enable is @False@, it is /undefined/. trueDualPortBlockRam# clkA enA weA addrA datA clkB enB weB addrB datB | snatToNum @Int (clockPeriod @domA) < snatToNum @Int (clockPeriod @domB) - = swap (trueDualPortBlockRamModel clkB enB weB addrB datB clkA enA weA addrA datA) + = swap (trueDualPortBlockRamModel labelB clkB enB weB addrB datB labelA clkA enA weA addrA datA) | otherwise - = trueDualPortBlockRamModel clkA enA weA addrA datA clkB enB weB addrB datB + = trueDualPortBlockRamModel labelA clkA enA weA addrA datA labelB clkB enB weB addrB datB + where + labelA = "Port A" + labelB = "Port B" {-# NOINLINE trueDualPortBlockRam# #-} {-# ANN trueDualPortBlockRam# hasBlackBox #-} @@ -1298,12 +1283,14 @@ , NFDataX a ) => + String -> Clock domSlow -> Signal domSlow Bool -> Signal domSlow Bool -> Signal domSlow (Index nAddrs) -> Signal domSlow a -> + String -> Clock domFast -> Signal domFast Bool -> Signal domFast Bool -> @@ -1311,21 +1298,26 @@ Signal domFast a -> (Signal domSlow a, Signal domFast a) -trueDualPortBlockRamModel !_clkA enA weA addrA datA !_clkB enB weB addrB datB = - ( deepErrorX "trueDualPortBlockRam: Port A: First value undefined" :- outA - , deepErrorX "trueDualPortBlockRam: Port B: First value undefined" :- outB ) +trueDualPortBlockRamModel labelA !_clkA enA weA addrA datA labelB !_clkB enB weB addrB datB = + ( startA :- outA + , startB :- outB ) where (outA, outB) = go - Nothing (Seq.fromFunction (natToNum @nAddrs) initElement) - tA -- ensure 'go' hits fast clock first + tB -- ensure 'go' hits fast clock first for 1 cycle, then execute slow + -- clock for 1 cycle, followed by the regular cadence of 'ceil(tA / tB)' + -- cycles for the fast clock followed by 1 cycle of the slow clock (bundle (enA, weA, fromIntegral <$> addrA, datA)) (bundle (enB, weB, fromIntegral <$> addrB, datB)) + startA startB tA = snatToNum @Int (clockPeriod @domSlow) tB = snatToNum @Int (clockPeriod @domFast) + startA = deepErrorX $ "trueDualPortBlockRam: " <> labelA <> ": First value undefined" + startB = deepErrorX $ "trueDualPortBlockRam: " <> labelB <> ": First value undefined" + initElement :: Int -> a initElement n = deepErrorX ("Unknown initial element; position " <> show n) @@ -1341,24 +1333,25 @@ deepErrorX ("Write enabled, but address unknown; position " <> show n <> "\nAddress error message: " <> msg) - getConflict :: Bool -> Int -> Bool -> Int -> Maybe Conflict - getConflict enableA addrA_ enableB addrB_ = + getConflict :: Bool -> Bool -> Bool -> Int -> Bool -> Int -> Maybe Conflict + getConflict enA_ enB_ wenA addrA_ wenB addrB_ = -- If port A or port B is writing on (potentially!) the same address, -- there's a conflict - if sameAddr then maybeConflict else Nothing + if sameAddr then Just conflict else Nothing where + wenAX = toMaybeX wenA + wenBX = toMaybeX wenB + + mergeX IsX b = b + mergeX a IsX = a + mergeX (IsDefined a) (IsDefined b) = IsDefined (a && b) + conflict = Conflict - { cfWrite = toMaybeX enableA + { cfRWA = if enB_ then wenBX else IsDefined False + , cfRWB = if enA_ then wenAX else IsDefined False + , cfWW = if enA_ && enB_ then mergeX wenAX wenBX else IsDefined False , cfAddress = toMaybeX addrA_ } - maybeConflict = - case (isX enableA, isX enableB) of - (Left _, _) -> Just conflict - (Right True, _) -> Just conflict - (_, Left _) -> Just conflict - (_, Right True) -> Just conflict - _ -> Nothing - sameAddr = case (isX addrA_, isX addrB_) of (Left _, _) -> True @@ -1392,47 +1385,74 @@ addrUndefined = isX addr go :: - Maybe Conflict -> Seq a -> Int -> Signal domSlow (Bool, Bool, Int, a) -> Signal domFast (Bool, Bool, Int, a) -> + a -> a -> (Signal domSlow a, Signal domFast a) - go conflict0 ram0 relativeTime as0 bs0 = - if relativeTime <= 0 then goSlow else goFast + go ram0 relativeTime as0 bs0 = + case compare relativeTime 0 of + LT -> goSlow + EQ -> goBoth + GT -> goFast where (enA_, weA_, addrA_, datA_) :- as1 = as0 (enB_, weB_, addrB_, datB_) :- bs1 = bs0 + goBoth prevA prevB = outA2 `seqX` outB2 `seqX` (outA2 :- as2, outB2 :- bs2) + where + conflict = getConflict enA_ enB_ weA_ addrA_ weB_ addrB_ + + (datA1_,datB1_) = case conflict of + Just Conflict{cfWW=IsDefined True} -> + ( deepErrorX "trueDualPortBlockRam: conflicting write/write queries" + , deepErrorX "trueDualPortBlockRam: conflicting write/write queries" ) + Just Conflict{cfWW=IsX} -> + ( deepErrorX "trueDualPortBlockRam: conflicting write/write queries" + , deepErrorX "trueDualPortBlockRam: conflicting write/write queries" ) + _ -> (datA_,datB_) + + (wroteA,ram1) = writeRam weA_ addrA_ datA1_ ram0 + (wroteB,ram2) = writeRam weB_ addrB_ datB1_ ram1 + + outA1 = case conflict of + Just Conflict{cfRWA=IsDefined True} -> + deepErrorX "trueDualPortBlockRam: conflicting read/write queries" + Just Conflict{cfRWA=IsX} -> + deepErrorX "trueDualPortBlockRam: conflicting read/write queries" + _ -> fromMaybe (ram0 `Seq.index` addrA_) wroteA + + outB1 = case conflict of + Just Conflict{cfRWB=IsDefined True} -> + deepErrorX "trueDualPortBlockRam: conflicting read/write queries" + Just Conflict{cfRWB=IsX} -> + deepErrorX "trueDualPortBlockRam: conflicting read/write queries" + _ -> fromMaybe (ram0 `Seq.index` addrB_) wroteB + + outA2 = if enA_ then outA1 else prevA + outB2 = if enB_ then outB1 else prevB + (as2,bs2) = go ram2 (relativeTime - tB + tA) as1 bs1 outA2 outB2 + -- 1 iteration here, as this is the slow clock. - goSlow = out1 `seqX` (out1 :- as2, bs2) + goSlow _ prevB | enA_ = out0 `seqX` (out0 :- as2, bs2) where (wrote, !ram1) = writeRam weA_ addrA_ datA_ ram0 out0 = fromMaybe (ram1 `Seq.index` addrA_) wrote - (as2, bs2) = go Nothing ram1 (relativeTime + tA) as1 bs0 - out1 = - case conflict0 of - Just Conflict{cfWrite=IsDefined True} -> - deepErrorX "trueDualPortBlockRam: conflicting read/write queries" - Just Conflict{cfWrite=IsX} -> - deepErrorX "trueDualPortBlockRam: conflicting read/write queries" - _ -> out0 + (as2, bs2) = go ram1 (relativeTime + tA) as1 bs0 out0 prevB + goSlow prevA prevB = (prevA :- as2, bs2) + where + (as2,bs2) = go ram0 (relativeTime + tA) as1 bs0 prevA prevB + -- 1 or more iterations here, as this is the fast clock. First iteration -- happens here. - goFast = out1 `seqX` (as2, out1 :- bs2) + goFast prevA _ | enB_ = out0 `seqX` (as2, out0 :- bs2) where - conflict1 | enA_ && enB_ = getConflict weB_ addrB_ weA_ addrA_ - | otherwise = Nothing (wrote, !ram1) = writeRam weB_ addrB_ datB_ ram0 out0 = fromMaybe (ram1 `Seq.index` addrB_) wrote - conflict2 = conflict0 <> conflict1 - (as2, bs2) = go conflict2 ram1 (relativeTime - tB) as0 bs1 - out1 = - case conflict1 of - Just Conflict{cfWrite=IsDefined False} -> - deepErrorX "trueDualPortBlockRam: conflicting read/write queries" - Just Conflict{cfWrite=IsX} -> - deepErrorX "trueDualPortBlockRam: conflicting read/write queries" - _ -> - out0 + (as2, bs2) = go ram1 (relativeTime - tB) as0 bs1 prevA out0 + + goFast prevA prevB = (as2, prevB :- bs2) + where + (as2,bs2) = go ram0 (relativeTime - tB) as0 bs1 prevA prevB diff --git a/tests/Clash/Tests/AsyncFIFOSynchronizer.hs b/tests/Clash/Tests/AsyncFIFOSynchronizer.hs --- a/tests/Clash/Tests/AsyncFIFOSynchronizer.hs +++ b/tests/Clash/Tests/AsyncFIFOSynchronizer.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -5,9 +7,14 @@ module Clash.Tests.AsyncFIFOSynchronizer (tests) where +import Data.Maybe (isJust, catMaybes) import qualified Prelude as P +import Hedgehog as H +import qualified Hedgehog.Range as Range +import qualified Hedgehog.Gen as Gen import Test.Tasty +import Test.Tasty.Hedgehog import Test.Tasty.HUnit import Clash.Explicit.Prelude @@ -963,6 +970,155 @@ , (Nothing,False) ] +createDomain vSystem{vName="A", vPeriod=hzToPeriod 20e6} -- fast +createDomain vSystem{vName="B", vPeriod=hzToPeriod 10e6} -- slow +createDomain vSystem{vName="C", vPeriod=hzToPeriod 7e6} -- slower + +data DomProxy (dom :: Domain) where + DomProxy + :: KnownDomain dom + => DomProxy dom + +-- A more useful Show instance than the one for 'Proxy' +instance Show (DomProxy dom) where + showsPrec d dom@DomProxy = + showParen (d > app_prec) $ ("DomProxy @" <>) . (symbolVal dom <>) + where app_prec = 10 + +data NamedTest a = NamedTest + { namedTest :: a + , testName :: String + } + +instance Show (NamedTest a) where + show nt = testName nt + +testNameShowsPrec + :: Int + -> ShowS + -> DomProxy dom1 + -> DomProxy dom2 + -> ShowS +testNameShowsPrec d baseName dom1 dom2 = + showParen (d > app_prec) $ baseName . (' ':) . showsPrec 11 dom1 . + (' ':) . showsPrec 11 dom2 + where app_prec = 10 + +forAllNamedTestProperties + :: [NamedTest (PropertyT IO ())] + -> Property + +forAllNamedTestProperties nts = property $ do + t <- fmap namedTest . forAllWith show . Gen.resize 99 $ Gen.element nts + t + +data WriteAction = + Write + | WNoOp + | WGated + | GatedWrite + deriving (Eq, Enum, Bounded, Show, Generic, NFDataX) + +data ReadAction = + Read + | RNoOp + | RGated + | GatedRead + deriving (Eq, Enum, Bounded, Show, Generic, NFDataX) + +fifoOperations + :: forall wdom rdom + . (KnownDomain wdom, KnownDomain rdom) + => [ReadAction] + -> [WriteAction] + -> ( Signal rdom ( Bool + -- Test fully done + , Maybe Int + -- Element read from FIFO + ) + , Signal wdom ( Bool + -- Test fully done + , Maybe Int + -- Element written to FIFO + ) + ) +fifoOperations racts wacts = (bundle (rAllDone, rel), bundle (wAllDone, wel)) + where + (rdata, rempty, wfull) = + asyncFIFOSynchronizer d3 wclk rclk noWRst noRRst (toEnable wen) + (toEnable ren) rinc wDataM + rclk = clockGen @rdom + wclk = clockGen @wdom + -- Not resetting makes the test easier to interpret and actual proper testing + -- of reset behaviour is a lot more involved. + noRRst = unsafeFromHighPolarity @rdom (pure False) + noWRst = unsafeFromHighPolarity @wdom (pure False) + (wdone, wact) = + unbundle $ fromList $ P.zip (P.repeat False) wacts <> P.repeat (True, WNoOp) + (rdone, ract) = + unbundle $ fromList $ P.zip (P.repeat False) racts <> P.repeat (True, RNoOp) + (wen, wDataM) = unbundle $ + liftA2 (\wact0 d -> case wact0 of + Write -> (True , Just d ) + WNoOp -> (True , Nothing) + WGated -> (False, Nothing) + GatedWrite -> (False, Just d ) + ) wact wdata + wdata = regEn wclk noWRst enableGen 1 (isJust <$> wDataM) (wdata + 1) + (ren, rinc) = unbundle $ + fmap (\ract0 -> case ract0 of + Read -> (True , True ) + RNoOp -> (True , False) + RGated -> (False, False) + GatedRead -> (False, True) + ) ract1 + mainDone = rdone .&&. unsafeSynchronizer wclk rclk wdone + -- Empty FIFO after main test + ract1 = mux mainDone (pure Read) ract + flushCnt = regEn rclk noRRst enableGen (1 :: Int) mainDone (flushCnt + 1) + -- Surely in 20 cycles we have seen all of the FIFO even if something has gone + -- wrong with the pointers + rAllDone = fmap (> 20) flushCnt + wAllDone = unsafeSynchronizer rclk wclk rAllDone + rel = mux (liftA3 (\en inc em -> en && inc && not em) ren rinc rempty) + (Just <$> rdata) (pure Nothing) + wel = mux (liftA3 (\en wdm fu -> en && isJust wdm && not fu) wen wDataM wfull) + (Just <$> wdata) (pure Nothing) + +fifoFunctionalTest + :: forall wdom rdom m + . Monad m + => DomProxy wdom + -> DomProxy rdom + -> NamedTest (PropertyT m ()) +fifoFunctionalTest wdom@DomProxy rdom@DomProxy = + NamedTest { namedTest=test0, testName = name } + where + name = testNameShowsPrec 0 (shows 'fifoFunctionalTest) wdom rdom "" + genInput :: (Bounded e, Enum e, Show e) => PropertyT m [e] + genInput = fmap P.concat . forAll . Gen.list (Range.linear 1 10) . + Gen.list (Range.linear 0 20) $ Gen.enumBounded + test0 = do + racts <- genInput + wacts <- genInput + let + results = fifoOperations @wdom @rdom racts wacts + catValids = catMaybes . P.map snd . P.takeWhile (not . fst) + rels = catValids . sample $ fst results + wels = catValids . sample $ snd results + rels === wels + +fifoFunctionalTestCombinations :: Monad m => [NamedTest (PropertyT m ())] +fifoFunctionalTestCombinations = + [ fifoFunctionalTest (DomProxy @A) (DomProxy @A) + , fifoFunctionalTest (DomProxy @A) (DomProxy @B) + , fifoFunctionalTest (DomProxy @A) (DomProxy @C) + , fifoFunctionalTest (DomProxy @B) (DomProxy @A) + , fifoFunctionalTest (DomProxy @B) (DomProxy @C) + , fifoFunctionalTest (DomProxy @C) (DomProxy @A) + , fifoFunctionalTest (DomProxy @C) (DomProxy @B) + ] + tests :: TestTree tests = testGroup "asyncFIFOSynchronizer" [ testCase "Test 1.1 Read" test1R1 @@ -993,4 +1149,5 @@ , testCase "Test 5.7 Write" test5W7 , testCase "Test 6.7 Read" test6R7 , testCase "Test 6.7 Write" test6W7 + , testProperty "Functional test" $ forAllNamedTestProperties fifoFunctionalTestCombinations ]