From e03d309515f46a76e4b0bd498072544fbf1c0365 Mon Sep 17 00:00:00 2001 From: Christiaan Baaij Date: Wed, 26 May 2021 14:40:43 +0200 Subject: [PATCH] Port to Clash 1.4.2 --- Makefile | 4 ++-- arch/src/CFM/Inst.hs | 3 +-- rtl/src/RTL/Beh.hs | 2 +- rtl/src/RTL/BootROM.hs | 2 +- rtl/src/RTL/Core.hs | 8 +++---- rtl/src/RTL/CoreInterface.hs | 5 ++-- rtl/src/RTL/GPIO.hs | 10 ++++---- rtl/src/RTL/IOBus.hs | 6 ++--- rtl/src/RTL/IRQ.hs | 12 ++++++---- rtl/src/RTL/IcestickTop.hs | 30 +++++++++++------------ rtl/src/RTL/IcoTop.hs | 46 ++++++++++++++++++------------------ rtl/src/RTL/MMU.hs | 12 ++++++---- rtl/src/RTL/SRAM.hs | 2 +- rtl/src/RTL/Str.hs | 8 +++---- rtl/src/RTL/TargetTop.hs | 10 ++++---- rtl/src/RTL/Timer.hs | 5 +++- rtl/src/RTL/UART.hs | 21 +++++++++------- rtl/src/RTL/VGA.hs | 8 +++---- rtl/src/RTL/VGA/FrameGen.hs | 20 ++++++++++++---- rtl/src/RTL/VGA/Palette.hs | 4 ++-- rtl/src/RTL/VGA/Timing.hs | 7 +++--- rtl/test/RTL/IOBusSpec.hs | 11 ++++++--- rtl/test/RTL/TestUtil.hs | 2 +- stack.yaml | 22 +---------------- tools/src/Target/Emu.hs | 4 ++-- 25 files changed, 134 insertions(+), 130 deletions(-) diff --git a/Makefile b/Makefile index d331da5..92db906 100644 --- a/Makefile +++ b/Makefile @@ -71,7 +71,7 @@ ICO_BF_SOURCES=\ build/ico_soc_clash.v: $(ICO_RTL_SOURCES) build/stack rtl/clash -irtl/src -iarch/src -outputdir build/clash \ -fclash-inline-limit=50 --verilog rtl/src/RTL/IcoTop.hs - cat build/clash/verilog/RTL/ico_soc/*.v > $@ + cat build/clash/RTL.IcoTop.topEntity/*.v > $@ build/ico.blif: build/ico_soc_clash.v rtl/syn/ico-top.v cd rtl/syn && yosys -q \ @@ -143,7 +143,7 @@ ICE_BF_SOURCES=\ build/icestick_soc_clash.v: $(ICE_RTL_SOURCES) build/stack rtl/clash -irtl/src -iarch/src -outputdir build/clash \ -fclash-inline-limit=50 --verilog rtl/src/RTL/IcestickTop.hs - cat build/clash/verilog/RTL/icestick_soc/*.v > $@ + cat build/clash/RTL.IcestickTop.topEntity/*.v > $@ build/icestick.blif: build/icestick_soc_clash.v rtl/syn/icestick-top.v cd rtl/syn && yosys -q \ diff --git a/arch/src/CFM/Inst.hs b/arch/src/CFM/Inst.hs index 65c220a..5674bb6 100644 --- a/arch/src/CFM/Inst.hs +++ b/arch/src/CFM/Inst.hs @@ -15,7 +15,6 @@ module CFM.Inst ) where import Clash.Prelude -import GHC.Generics import Control.DeepSeq (NFData) import Test.QuickCheck @@ -69,7 +68,7 @@ data TMux = T -- ^ 0: Same value as this cycle. deriving (Eq, Enum, Bounded, Show) data Space = MSpace | ISpace - deriving (Eq, Show, Enum, Bounded, Generic, ShowX, NFData) + deriving (Eq, Show, Enum, Bounded, Generic, ShowX, NFData, NFDataX) instance BitPack Space where type BitSize Space = 1 diff --git a/rtl/src/RTL/Beh.hs b/rtl/src/RTL/Beh.hs index 7145b5b..bb6f2b4 100644 --- a/rtl/src/RTL/Beh.hs +++ b/rtl/src/RTL/Beh.hs @@ -68,7 +68,7 @@ executeNormally = do msRPtr += 1 -- push return stack fetch <&> osROp . _2 .~ 1 - <&> osROp . _3 .~ Just (zeroExtend $ pc' ++# low) + <&> osROp . _3 .~ Just (zeroExtend $ pc' ++# pack low) NotLit (ALU rpc t' tn tr nm space rd dd) -> do n <- view isDData diff --git a/rtl/src/RTL/BootROM.hs b/rtl/src/RTL/BootROM.hs index 834e551..f53ffc1 100644 --- a/rtl/src/RTL/BootROM.hs +++ b/rtl/src/RTL/BootROM.hs @@ -31,7 +31,7 @@ import CFM.Types -- monitors the CPU fetch bus, and on the *second* such jump (the first having -- activated the boot program at reset), the interposer disables itself and -- normal RAM is exposed. -bootROM :: (HasClockReset d g s, KnownNat a) +bootROM :: (HiddenClockResetEnable d, KnownNat a) => SNat n -- ^ Size of the ROM. -> FilePath diff --git a/rtl/src/RTL/Core.hs b/rtl/src/RTL/Core.hs index 61dbb75..e3b4b1a 100644 --- a/rtl/src/RTL/Core.hs +++ b/rtl/src/RTL/Core.hs @@ -13,14 +13,14 @@ import RTL.Str import RTL.CoreInterface -- | Registered version of the core datapath. -core :: HasClockReset dom gated synchronous +core :: HiddenClockResetEnable dom => Signal dom IS -> Signal dom OS core = mealy datapath def -- | Combines 'core' with the selected implementation of stacks, and exposes -- the local bus interface. coreWithStacks - :: (HasClockReset dom gated synchronous) + :: (HiddenClockResetEnable dom) => Signal dom Cell -- ^ read response from memory -> Signal dom Cell -- ^ read response from I/O -> ( Signal dom BusReq @@ -38,7 +38,7 @@ coreWithStacks mresp ioresp = (mreq, ireq, fetch) n = stack "D" $ coreOuts <&> (^. osDOp) r = stack "R" $ coreOuts <&> (^. osROp) -stack :: (HasClockReset d g s) +stack :: (HiddenClockResetEnable d) => String -> Signal d (SP, SDelta, Maybe Cell) -> Signal d Cell stack name op = readNew (blockRamPow2 (repeat $ errorX name)) (op <&> (^. _1) <&> unpack) @@ -50,7 +50,7 @@ stack name op = readNew (blockRamPow2 (repeat $ errorX name)) -- | Combines 'coreWithStacks' with a RAM built from the given constructor, and -- an I/O bridge, exposing the I/O bus. coreWithRAM - :: (HasClockReset dom gated synchronous) + :: (HiddenClockResetEnable dom) => (Signal dom (Maybe (CellAddr, Maybe Cell)) -> Signal dom Cell) -- ^ RAM constructor -> Signal dom Cell -- ^ I/O read response, valid when addressed. diff --git a/rtl/src/RTL/CoreInterface.hs b/rtl/src/RTL/CoreInterface.hs index 6c2476e..fcd6b29 100644 --- a/rtl/src/RTL/CoreInterface.hs +++ b/rtl/src/RTL/CoreInterface.hs @@ -8,7 +8,6 @@ module RTL.CoreInterface where import Clash.Prelude hiding (cycle) -import GHC.Generics import Control.DeepSeq (NFData) import Control.Lens hiding ((:>)) @@ -24,7 +23,7 @@ data BusState = BusFetch | BusData Bool -- ^ The bus was used for something else. The bool flag -- indicates that the bus response should be written to T. - deriving (Eq, Show, Generic, ShowX, NFData) + deriving (Eq, Show, Generic, ShowX, NFData, NFDataX) instance Arbitrary BusState where arbitrary = oneof [ pure BusFetch @@ -46,7 +45,7 @@ data MS = MS , _msT :: Cell , _msBusState :: BusState , _msLastSpace :: Space - } deriving (Show, Generic, ShowX, NFData) + } deriving (Show, Generic, ShowX, NFData, NFDataX) makeLenses ''MS -- At reset, pretend we're in the second phase of a store. We'll ignore the diff --git a/rtl/src/RTL/GPIO.hs b/rtl/src/RTL/GPIO.hs index 975f305..0b84e63 100644 --- a/rtl/src/RTL/GPIO.hs +++ b/rtl/src/RTL/GPIO.hs @@ -1,5 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} @@ -17,7 +19,7 @@ import CFM.Types -- - +4: NAND output pins. 1 bits will clear pins, 0 bits have no effect. -- -- Reading from any address gets the current pin status. -outport :: (HasClockReset d g s) +outport :: (HiddenClockResetEnable d) => Signal d (Maybe (BitVector 2, Maybe Cell)) -> ( Signal d Cell , Signal d Cell @@ -41,7 +43,7 @@ outport = moorep outportT repeat id (pure ()) -- -- It also produces an interrupt on negative edges of bit 0. The interrupt -- condition can be cleared by any write to the port's address space. -inport :: (KnownNat a, HasClockReset d g s) +inport :: (KnownNat a, HiddenClockResetEnable d) => Signal d Cell -> Signal d (Maybe (BitVector a, Maybe Cell)) -> ( Signal d Cell @@ -56,7 +58,7 @@ inport = moorep inportT (repeat . \(InportS x _) -> x) (\(InportS _ x) -> x) Just (_, Just _) -> False -- Otherwise, OR in the negative edge detector. _ -> irq || negedge - negedge = unpack (lsb reg .&. complement (lsb port)) + negedge = bitCoerce (lsb reg .&. complement (lsb port)) -data InportS = InportS Cell Bool deriving (Show) +data InportS = InportS Cell Bool deriving (Show, Generic, NFDataX) instance Default InportS where def = InportS def False diff --git a/rtl/src/RTL/IOBus.hs b/rtl/src/RTL/IOBus.hs index d7939dc..1384e23 100644 --- a/rtl/src/RTL/IOBus.hs +++ b/rtl/src/RTL/IOBus.hs @@ -75,7 +75,7 @@ topBits = fst . split -- Each cycle, the 'ioDecoder' sends its muxing decision as a @BitVector m@ -- (when an I/O device is selected at all. On the next cycle, the 'responseMux' -- selects the corresponding channel out of @2 ^ m@ device response channels. -responseMux :: forall m t d g s. (KnownNat m, HasClockReset d g s) +responseMux :: forall m t d. (KnownNat m, HiddenClockResetEnable d) => Vec (2 ^ m) (Signal d t) -- ^ response from each device -> Signal d (Maybe (BitVector m)) -- ^ decoder output -> Signal d t -- ^ response to core @@ -98,7 +98,7 @@ partialDecode = fmap truncateAddr -- -- The reset state of the machine is given by 'def' for the state type, for -- convenience. -moorep :: (KnownNat a, HasClockReset dom gated synchronous, Default s) +moorep :: (KnownNat a, HiddenClockResetEnable dom, Default s, NFDataX s) => (s -> (Maybe (BitVector a, Maybe Cell), i) -> s) -- ^ State transition function. -> (s -> Vec (2^a) Cell) @@ -129,7 +129,7 @@ moorep ft fr fo = \inp ioreq -> -- -- The reset state of the machine is given by 'def' for the state type, for -- convenience. -mealyp :: (KnownNat a, HasClockReset dom gated synchronous, Default s) +mealyp :: (KnownNat a, HiddenClockResetEnable dom, Default s, NFDataX s) => (s -> (Maybe (BitVector a, Maybe Cell), i) -> (s, o)) -- ^ State transition and outputs function. -> (s -> Vec (2^a) Cell) diff --git a/rtl/src/RTL/IRQ.hs b/rtl/src/RTL/IRQ.hs index 5f50cc8..03484ba 100644 --- a/rtl/src/RTL/IRQ.hs +++ b/rtl/src/RTL/IRQ.hs @@ -1,5 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} @@ -28,7 +30,7 @@ vectorMux vf = mux (fromStrobe <$> vf) (pure $ pack $ NotLit $ Call 1) -- space. They are disabled when an interrupt occurs. Currently, there is no -- way to disable interrupts programatically. singleIrqController - :: (HasClockReset d g s) + :: (HiddenClockResetEnable d) => Signal d Bool -- ^ Interrupt input, active high, level-sensitive. -> Signal d Bool -- ^ CPU fetch signal, active high. -> Signal d (Maybe (BitVector 1, Maybe Cell)) -- ^ I/O bus request. @@ -67,7 +69,7 @@ data SIS = SIS , sisEnter :: Bool -- ^ Interrupt entry event strobe. Goes high on the cycle when a fetch -- is being replaced by a vector. - } deriving (Show) + } deriving (Show, Generic, NFDataX) instance Default SIS where def = SIS False False @@ -96,7 +98,7 @@ instance Default SIS where def = SIS False False -- interrupt. On writes, zero bits are ignored. Reads as the interrupt -- enable mask (the same as IRQSE). multiIrqController - :: (HasClockReset d g s) + :: (HiddenClockResetEnable d) => Vec Width (Signal d Bool) -- ^ Interrupt inputs, active high, level-sensitive. -> Signal d Bool -- ^ CPU fetch signal, active high. @@ -123,7 +125,7 @@ multiIrqController irqS fetchS reqS = (vfaS, vfdS, eiS, respS) -- Any write to the enable-trigger register enables. Just (0, Just _) -> True -- The bottom bit of writes @ 1 gets copied into the enable bit. - Just (1, Just v) -> unpack $ lsb v + Just (1, Just v) -> bitCoerce $ lsb v -- Anything else leaves matters unchanged. _ -> misEn s @@ -154,7 +156,7 @@ data MIS = MIS -- ^ Individual interrupt enable flags. , misEnter :: Bool -- ^ Vector fetch flag. Set during the cycle where we intercede in fetch. - } deriving (Show) + } deriving (Show, Generic, NFDataX) instance Default MIS where def = MIS False (repeat False) (repeat False) False diff --git a/rtl/src/RTL/IcestickTop.hs b/rtl/src/RTL/IcestickTop.hs index 1331462..0f73489 100644 --- a/rtl/src/RTL/IcestickTop.hs +++ b/rtl/src/RTL/IcestickTop.hs @@ -14,7 +14,7 @@ import RTL.GPIO import RTL.Core import RTL.UART -system :: (HasClockReset dom gated synchronous) +system :: (HiddenClockResetEnable dom) => FilePath -> Signal dom Cell -> Signal dom Bit -- UART RX @@ -36,20 +36,20 @@ system raminit ins urx = (outs, utx) partialDecode ioreq3 irqs = irq0 :> urxne :> repeat (pure False) -{-# ANN topEntity (defTop { t_name = "icestick_soc" - , t_inputs = [ PortName "clk_core" - , PortName "reset" - , PortName "inport" - , PortName "uart_rx" - ] - , t_output = PortField "" - [ PortName "out1" - , PortName "uart_tx" - ] - }) #-} -topEntity :: Clock System 'Source - -> Reset System 'Asynchronous +{-# ANN topEntity (Synthesize { t_name = "icestick_soc" + , t_inputs = [ PortName "clk_core" + , PortName "reset" + , PortName "inport" + , PortName "uart_rx" + ] + , t_output = PortProduct "" + [ PortName "out1" + , PortName "uart_tx" + ] + }) #-} +topEntity :: Clock System + -> Reset System -> Signal System Cell -> Signal System Bit -> (Signal System Cell, Signal System Bit) -topEntity c r = withClockReset c r $ system "random-3k5.readmemb" +topEntity c r = withClockResetEnable c r enableGen $ system "rtl/syn/random-3k5.readmemb" diff --git a/rtl/src/RTL/IcoTop.hs b/rtl/src/RTL/IcoTop.hs index f57257b..e05a6a2 100644 --- a/rtl/src/RTL/IcoTop.hs +++ b/rtl/src/RTL/IcoTop.hs @@ -21,8 +21,8 @@ import qualified RTL.UART as U type PhysAddr = BitVector 19 -system :: forall dom gated synchronous. - (HasClockReset dom gated synchronous) +system :: forall dom. + (HiddenClockResetEnable dom) => FilePath -> Signal dom Cell -- input port -> Signal dom Cell -- SRAM-to-host @@ -83,26 +83,26 @@ system raminit ins sram2h urx = (ioresp6, mmuMap) = mmu @3 @7 vecfetchA ei $ partialDecode ioreq6 -{-# ANN topEntity (defTop { t_name = "ico_soc" - , t_inputs = [ PortName "clk_core" - , PortName "reset" - , PortName "inport" - , PortName "sram_to_host" - , PortName "uart_rx" - ] - , t_output = PortField "" - [ PortName "out1" - , PortName "hsync" - , PortName "vsync" - , PortName "vid" - , PortName "sram_a" - , PortName "sram_wr" - , PortName "host_to_sram" - , PortName "uart_tx" - ] - }) #-} -topEntity :: Clock System 'Source - -> Reset System 'Synchronous +{-# ANN topEntity (Synthesize { t_name = "ico_soc" + , t_inputs = [ PortName "clk_core" + , PortName "reset" + , PortName "inport" + , PortName "sram_to_host" + , PortName "uart_rx" + ] + , t_output = PortProduct "" + [ PortName "out1" + , PortName "hsync" + , PortName "vsync" + , PortName "vid" + , PortName "sram_a" + , PortName "sram_wr" + , PortName "host_to_sram" + , PortName "uart_tx" + ] + }) #-} +topEntity :: Clock System + -> Reset System -> Signal System Cell -> Signal System Cell -> Signal System Bit @@ -115,4 +115,4 @@ topEntity :: Clock System 'Source , Signal System Cell -- SRAM data , Signal System Bit ) -topEntity c r = withClockReset c r $ system "rtl/syn/random-256.readmemb" +topEntity c r = withClockResetEnable c r enableGen $ system "rtl/syn/random-256.readmemb" diff --git a/rtl/src/RTL/MMU.hs b/rtl/src/RTL/MMU.hs index f648b0e..d1f2f3f 100644 --- a/rtl/src/RTL/MMU.hs +++ b/rtl/src/RTL/MMU.hs @@ -1,5 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} @@ -52,8 +54,8 @@ import RTL.Strobes -- - +6: Map 1 Access. Reads/writes the part of map 1 selected by Map Pointer. -- - +8: Active Map flag in bit 0 (read/write). -- - +A: Switched due to IRQ flag in bit 0 (read/write). -mmu :: forall v p ev ep d g s. - ( HasClockReset d g s +mmu :: forall v p ev ep d. + ( HiddenClockResetEnable d , KnownNat v , KnownNat p , KnownNat ev @@ -92,12 +94,12 @@ mmu vecfetchS enirqS = mealyp fT fR $ bundle (vecfetchS, enirqS) m1a' | fromStrobe vecfetch = False | fromStrobe enirq && sirq = True | Just (0, Just _) <- req = not m1a - | Just (4, Just x) <- req = unpack $ lsb x + | Just (4, Just x) <- req = bitCoerce $ lsb x | otherwise = m1a sirq' | fromStrobe vecfetch = m1a | fromStrobe enirq && sirq = False - | Just (5, Just x) <- req = unpack $ lsb x + | Just (5, Just x) <- req = bitCoerce $ lsb x | otherwise = sirq activeMap | not m1a || fromStrobe vecfetch = map0 @@ -117,7 +119,7 @@ data S v p = S , sMapPtr :: BitVector v , sMap1Active :: Bool , sSwitchedByIRQ :: Bool - } + } deriving (Generic, NFDataX) instance (KnownNat v, KnownNat p) => Default (S v p) where def = S diff --git a/rtl/src/RTL/SRAM.hs b/rtl/src/RTL/SRAM.hs index c598453..85fadd9 100644 --- a/rtl/src/RTL/SRAM.hs +++ b/rtl/src/RTL/SRAM.hs @@ -23,7 +23,7 @@ import CFM.Types -- period offset within the cycle. -- -- It currently seems easier to do this outside of Clash than within it. -extsram :: (HasClockReset d g s) +extsram :: (HiddenClockResetEnable d, KnownNat a) => Signal d (Maybe (BitVector a, Maybe Cell)) -- ^ Memory request. -> ( Signal d (BitVector a) , Signal d Bool diff --git a/rtl/src/RTL/Str.hs b/rtl/src/RTL/Str.hs index ae1e98a..ef95017 100644 --- a/rtl/src/RTL/Str.hs +++ b/rtl/src/RTL/Str.hs @@ -32,9 +32,9 @@ datapath (MS dptr rptr pc t bs lastSpace) (IS m i n r) = pc1 = pc + 1 -- Magnitude comparison and subtraction are implemented in terms of each -- other. - (lessThan, nMinusT) = split @_ @1 (n `minus` t) + (lessThan, nMinusT) = split @_ @1 (n `sub` t) signedLessThan | msb t /= msb n = msb n - | otherwise = lessThan + | otherwise = unpack lessThan loadResult = case lastSpace of MSpace -> m @@ -48,7 +48,7 @@ datapath (MS dptr rptr pc t bs lastSpace) (IS m i n r) = NotLit (JumpZ _) -> (-1, Nothing) _ -> (0, Nothing) (rptr', rdlt, rop) = stack rptr $ case inst of - NotLit (Call _) -> (1, Just (zeroExtend $ pc1 ++# low)) + NotLit (Call _) -> (1, Just (zeroExtend $ pc1 ++# pack low)) NotLit (ALU _ _ _ tr _ _ d _) -> (d, if tr then Just t else Nothing) _ -> (0, Nothing) -- Register updates other than the ALU @@ -82,7 +82,7 @@ datapath (MS dptr rptr pc t bs lastSpace) (IS m i n r) = -- the subtractor output against zero. However, the subtractor is -- one of the longer paths through the ALU, and testing its -- result adds to that, reducing speed. - NLtT -> signExtend signedLessThan + NLtT -> signExtend (pack signedLessThan) NRshiftT -> n `rightShift` slice d3 d0 t NMinusT -> nMinusT R -> r diff --git a/rtl/src/RTL/TargetTop.hs b/rtl/src/RTL/TargetTop.hs index 7e3539f..fe2fefd 100644 --- a/rtl/src/RTL/TargetTop.hs +++ b/rtl/src/RTL/TargetTop.hs @@ -13,7 +13,7 @@ import CFM.Types import RTL.IOBus import RTL.Core -host :: (HasClockReset d g s) +host :: (HiddenClockResetEnable d) => Signal d (Maybe Cell) -- ^ Host-to-target data -> Signal d Bool -- ^ Host "take" signal clears the T2H buffer -> Signal d (Maybe (BitVector 2, Maybe Cell)) -- ^ ioreq @@ -47,7 +47,7 @@ host h2tS htakeS reqS = mooreB hostT hostO def (h2tS, htakeS, reqS) h2tEmpty = isNothing h2t -target :: (HasClockReset dom gated synchronous, KnownNat n) +target :: (HiddenClockResetEnable dom, KnownNat n) => Vec n Cell -- ^ RAM image -> Signal dom (Maybe Cell) -- ^ Host-to-target channel -> Signal dom Bool -- ^ Host "take" or ready signal @@ -61,14 +61,14 @@ target raminit h2t htake = (t2h, h2tEmpty) targetTop :: (KnownNat n) => Vec n Cell -- ^ RAM image - -> Clock System 'Source - -> Reset System 'Asynchronous + -> Clock System + -> Reset System -> ( Signal System (Maybe Cell) , Signal System Bool ) -> ( Signal System (Maybe Cell) , Signal System Bool ) -targetTop img c r = withClockReset c r $ +targetTop img c r = withClockResetEnable c r enableGen $ uncurry $ target img diff --git a/rtl/src/RTL/Timer.hs b/rtl/src/RTL/Timer.hs index 04ff427..80918cb 100644 --- a/rtl/src/RTL/Timer.hs +++ b/rtl/src/RTL/Timer.hs @@ -1,5 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} @@ -32,7 +34,7 @@ type Ctr = BitVector CtrWidth -- register, the corresponding match bit in the status register will be set. -- -- The match bits in the status register are also exposed as IRQs. -timer :: (HasClockReset d g s) +timer :: (HiddenClockResetEnable d) => Signal d (Maybe (Addr, Maybe Cell)) -> ( Signal d Cell , Vec MatchCount (Signal d Bool) @@ -42,6 +44,7 @@ timer = second unbundle . moorep timerT timerR timerO (pure ()) timerO (TimS _ irqs _) = irqs data TimS = TimS Ctr (Vec MatchCount Bool) (Vec MatchCount Ctr) + deriving (Generic, NFDataX) instance Default TimS where def = TimS 0 (repeat False) (repeat 0) diff --git a/rtl/src/RTL/UART.hs b/rtl/src/RTL/UART.hs index a642edb..73d0ee5 100644 --- a/rtl/src/RTL/UART.hs +++ b/rtl/src/RTL/UART.hs @@ -1,5 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} @@ -19,7 +21,7 @@ import RTL.IOBus -- | A simple UART. -- -- This currently provides one level of transmit queueing. -uart :: (HasClockReset d g s) +uart :: (HiddenClockResetEnable d) => Signal d Bit -> Signal d (Maybe (BitVector 2, Maybe Cell)) -> ( Signal d Cell @@ -38,7 +40,7 @@ uart din ioreq = (ioresp, txready, txidle, rxne, txout) ------------------------------------------------------------------------------ -- Common registers and interface for both the transmitter and receiver. -common :: (HasClockReset d g s) +common :: (HiddenClockResetEnable d) => Signal d Bool -- ^ transmit register empty / ready -> Signal d Bool -- ^ transmitter idle -> Signal d (Maybe (Either FramingError (BitVector 8))) @@ -91,7 +93,7 @@ data CS = CS , csCyclesPerBit :: Cell , csReceived :: Maybe (Either FramingError (BitVector 8)) , csDelayedTake :: Bool - } + } deriving (Generic, NFDataX) instance Default CS where def = CS def def def False @@ -108,7 +110,7 @@ type Transmit d = Signal d (Maybe (BitVector 8)) -- new data -- | Transmitter with a single shift register. A new value cannot be loaded for -- transmission until the transmitter is completely idle (that is, ready == -- idle). -transmit :: (HasClockReset d g s) +transmit :: (HiddenClockResetEnable d) => Signal d (Unsigned 16) -> Transmit d transmit = curry $ mooreB transmitT transmitO def @@ -142,7 +144,7 @@ data TS = TS -- placed on the wire. , tsTimer :: Unsigned 16 -- ^ Core cycles remaining in current bit. - } + } deriving (Generic, NFDataX) instance Default TS where def = TS def (-1) def -- | Adds a single level of transmit holding buffer to a transmitter. This @@ -150,7 +152,7 @@ instance Default TS where def = TS def (-1) def -- initiation of transmission by one core clock cycle. -- -- This can be stacked if desired. -addTxHold :: (HasClockReset d g s) +addTxHold :: (HiddenClockResetEnable d) => Transmit d -> Transmit d addTxHold tx up = ((||) <$> txempty <*> txempty', txidle, out) @@ -168,7 +170,7 @@ addTxHold tx up = ((||) <$> txempty <*> txempty', txidle, out) ------------------------------------------------------------------------------ -- Receiver. -receive :: (HasClockReset d g s) +receive :: (HiddenClockResetEnable d) => Signal d (Unsigned 16) -> Signal d Bit -> Signal d (Maybe (Either FramingError (BitVector 8))) @@ -179,7 +181,7 @@ data RS = RS , rsShift :: BitVector 10 , rsTimer :: Unsigned 16 , rsNew :: Bool - } + } deriving (Generic, NFDataX) instance Default RS where def = RS def def def False receiveT :: RS -> (Unsigned 16, Bit) -> RS @@ -196,11 +198,12 @@ receiveT s0 (cycPerBit, b) = else s _ -> s { rsBitsLeft = rsBitsLeft s - 1 , rsTimer = if rsBitsLeft s == 1 then 0 else cycPerBit - , rsShift = b ++# slice d9 d1 (rsShift s) + , rsShift = pack b ++# slice d9 d1 (rsShift s) , rsNew = rsBitsLeft s == 1 } data FramingError = FramingError + deriving (Generic, NFDataX) receiveO :: RS -> Maybe (Either FramingError (BitVector 8)) receiveO s diff --git a/rtl/src/RTL/VGA.hs b/rtl/src/RTL/VGA.hs index 55bf8b6..6702976 100644 --- a/rtl/src/RTL/VGA.hs +++ b/rtl/src/RTL/VGA.hs @@ -17,7 +17,7 @@ import RTL.VGA.FrameGen chargen - :: (HasClockReset d g s) + :: (HiddenClockResetEnable d) => Signal d (Maybe (BitVector 5, Maybe Cell)) -> ( Signal d Cell -- read response , Signal d Bool -- hsync @@ -70,7 +70,7 @@ chargen ioreq = ( resp (charWr, glyphWr) = unbundle $ ramsplit <$> register def wrth -- Past the character memory we are delayed one cycle. - achar' = blockRamFilePow2 @_ @_ @11 @16 "rtl/syn/random-2k.readmemb" + achar' = blockRamFilePow2 @_ @11 @16 "rtl/syn/random-2k.readmemb" (unpack <$> charAddr) (fmap (second truncateB) <$> charWr) (foreI', backI', char') = ( slice d15 d12 <$> achar' @@ -86,7 +86,7 @@ chargen ioreq = ( resp cursor' = register False cursor -- Past the glyph memory we're delayed another cycle. - gslice'' = blockRamFilePow2 @_ @_ @11 @8 "rtl/syn/font-8x16.readmemb" + gslice'' = blockRamFilePow2 @_ @11 @8 "rtl/syn/font-8x16.readmemb" (unpack <$> charf') (fmap (second truncateB) <$> glyphWr) pxlAddr'' = register def pxlAddr' @@ -103,7 +103,7 @@ chargen ioreq = ( resp gcslice'' = (.|.) <$> gslice'' <*> cursbits'' out'' = mux active'' - (mux (unpack <$> ((!) <$> gcslice'' <*> pxlAddr'')) + (mux (bitCoerce <$> ((!) <$> gcslice'' <*> pxlAddr'')) fore'' back'') (pure 0) diff --git a/rtl/src/RTL/VGA/FrameGen.hs b/rtl/src/RTL/VGA/FrameGen.hs index e3e7e13..c341d70 100644 --- a/rtl/src/RTL/VGA/FrameGen.hs +++ b/rtl/src/RTL/VGA/FrameGen.hs @@ -12,13 +12,11 @@ module RTL.VGA.FrameGen (framegen) where import Clash.Prelude -import GHC.Generics import Data.Maybe (fromMaybe) import Control.Lens hiding ((:>)) import Control.Arrow (second) import Control.DeepSeq import Test.QuickCheck hiding ((.&.)) -import Test.QuickCheck.Arbitrary.Generic (genericArbitrary) import CFM.Types import RTL.VGA.Timing (TimingSigs(..)) @@ -45,7 +43,7 @@ data GState = GState , _gsReadValue :: Cell -- ^ Read value, registered to improve bus timing. } - deriving (Show, Generic, NFData) + deriving (Show, Generic, NFData, NFDataX) makeLenses ''GState @@ -64,12 +62,24 @@ instance Default GState where } instance Arbitrary GState where - arbitrary = genericArbitrary + -- arbitrary = genericArbitrary -- Ugh, missing `Arbitrary Bit` instance + arbitrary = + GState + <$> arbitrary -- _gsPixels + <*> arbitrary -- _gsShadowPixels + <*> arbitrary -- _gsChar0 + <*> arbitrary -- _gsHIF + <*> arbitrary -- _gsVIF + <*> arbitrary -- _gsEVIF + <*> arbitrary -- _gsFB + <*> ((,) <$> (unpack <$> arbitrary) <*> arbitrary) -- _gsAddr + <*> arbitrary -- _gsWriteValue + <*> arbitrary -- _gsReadValue -- | The frame generator coordinates with two timing machines to produce -- control signals for driving the character generator. It is roughly analogous -- to an MC6845. -framegen :: (HasClockReset d g s) +framegen :: (HiddenClockResetEnable d) => Signal d (Maybe (BitVector 3, Maybe Cell)) -> Signal d TimingSigs -> Signal d TimingSigs diff --git a/rtl/src/RTL/VGA/Palette.hs b/rtl/src/RTL/VGA/Palette.hs index 8c41440..af03f49 100644 --- a/rtl/src/RTL/VGA/Palette.hs +++ b/rtl/src/RTL/VGA/Palette.hs @@ -12,8 +12,8 @@ import RTL.IOBus (moorep) -- | The palette maps @2^n@ attribute colors to output colors of @c@ bits each. -- It is a small asynchronous memory with N read ports (e.g. foreground and -- background), and a secondary synchronous port for the CPU. -palette :: forall n c rp cx d g s. - ( HasClockReset d g s +palette :: forall n c rp cx d. + ( HiddenClockResetEnable d , KnownNat n , KnownNat c , KnownNat cx diff --git a/rtl/src/RTL/VGA/Timing.hs b/rtl/src/RTL/VGA/Timing.hs index 5a6811e..65a9fa9 100644 --- a/rtl/src/RTL/VGA/Timing.hs +++ b/rtl/src/RTL/VGA/Timing.hs @@ -12,7 +12,6 @@ module RTL.VGA.Timing ) where import Clash.Prelude -import GHC.Generics import Data.Maybe (fromMaybe) import Control.DeepSeq import Test.QuickCheck hiding ((.&.)) @@ -21,7 +20,7 @@ import CFM.Types -- | Timing machine circuit for one axis (horizontal or vertical) of a raster -- display. -timing :: ( HasClockReset d g s +timing :: ( HiddenClockResetEnable d , KnownNat nx, KnownNat n , (nx + n) ~ Width , (n + nx) ~ Width -- siiiiiigh @@ -61,7 +60,7 @@ data Phase = FrontPorch -- ^ Start of blanking interval. | SyncPulse -- ^ Sync pulse. | BackPorch -- ^ End of blanking interval. | VisibleArea -- ^ Actual pixels. - deriving (Show, Eq, Ord, Enum, Bounded, Generic, NFData) + deriving (Show, Eq, Ord, Enum, Bounded, Generic, NFData, NFDataX) instance Arbitrary Phase where arbitrary = genericArbitrary @@ -101,7 +100,7 @@ data TState n = TState , tsCycLeft :: BitVector n -- ^ Cycles remaining within current phase. } - deriving (Show, Generic, NFData) + deriving (Show, Generic, NFData, NFDataX) instance Default (TState n) where def = TState VisibleArea def instance (KnownNat n) => Arbitrary (TState n) where arbitrary = genericArbitrary diff --git a/rtl/test/RTL/IOBusSpec.hs b/rtl/test/RTL/IOBusSpec.hs index 24d12e7..178509e 100644 --- a/rtl/test/RTL/IOBusSpec.hs +++ b/rtl/test/RTL/IOBusSpec.hs @@ -52,12 +52,17 @@ responseMuxSpec :: forall m. (KnownNat m) => SNat m -> Spec responseMuxSpec mS = context ("responseMux " L.++ show mS) $ do - let special = withClockReset systemClockGen systemResetGen $ + let special = withClockResetEnable systemClockGen systemResetGen enableGen $ responseMux @m @(BitVector m) sim :: [Vec (2^m) (BitVector m)] -> [Maybe (BitVector m)] -> [BitVector m] - sim inputs ch = - let ix = indices (d2 `powSNat` mS) + sim [] [] = [] + sim (i0:inputs') (ch0:ch') = + -- reset is only de-asserted after the first active edge, + -- so duplicate the first sample + let inputs = i0:i0:inputs' + ch = ch0:ch0:ch' + ix = indices (d2 `powSNat` mS) sep = map (\i -> L.map (!! i) inputs) ix inputsS = map fromList sep chS = fromList ch diff --git a/rtl/test/RTL/TestUtil.hs b/rtl/test/RTL/TestUtil.hs index adb527f..971361f 100644 --- a/rtl/test/RTL/TestUtil.hs +++ b/rtl/test/RTL/TestUtil.hs @@ -157,7 +157,7 @@ genspec sf = do u = errorX "must not be used in this test" it "pushes return PC to R as byte address" $ property $ \x (Fetch s) -> - go s x ^. _2 . osROp . _3 == Just (zeroExtend $ (s ^. msPC + 1) ++# low) + go s x ^. _2 . osROp . _3 == Just (zeroExtend $ (s ^. msPC + 1) ++# pack low) it "always jumps" $ property $ \x (Fetch s) -> go s x ^. _1 . msPC == zeroExtend x diff --git a/stack.yaml b/stack.yaml index fd83a49..b6b3545 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,29 +1,9 @@ -resolver: nightly-2017-08-15 +resolver: nightly-2021-05-26 packages: - arch - rtl - tools -- location: - git: https://github.com/clash-lang/clash-compiler.git - commit: 78fd08edec641d1ef6950054fcb0deb399486495 - subdirs: - - clash-lib - - clash-ghc - extra-dep: true -- location: - git: https://github.com/clash-lang/clash-prelude.git - commit: 7fbf635210c184038ee8638cfde84c0ca4a0559a - extra-dep: true - -extra-deps: -- ghc-tcplugins-extra-0.2.1 -- ghc-typelits-extra-0.2.3 -- ghc-typelits-knownnat-0.3 -- ghc-typelits-natnormalise-0.5.3 -- uu-parsinglib-2.9.1.1 -- uu-interleaved-0.2.0.0 -- generic-arbitrary-0.1.0 flags: {} diff --git a/tools/src/Target/Emu.hs b/tools/src/Target/Emu.hs index e0f00eb..f75c6aa 100644 --- a/tools/src/Target/Emu.hs +++ b/tools/src/Target/Emu.hs @@ -79,9 +79,9 @@ step s = S ms' os' mem' ds' rs' cyc' cyc' = s ^. sCyc + 1 newtype EmuT m x = EmuT { runEmuT :: StateT S m x } - deriving (Functor, Applicative, Monad, MonadState S, MonadIO) + deriving (Functor, Applicative, Monad, MonadState S, MonadIO, MonadFail) -instance (Monad m) => MonadTarget (EmuT m) where +instance (Monad m, MonadFail m) => MonadTarget (EmuT m) where tload a = do Just v <- preuse $ sMEM . ix (fromIntegral a) pure $ Right $ fromIntegral v