From 7cc11c6f8cad8d5eff6e4da9a4b4573f6ae4b7a8 Mon Sep 17 00:00:00 2001 From: M Farkas-Dyck Date: Fri, 30 Apr 2021 11:18:14 -0800 Subject: [PATCH 1/3] Generalize XLEN. It's not RV64I yet, for it has no `*w` instructions (`addw` and such). --- lion-formal/src/LionFV.hs | 18 +-- lion-metric/src/Metric.hs | 10 +- lion-soc/src/Bus.hs | 12 +- lion.cabal | 1 + src/Lion/Alu.hs | 41 +++--- src/Lion/Core.hs | 30 ++--- src/Lion/Instruction.hs | 80 +++++++----- src/Lion/Pipe.hs | 255 ++++++++++++++++++++------------------ src/Lion/Rvfi.hs | 32 ++--- src/Lion/Util/Clash.hs | 16 +++ 10 files changed, 272 insertions(+), 223 deletions(-) create mode 100644 src/Lion/Util/Clash.hs diff --git a/lion-formal/src/LionFV.hs b/lion-formal/src/LionFV.hs index fbd2790..587682f 100644 --- a/lion-formal/src/LionFV.hs +++ b/lion-formal/src/LionFV.hs @@ -6,6 +6,9 @@ License : BSD-3-Clause Maintainer : standardsemiconductor@gmail.com -} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} + module LionFV where import Clash.Prelude @@ -17,13 +20,14 @@ import Lion.Rvfi ( Rvfi ) lionFV :: HiddenClockResetEnable dom - => Signal dom (BitVector 32) -- ^ mem_rdata + => (KnownNat xl, KnownNat (Log2 xl), 1 <= Div xl 8) + => Signal dom (BitVector xl) -- ^ mem_rdata -> ( Signal dom Bool -- mem_valid , Signal dom Bool -- mem_instr - , Signal dom (BitVector 32) -- mem_addr - , Signal dom (BitVector 32) -- mem_wdata - , Signal dom (BitVector 4) -- mem_wstrb - , Signal dom Rvfi -- rvfi + , Signal dom (BitVector xl) -- mem_addr + , Signal dom (BitVector xl) -- mem_wdata + , Signal dom (BitVector (Div xl 8)) -- mem_wstrb + , Signal dom (Rvfi xl) -- rvfi ) lionFV memRData = ( memValid @@ -41,7 +45,7 @@ lionFV memRData = memWData = fromMaybe 0 . (memWrite =<<) <$> toMem fromCore memWStrb = maybe 0 memByteMask <$> toMem fromCore -isInstr :: ToMem -> Bool +isInstr :: ToMem xl -> Bool isInstr = (== InstrMem) . memAccess {-# NOINLINE topEntity #-} @@ -54,7 +58,7 @@ topEntity , "mem_addr" ::: Signal System (BitVector 32) , "mem_wdata" ::: Signal System (BitVector 32) , "mem_wstrb" ::: Signal System (BitVector 4) - , "rvfi" ::: Signal System Rvfi + , "rvfi" ::: Signal System (Rvfi 32) ) topEntity clk rst = exposeClockResetEnable lionFV clk rst enableGen makeTopEntityWithName 'topEntity "LionFV" \ No newline at end of file diff --git a/lion-metric/src/Metric.hs b/lion-metric/src/Metric.hs index e643faa..16f0a27 100644 --- a/lion-metric/src/Metric.hs +++ b/lion-metric/src/Metric.hs @@ -8,6 +8,9 @@ Maintainer : standardsemiconductor@gmail.com Core top entity to observe yosys metrics when synthesized for iCE40 -} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} + module Metric where import Clash.Prelude @@ -16,8 +19,9 @@ import Lion.Core metric :: HiddenClockResetEnable dom - => Signal dom (BitVector 32) - -> Signal dom (Maybe ToMem) + => (KnownNat xl, KnownNat (Log2 xl), 1 <= Div xl 8) + => Signal dom (BitVector xl) + -> Signal dom (Maybe (ToMem xl)) metric = toMem . core defaultCoreConfig {-# NOINLINE topEntity #-} @@ -25,6 +29,6 @@ topEntity :: "clk" ::: Clock System -> "rst" ::: Reset System -> "fromMem" ::: Signal System (BitVector 32) - -> "toMem" ::: Signal System (Maybe ToMem) + -> "toMem" ::: Signal System (Maybe (ToMem 32)) topEntity clk rst = withClockResetEnable clk rst enableGen metric makeTopEntityWithName 'topEntity "Metric" diff --git a/lion-soc/src/Bus.hs b/lion-soc/src/Bus.hs index 6da71e3..c8c8109 100644 --- a/lion-soc/src/Bus.hs +++ b/lion-soc/src/Bus.hs @@ -50,21 +50,21 @@ data BusOut (p :: Peripheral) where FromSpram :: BitVector 32 -> BusOut 'Spram FromSpi :: BitVector 32 -> BusOut 'Spi -romMap :: Maybe ToMem -> BusIn 'Rom +romMap :: Maybe (ToMem 32) -> BusIn 'Rom romMap = ToRom . wordAddr . maybe 0 memAddress where wordAddr :: BitVector 32 -> Unsigned 8 wordAddr a = unpack $ slice d7 d0 $ a `shiftR` 2 -uartMap :: Peripheral -> Maybe ToMem -> BusIn 'Uart +uartMap :: Peripheral -> Maybe (ToMem 32) -> BusIn 'Uart uartMap Uart (Just (ToMem DataMem _ msk wrM)) = ToUart (slice d2 d0 msk) $ slice d7 d0 <$> wrM uartMap _ _ = ToUart 0 Nothing -ledMap :: Peripheral -> Maybe ToMem -> BusIn 'Led +ledMap :: Peripheral -> Maybe (ToMem 32) -> BusIn 'Led ledMap Led (Just (ToMem _ _ $(bitPattern "..11") (Just d))) = ToLed (slice d11 d8 d) (slice d7 d0 d) True ledMap _ _ = ToLed 0 0 False -spramMap :: Peripheral -> Maybe ToMem -> BusIn 'Spram +spramMap :: Peripheral -> Maybe (ToMem 32) -> BusIn 'Spram spramMap _ Nothing = ToSpram 0 0 0 0 spramMap periph (Just mem) = case (periph, memWrite mem) of (Spram, Just wr) -> ToSpram wordAddr wr nybMask 1 @@ -78,11 +78,11 @@ spramMap periph (Just mem) = case (periph, memWrite mem) of | b == high = 0b11 | otherwise = 0b00 -spiMap :: Peripheral -> Maybe ToMem -> BusIn 'Spi +spiMap :: Peripheral -> Maybe (ToMem 32) -> BusIn 'Spi spiMap Spi (Just (ToMem DataMem _ mask wrM)) = ToSpi mask wrM spiMap _ _ = ToSpi 0 Nothing -selectPeripheral :: Maybe ToMem -> Peripheral +selectPeripheral :: Maybe (ToMem 32) -> Peripheral selectPeripheral Nothing = Rom selectPeripheral (Just toMem) | checkRegion 17 = Spram diff --git a/lion.cabal b/lion.cabal index bb7a880..7441c00 100644 --- a/lion.cabal +++ b/lion.cabal @@ -24,6 +24,7 @@ library other-modules: Lion.Alu , Lion.Instruction , Lion.Pipe + , Lion.Util.Clash hs-source-dirs: src default-language: Haskell2010 build-depends: diff --git a/src/Lion/Alu.hs b/src/Lion/Alu.hs index 7939b84..c8046ce 100644 --- a/src/Lion/Alu.hs +++ b/src/Lion/Alu.hs @@ -11,44 +11,46 @@ Configurable alu, choose between soft and hard adders/subtractors module Lion.Alu where import Clash.Prelude +import Data.Bool ( bool ) import Data.Function ( on ) import Data.Proxy import Ice40.Mac import Lion.Instruction +import Lion.Util.Clash -- | ALU configuration data AluConfig = Hard -- ^ use hard adder and subtractor from iCE40 SB_MAC16 | Soft -- ^ use generic adder and subtractor: (+) and (-) deriving stock (Generic, Show, Eq) -class Alu (config :: AluConfig) where - alu :: HiddenClockResetEnable dom +class Alu (xl :: Nat) (config :: AluConfig) where + alu :: (KnownNat xl, KnownNat (Log2 xl)) + => HiddenClockResetEnable dom => Proxy (config :: AluConfig) -> Signal dom Op - -> Signal dom (BitVector 32) - -> Signal dom (BitVector 32) - -> Signal dom (BitVector 32) + -> Signal dom (BitVector xl) + -> Signal dom (BitVector xl) + -> Signal dom (BitVector xl) -instance Alu 'Soft where +instance Alu xl 'Soft where alu _ op in1 = register 0 . liftA3 aluFunc op in1 where aluFunc = \case Add -> (+) Sub -> (-) Sll -> \x y -> x `shiftL` shamt y - Slt -> boolToBV ... (<) `on` sign - Sltu -> boolToBV ... (<) + Slt -> bool 0 1 ... (<) `on` sign + Sltu -> bool 0 1 ... (<) Xor -> xor Srl -> \x y -> x `shiftR` shamt y Sra -> \x y -> pack $ sign x `shiftR` shamt y Or -> (.|.) And -> (.&.) where - shamt = unpack . resize . slice d4 d0 - sign = unpack :: BitVector 32 -> Signed 32 + shamt = fromEnum . resizeTo (SNat :: SNat (Log2 xl)) (...) = (.).(.) -instance Alu 'Hard where +instance Alu 32 'Hard where alu _ op in1 in2 = mux isAddSub adderSubtractor $ register 0 $ baseAlu op in1 in2 where isAdd = (Add == ) <$> op @@ -57,24 +59,25 @@ instance Alu 'Hard where adderSubtractor = hardAddSub (boolToBit <$> isSub) in1 in2 baseAlu - :: Signal dom Op - -> Signal dom (BitVector 32) - -> Signal dom (BitVector 32) - -> Signal dom (BitVector 32) + :: forall dom xl + . (KnownNat xl, KnownNat (Log2 xl)) + => Signal dom Op + -> Signal dom (BitVector xl) + -> Signal dom (BitVector xl) + -> Signal dom (BitVector xl) baseAlu = liftA3 $ \case Add -> \_ _ -> 0 Sub -> \_ _ -> 0 Sll -> \x y -> x `shiftL` shamt y - Slt -> boolToBV ... (<) `on` sign - Sltu -> boolToBV ... (<) + Slt -> bool 0 1 ... (<) `on` sign + Sltu -> bool 0 1 ... (<) Xor -> xor Srl -> \x y -> x `shiftR` shamt y Sra -> \x y -> pack $ sign x `shiftR` shamt y Or -> (.|.) And -> (.&.) where - shamt = unpack . resize . slice d4 d0 - sign = unpack :: BitVector 32 -> Signed 32 + shamt = fromEnum . resizeTo (SNat :: SNat (Log2 xl)) (...) = (.).(.) -- | addSub32PipelinedUnsigned diff --git a/src/Lion/Core.hs b/src/Lion/Core.hs index 4c8aa9e..0faf786 100644 --- a/src/Lion/Core.hs +++ b/src/Lion/Core.hs @@ -5,7 +5,7 @@ Copyright : (c) David Cox, 2021 License : BSD-3-Clause Maintainer : standardsemiconductor@gmail.com -The Lion core is a 32-bit [RISC-V](https://riscv.org/about/) processor written in Haskell using [Clash](https://clash-lang.org). Note, all peripherals and memory must have single cycle latency. See [lion-soc](https://github.com/standardsemiconductor/lion/tree/main/lion-soc) for an example of using the Lion core in a system. +The Lion core is a xl-bit [RISC-V](https://riscv.org/about/) processor written in Haskell using [Clash](https://clash-lang.org). Note, all peripherals and memory must have single cycle latency. See [lion-soc](https://github.com/standardsemiconductor/lion/tree/main/lion-soc) for an example of using the Lion core in a system. -} module Lion.Core @@ -49,20 +49,21 @@ defaultCoreConfig = CoreConfig } -- | Core outputs -data FromCore dom = FromCore - { toMem :: Signal dom (Maybe P.ToMem) -- ^ shared memory and instruction bus, output from core to memory and peripherals - , toRvfi :: Signal dom Rvfi -- ^ formal verification interface output, see [lion-formal](https://github.com/standardsemiconductor/lion/tree/main/lion-formal) for usage +data FromCore dom xl = FromCore + { toMem :: Signal dom (Maybe (P.ToMem xl)) -- ^ shared memory and instruction bus, output from core to memory and peripherals + , toRvfi :: Signal dom (Rvfi xl) -- ^ formal verification interface output, see [lion-formal](https://github.com/standardsemiconductor/lion/tree/main/lion-formal) for usage } --- | RISC-V Core: RV32I +-- | RISC-V Core: RV(32, 64)I core - :: forall a startPC dom - . HiddenClockResetEnable dom - => Alu a - => (KnownNat startPC, startPC <= 0xFFFFFFFF) + :: forall a startPC dom xl + . (KnownNat xl, KnownNat (Log2 xl), 1 <= Div xl 8) + => HiddenClockResetEnable dom + => Alu xl a + => (KnownNat startPC, startPC + 1 <= 2^xl) => CoreConfig (startPC :: Nat) (a :: AluConfig) -- ^ core configuration - -> Signal dom (BitVector 32) -- ^ core input, from memory/peripherals - -> FromCore dom -- ^ core output + -> Signal dom (BitVector xl) -- ^ core input, from memory/peripherals + -> FromCore dom xl -- ^ core output core config toCore = FromCore { toMem = getFirst . P._toMem <$> fromPipe , toRvfi = fromMaybe mkRvfi . getFirst . P._toRvfi <$> fromPipe @@ -87,11 +88,12 @@ core config toCore = FromCore -- | Register bank regBank - :: HiddenClockResetEnable dom + :: KnownNat xl + => HiddenClockResetEnable dom => Signal dom (Unsigned 5) -- ^ Rs1 Addr -> Signal dom (Unsigned 5) -- ^ Rs2 Addr - -> Signal dom (Maybe (Unsigned 5, BitVector 32)) -- ^ Rd Write - -> Unbundled dom (BitVector 32, BitVector 32) -- ^ (Rs1Data, Rs2Data) + -> Signal dom (Maybe (Unsigned 5, BitVector xl)) -- ^ Rd Write + -> Unbundled dom (BitVector xl, BitVector xl) -- ^ (Rs1Data, Rs2Data) regBank rs1Addr rs2Addr rdWrM = (regFile rs1Addr, regFile rs2Addr) where regFile = flip (readNew (blockRamPow2 (repeat 0))) rdWrM \ No newline at end of file diff --git a/src/Lion/Instruction.hs b/src/Lion/Instruction.hs index aae6bec..96ca2a5 100644 --- a/src/Lion/Instruction.hs +++ b/src/Lion/Instruction.hs @@ -11,36 +11,41 @@ module Lion.Instruction where import Clash.Prelude import Data.Function ( on ) +import Lion.Util.Clash + data Exception = IllegalInstruction deriving stock (Generic, Show, Eq) deriving anyclass NFDataX -- | Writeback pipeline instruction -data WbInstr = WbRegWr (Unsigned 5) (BitVector 32) - | WbLoad Load (Unsigned 5) (BitVector 4) - | WbStore - | WbNop +data WbInstr xl + = WbRegWr (Unsigned 5) (BitVector xl) + | WbLoad Load (Unsigned 5) (BitVector (Div xl 8)) + | WbStore + | WbNop deriving stock (Generic, Show, Eq) deriving anyclass NFDataX -- | Memory pipeline instruction -data MeInstr = MeRegWr (Unsigned 5) - | MeJump (Unsigned 5) (BitVector 32) - | MeBranch - | MeStore (BitVector 32) (BitVector 4) (BitVector 32) - | MeLoad Load (Unsigned 5) (BitVector 32) (BitVector 4) - | MeNop +data MeInstr xl + = MeRegWr (Unsigned 5) + | MeJump (Unsigned 5) (BitVector xl) + | MeBranch + | MeStore (BitVector xl) (BitVector (Div xl 8)) (BitVector xl) + | MeLoad Load (Unsigned 5) (BitVector xl) (BitVector (Div xl 8)) + | MeNop deriving stock (Generic, Show, Eq) deriving anyclass NFDataX -- | Execute pipeline instruction -data ExInstr = Ex ExOp (Unsigned 5) (BitVector 32) - | ExJump Jump (Unsigned 5) (BitVector 32) - | ExBranch Branch (BitVector 32) - | ExStore Store (BitVector 32) - | ExLoad Load (Unsigned 5) (BitVector 32) - | ExAlu Op (Unsigned 5) - | ExAluImm Op (Unsigned 5) (BitVector 32) +data ExInstr xl + = Ex ExOp (Unsigned 5) (BitVector xl) + | ExJump Jump (Unsigned 5) (BitVector xl) + | ExBranch Branch (BitVector xl) + | ExStore Store (BitVector xl) + | ExLoad Load (Unsigned 5) (BitVector xl) + | ExAlu Op (Unsigned 5) + | ExAluImm Op (Unsigned 5) (BitVector xl) deriving stock (Generic, Show, Eq) deriving anyclass NFDataX @@ -69,7 +74,7 @@ data Branch = Beq deriving anyclass NFDataX -- | branch calculation -branch :: Branch -> BitVector 32 -> BitVector 32 -> Bool +branch :: KnownNat xl => Branch -> BitVector xl -> BitVector xl -> Bool branch = \case Beq -> not ... (/=) Bne -> (/=) @@ -79,8 +84,6 @@ branch = \case Bltu -> (<) where (...) = (.).(.) - sign :: BitVector 32 -> Signed 32 - sign = unpack data ExOp = Lui | Auipc @@ -95,6 +98,7 @@ data Jump = Jal | Jalr data Store = Sb | Sh | Sw + | Sd deriving stock (Generic, Show, Eq) deriving anyclass NFDataX @@ -104,10 +108,12 @@ data Load = Lb | Lw | Lbu | Lhu + | Lwu + | Ld deriving stock (Generic, Show, Eq) deriving anyclass NFDataX -parseInstr :: BitVector 32 -> Either Exception ExInstr +parseInstr :: forall xl . KnownNat xl => BitVector 32 -> Either Exception (ExInstr xl) parseInstr i = case i of $(bitPattern ".........................0110111") -> Right $ Ex Lui rd immU -- lui $(bitPattern ".........................0010111") -> Right $ Ex Auipc rd immU -- auipc @@ -122,20 +128,26 @@ parseInstr i = case i of $(bitPattern ".................000.....0000011") -> Right $ ExLoad Lb rd immI -- lb $(bitPattern ".................001.....0000011") -> Right $ ExLoad Lh rd immI -- lh $(bitPattern ".................010.....0000011") -> Right $ ExLoad Lw rd immI -- lw + $(bitPattern ".................011.....0000011") -> Right $ ExLoad Ld rd immI -- ld $(bitPattern ".................100.....0000011") -> Right $ ExLoad Lbu rd immI -- lbu $(bitPattern ".................101.....0000011") -> Right $ ExLoad Lhu rd immI -- lhu + $(bitPattern ".................110.....0000011") -> Right $ ExLoad Lwu rd immI -- lwu $(bitPattern ".................000.....0100011") -> Right $ ExStore Sb immS -- sb $(bitPattern ".................001.....0100011") -> Right $ ExStore Sh immS -- sh $(bitPattern ".................010.....0100011") -> Right $ ExStore Sw immS -- sw + $(bitPattern ".................011.....0100011") -> Right $ ExStore Sd immS -- sd $(bitPattern ".................000.....0010011") -> Right $ ExAluImm Add rd immI -- addi $(bitPattern ".................010.....0010011") -> Right $ ExAluImm Slt rd immI -- slti $(bitPattern ".................011.....0010011") -> Right $ ExAluImm Sltu rd immI -- sltiu $(bitPattern ".................100.....0010011") -> Right $ ExAluImm Xor rd immI -- xori $(bitPattern ".................110.....0010011") -> Right $ ExAluImm Or rd immI -- ori $(bitPattern ".................111.....0010011") -> Right $ ExAluImm And rd immI -- andi - $(bitPattern "0000000..........001.....0010011") -> Right $ ExAluImm Sll rd immI -- slli - $(bitPattern "0000000..........101.....0010011") -> Right $ ExAluImm Srl rd immI -- srli - $(bitPattern "0100000..........101.....0010011") -> Right $ ExAluImm Sra rd immI -- srai + $(bitPattern "000000x..........001.....0010011") + | 0 == x || 32 < natVal immI -> Right $ ExAluImm Sll rd immI -- slli + $(bitPattern "000000x..........101.....0010011") + | 0 == x || 32 < natVal immI -> Right $ ExAluImm Srl rd immI -- srli + $(bitPattern "010000x..........101.....0010011") + | 0 == x || 32 < natVal immI -> Right $ ExAluImm Sra rd immI -- srai $(bitPattern "0000000..........000.....0110011") -> Right $ ExAlu Add rd -- add $(bitPattern "0100000..........000.....0110011") -> Right $ ExAlu Sub rd -- sub $(bitPattern "0000000..........001.....0110011") -> Right $ ExAlu Sll rd -- sll @@ -153,20 +165,20 @@ parseInstr i = case i of rd = sliceRd i - immI :: BitVector 32 - immI = signExtend $ slice d31 d20 i + immI :: BitVector xl + immI = signResize $ slice d31 d20 i - immS :: BitVector 32 - immS = signExtend $ slice d31 d25 i ++# slice d11 d7 i + immS :: BitVector xl + immS = signResize $ slice d31 d25 i ++# slice d11 d7 i - immB :: BitVector 32 - immB = signExtend (slice d31 d31 i ++# slice d7 d7 i ++# slice d30 d25 i ++# slice d11 d8 i) `shiftL` 1 + immB :: BitVector xl + immB = signResize (slice d31 d31 i ++# slice d7 d7 i ++# slice d30 d25 i ++# slice d11 d8 i) `shiftL` 1 - immU :: BitVector 32 - immU = slice d31 d12 i ++# 0 + immU :: BitVector xl + immU = zeroResize (slice d31 d12 i ++# 0 :: BitVector 32) - immJ :: BitVector 32 - immJ = signExtend (slice d31 d31 i ++# slice d19 d12 i ++# slice d20 d20 i ++# slice d30 d25 i ++# slice d24 d21 i) `shiftL` 1 + immJ :: BitVector xl + immJ = signResize (slice d31 d31 i ++# slice d19 d12 i ++# slice d20 d20 i ++# slice d30 d25 i ++# slice d24 d21 i) `shiftL` 1 sliceRd :: BitVector 32 -> Unsigned 5 diff --git a/src/Lion/Pipe.hs b/src/Lion/Pipe.hs index 8cb82ed..67faaaf 100644 --- a/src/Lion/Pipe.hs +++ b/src/Lion/Pipe.hs @@ -6,15 +6,19 @@ License : BSD-3-Clause Maintainer : standardsemiconductor@gmail.com -} +{-# LANGUAGE PartialTypeSignatures #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} + module Lion.Pipe where import Clash.Prelude -import Control.Lens hiding ( op ) +import Control.Lens hiding ( (:<), (:>), imap, indices, op ) import Control.Monad.RWS -import Data.Maybe ( isJust ) +import Data.Maybe ( isJust, fromMaybe ) import Data.Monoid.Generic import Lion.Instruction import Lion.Rvfi +import Lion.Util.Clash -- | Pipeline configuration data PipeConfig (startPC :: Nat) = PipeConfig @@ -27,11 +31,11 @@ defaultPipeConfig :: PipeConfig 0 defaultPipeConfig = PipeConfig -- | Pipeline inputs -data ToPipe = ToPipe - { _fromRs1 :: BitVector 32 - , _fromRs2 :: BitVector 32 - , _fromAlu :: BitVector 32 - , _fromMem :: BitVector 32 +data ToPipe xl = ToPipe + { _fromRs1 :: BitVector xl + , _fromRs2 :: BitVector xl + , _fromAlu :: BitVector xl + , _fromMem :: BitVector xl } deriving stock (Generic, Show, Eq) deriving anyclass NFDataX @@ -44,19 +48,20 @@ data MemoryAccess = InstrMem -- ^ instruction access deriving anyclass NFDataX -- | Memory bus -data ToMem = ToMem +data ToMem xl = ToMem { memAccess :: MemoryAccess -- ^ memory access type - , memAddress :: BitVector 32 -- ^ memory address - , memByteMask :: BitVector 4 -- ^ memory byte mask - , memWrite :: Maybe (BitVector 32) -- ^ read=Nothing write=Just wr + , memAddress :: BitVector xl -- ^ memory address + , memByteMask :: BitVector (Div xl 8) -- ^ memory byte mask + , memWrite :: Maybe (BitVector xl) -- ^ read=Nothing write=Just wr } deriving stock (Generic, Show, Eq) deriving anyclass NFDataX -- | Construct instruction memory access instrMem - :: BitVector 32 -- ^ instruction address - -> ToMem + :: KnownNat xl + => BitVector xl -- ^ instruction address + -> ToMem xl instrMem addr = ToMem { memAccess = InstrMem , memAddress = addr @@ -66,10 +71,10 @@ instrMem addr = ToMem -- | Construct data memory access dataMem - :: BitVector 32 -- ^ memory address - -> BitVector 4 -- ^ byte mask - -> Maybe (BitVector 32) -- ^ write - -> ToMem + :: BitVector xl -- ^ memory address + -> BitVector (Div xl 8) -- ^ byte mask + -> Maybe (BitVector xl) -- ^ write + -> ToMem xl dataMem addr mask wrM = ToMem { memAccess = DataMem , memAddress = addr @@ -78,38 +83,38 @@ dataMem addr mask wrM = ToMem } -- | Pipeline outputs -data FromPipe = FromPipe - { _toMem :: First ToMem +data FromPipe xl = FromPipe + { _toMem :: First (ToMem xl) , _toRs1Addr :: First (Unsigned 5) , _toRs2Addr :: First (Unsigned 5) - , _toRd :: First (Unsigned 5, BitVector 32) + , _toRd :: First (Unsigned 5, BitVector xl) , _toAluOp :: First Op - , _toAluInput1 :: First (BitVector 32) - , _toAluInput2 :: First (BitVector 32) - , _toRvfi :: First Rvfi + , _toAluInput1 :: First (BitVector xl) + , _toAluInput2 :: First (BitVector xl) + , _toRvfi :: First (Rvfi xl) } deriving stock (Generic, Show, Eq) deriving anyclass NFDataX - deriving Semigroup via GenericSemigroup FromPipe - deriving Monoid via GenericMonoid FromPipe + deriving Semigroup via GenericSemigroup (FromPipe xl) + deriving Monoid via GenericMonoid (FromPipe xl) makeLenses ''FromPipe -data Control = Control +data Control xl = Control { _firstCycle :: Bool -- ^ First cycle True, then always False - , _exBranching :: Maybe (BitVector 32) -- ^ execute stage branch/jump + , _exBranching :: Maybe (BitVector xl) -- ^ execute stage branch/jump , _meBranching :: Bool -- ^ memory stage branch/jump , _deLoad :: Bool -- ^ decode stage load , _exLoad :: Bool -- ^ execute stage load , _meMemory :: Bool -- ^ memory stage load/store , _wbMemory :: Bool -- ^ writeback stage load/store - , _meRegFwd :: Maybe (Unsigned 5, BitVector 32) -- ^ memory stage register forwarding - , _wbRegFwd :: Maybe (Unsigned 5, BitVector 32) -- ^ writeback stage register forwading + , _meRegFwd :: Maybe (Unsigned 5, BitVector xl) -- ^ memory stage register forwarding + , _wbRegFwd :: Maybe (Unsigned 5, BitVector xl) -- ^ writeback stage register forwading } deriving stock (Generic, Show, Eq) deriving anyclass NFDataX makeLenses ''Control -mkControl :: Control +mkControl :: Control xl mkControl = Control { _firstCycle = True , _exBranching = Nothing @@ -122,40 +127,41 @@ mkControl = Control , _wbRegFwd = Nothing } -data Pipe = Pipe - { _fetchPC :: BitVector 32 +data Pipe xl = Pipe + { _fetchPC :: BitVector xl -- decode stage - , _dePC :: BitVector 32 + , _dePC :: BitVector xl -- execute stage - , _exIR :: Maybe ExInstr - , _exPC :: BitVector 32 + , _exIR :: Maybe (ExInstr xl) + , _exPC :: BitVector xl , _exRs1 :: Unsigned 5 , _exRs2 :: Unsigned 5 - , _exRvfi :: Rvfi + , _exRvfi :: Rvfi xl -- memory stage - , _meIR :: Maybe MeInstr - , _meRvfi :: Rvfi + , _meIR :: Maybe (MeInstr xl) + , _meRvfi :: Rvfi xl -- writeback stage - , _wbIR :: Maybe WbInstr + , _wbIR :: Maybe (WbInstr xl) , _wbNRet :: BitVector 64 - , _wbRvfi :: Rvfi + , _wbRvfi :: Rvfi xl -- pipeline control - , _control :: Control + , _control :: Control xl } deriving stock (Generic, Show, Eq) deriving anyclass NFDataX makeLenses ''Pipe mkPipe - :: forall startPC - . (KnownNat startPC, startPC <= 0xFFFFFFFF) + :: forall startPC xl + . KnownNat xl + => (KnownNat startPC, startPC + 1 <= 2^xl) => PipeConfig (startPC :: Nat) - -> Pipe + -> Pipe xl mkPipe _ = Pipe { _fetchPC = natToNum @startPC @@ -185,17 +191,20 @@ mkPipe _ = Pipe -- | 5-Stage RISC-V pipeline pipe :: HiddenClockResetEnable dom - => (KnownNat startPC, startPC <= 0xFFFFFFFF) + => (KnownNat xl, 1 <= Div xl 8) + => (KnownNat startPC, startPC + 1 <= 2^xl) => PipeConfig (startPC :: Nat) - -> Signal dom ToPipe - -> Signal dom FromPipe + -> Signal dom (ToPipe xl) + -> Signal dom (FromPipe xl) pipe config = mealy pipeMealy (mkPipe config) where pipeMealy s i = let ((), s', o) = runRWS pipeM i s in (s', o) -- | Monadic pipeline -pipeM :: RWS ToPipe FromPipe Pipe () +pipeM + :: (KnownNat xl, 1 <= Div xl 8) + => RWS (ToPipe xl) (FromPipe xl) (Pipe xl) () pipeM = do writeback memory @@ -205,7 +214,9 @@ pipeM = do control .= mkControl{ _firstCycle = False } -- reset control -- | Writeback stage -writeback :: RWS ToPipe FromPipe Pipe () +writeback + :: KnownNat xl + => RWS (ToPipe xl) (FromPipe xl) (Pipe xl) () writeback = withInstr wbIR $ \instr -> do wbRvfi.rvfiValid .= True wbRvfi.rvfiOrder <~ wbNRet <<+= 1 @@ -218,14 +229,17 @@ writeback = withInstr wbIR $ \instr -> do control.wbMemory .= True wbRvfi.rvfiRdAddr .= rdAddr mem <- wbRvfi.rvfiMemRData <<~ view fromMem - let byte = sliceByte mask mem - half = sliceHalf mask mem + let mem8 = sliceX d8 mask mem + mem16 = sliceX d16 mask mem + mem32 = sliceX d32 mask mem wr = case op of - Lb -> signExtend byte - Lh -> signExtend half - Lw -> mem - Lbu -> zeroExtend byte - Lhu -> zeroExtend half + Lb -> signResize mem8 + Lh -> signResize mem16 + Lw -> signResize mem32 + Ld -> mem + Lbu -> zeroResize mem8 + Lhu -> zeroResize mem16 + Lwu -> zeroResize mem32 rdData <- wbRvfi.rvfiRdWData <.= guardZero rdAddr wr scribe toRd . First =<< control.wbRegFwd <.= Just (rdAddr, rdData) WbStore -> control.wbMemory .= True @@ -236,7 +250,7 @@ writeback = withInstr wbIR $ \instr -> do guardZero _ = id -- | Memory stage -memory :: RWS ToPipe FromPipe Pipe () +memory :: RWS (ToPipe xl) (FromPipe xl) (Pipe xl) () memory = do wbIR .= Nothing wbRvfi <~ use meRvfi @@ -268,7 +282,9 @@ memory = do wbIR ?= WbLoad op rdAddr mask -- | Execute stage -execute :: RWS ToPipe FromPipe Pipe () +execute :: forall xl + . (KnownNat xl, 1 <= Div xl 8) + => RWS (ToPipe xl) (FromPipe xl) (Pipe xl) () execute = do meIR .= Nothing meRvfi <~ use exRvfi @@ -286,41 +302,43 @@ execute = do npc <- meRvfi.rvfiPcWData <<~ control.exBranching pc + imm Jalr -> clearBit (rs1Data + imm) 0 - meRvfi.rvfiTrap ||= isMisaligned npc + meRvfi.rvfiTrap ||= isMisaligned d32 npc meIR ?= MeJump rd pc4 ExBranch op imm -> if branch op rs1Data rs2Data then do branchPC <- meRvfi.rvfiPcWData <<~ control.exBranching do + ExStore op imm -> let addr = rs1Data + imm -- unaligned - addr' = addr .&. complement 0x3 -- aligned - case op of - Sb -> let wr = concatBitVector# $ replicate d4 $ slice d7 d0 rs2Data - in meIR ?= MeStore addr' (byteMask addr) wr - Sh -> do - meRvfi.rvfiTrap ||= isMisalignedHalf addr -- trap on half-word boundary - let wr = concatBitVector# $ replicate d2 $ slice d15 d0 rs2Data - meIR ?= MeStore addr' (halfMask addr) wr - Sw -> do - meRvfi.rvfiTrap ||= isMisaligned addr -- trap on word boundary - meIR ?= MeStore addr' 0xF rs2Data + addr' = addr .&. fromIntegral (natVal (SNat :: SNat (Div xl 8)) - 1) -- aligned + helper :: _ => SNat yl -> _ + helper yl = do + meRvfi.rvfiTrap ||= isMisaligned yl addr -- trap on boundary + let wr :: BitVector xl + wr = concatReplicateI $ resizeTo yl rs2Data + meIR ?= MeStore addr' (byteMaskX yl addr) wr + in case op of + Sb -> helper d8 + Sh -> helper d16 + Sw -> helper d32 + Sd -> helper d64 ExLoad op rdAddr imm -> do control.exLoad .= True let addr = rs1Data + imm -- unaligned - addr' = addr .&. complement 0x3 -- aligned - if | op == Lb || op == Lbu -> meIR ?= MeLoad op rdAddr addr' (byteMask addr) - | op == Lh || op == Lhu -> do - meRvfi.rvfiTrap ||= isMisalignedHalf addr -- trap on half-word boundary - meIR ?= MeLoad op rdAddr addr' (halfMask addr) - | otherwise -> do -- Lw - meRvfi.rvfiTrap ||= isMisaligned addr -- trap on word boundary - meIR ?= MeLoad op rdAddr addr' 0xF + addr' = addr .&. fromIntegral (natVal (SNat :: SNat (Div xl 8)) - 1) -- aligned + helper :: _ => SNat yl -> _ + helper yl = do + meRvfi.rvfiTrap ||= isMisaligned yl addr -- trap on boundary + meIR ?= MeLoad op rdAddr addr' (byteMaskX yl addr) + if | op == Lb || op == Lbu -> helper d8 + | op == Lh || op == Lhu -> helper d16 + | op == Lw || op == Lwu -> helper d32 + | otherwise -> helper d64 ExAlu op rd -> do scribeAlu op rs1Data rs2Data meIR ?= MeRegWr rd @@ -337,18 +355,18 @@ execute = do :: MonadState s m => MonadReader r m => Lens' s (Unsigned 5) - -> Lens' r (BitVector 32) - -> Lens' s (Maybe (Unsigned 5, BitVector 32)) - -> Lens' s (Maybe (Unsigned 5, BitVector 32)) - -> m (BitVector 32) + -> Lens' r (BitVector xl) + -> Lens' s (Maybe (Unsigned 5, BitVector xl)) + -> Lens' s (Maybe (Unsigned 5, BitVector xl)) + -> m (BitVector xl) regFwd rsAddr rsData meFwd wbFwd = guardZero rsAddr =<< fwd <$> use rsAddr <*> view rsData <*> use meFwd <*> use wbFwd where guardZero -- register x0 always has value 0. :: MonadState s m => Lens' s (Unsigned 5) - -> BitVector 32 - -> m (BitVector 32) + -> BitVector xl + -> m (BitVector xl) guardZero addr value = do isZero <- uses addr (== 0) return $ if isZero @@ -356,12 +374,12 @@ execute = do else value -- | Decode stage -decode :: RWS ToPipe FromPipe Pipe () +decode :: KnownNat xl => RWS (ToPipe xl) (FromPipe xl) (Pipe xl) () decode = do exIR .= Nothing exRvfi .= mkRvfi exPC <~ use dePC - mem <- exRvfi.rvfiInsn <<~ view fromMem + mem <- exRvfi.rvfiInsn <<~ (resize <$> view fromMem) scribe toRs1Addr . First . Just =<< exRvfi.rvfiRs1Addr <<~ exRs1 <.= sliceRs1 mem scribe toRs2Addr . First . Just =<< exRvfi.rvfiRs2Addr <<~ exRs2 <.= sliceRs2 mem isFirstCycle <- use $ control.firstCycle -- first memory output undefined @@ -381,7 +399,7 @@ decode = do exRvfi.rvfiTrap .= True -- | fetch instruction -fetch :: RWS ToPipe FromPipe Pipe () +fetch :: KnownNat xl => RWS (ToPipe xl) (FromPipe xl) (Pipe xl) () fetch = do scribe toMem . First . Just . instrMem =<< use fetchPC isMeMemory <- use $ control.meMemory @@ -397,10 +415,10 @@ fetch = do -- | forward register writes fwd :: Unsigned 5 - -> BitVector 32 - -> Maybe (Unsigned 5, BitVector 32) -- ^ meRegFwd - -> Maybe (Unsigned 5, BitVector 32) -- ^ wbRegFwd - -> BitVector 32 + -> BitVector xl + -> Maybe (Unsigned 5, BitVector xl) -- ^ meRegFwd + -> Maybe (Unsigned 5, BitVector xl) -- ^ wbRegFwd + -> BitVector xl fwd _ wr Nothing Nothing = wr fwd addr wr Nothing (Just (wbAddr, wbWr)) | addr == wbAddr = wbWr @@ -414,38 +432,27 @@ fwd addr wr (Just (meAddr, meWr)) (Just (wbAddr, wbWr)) | otherwise = wr -- | calcluate byte mask based on address -byteMask :: BitVector 32 -> BitVector 4 -byteMask = (1 `shiftL`) . unpack . resize . slice d1 d0 - --- | calculate half word mask based on address -halfMask :: BitVector 32 -> BitVector 4 -halfMask addr = if addr .&. 0x2 == 0 - then 0x3 - else 0xC - --- | slice address based on mask -sliceByte :: BitVector 4 -> BitVector 32 -> BitVector 8 -sliceByte = \case - $(bitPattern "...1") -> slice d7 d0 - $(bitPattern "..1.") -> slice d15 d8 - $(bitPattern ".1..") -> slice d23 d16 - $(bitPattern "1...") -> slice d31 d24 - _ -> const 0 - --- | slice address based on mask -sliceHalf :: BitVector 4 -> BitVector 32 -> BitVector 16 -sliceHalf = \case - $(bitPattern "..11") -> slice d15 d0 - $(bitPattern "11..") -> slice d31 d16 - _ -> const 0 +byteMaskX + :: (KnownNat xl, 1 <= Div xl 8, 1 <= Div yl 8) + => SNat yl -> BitVector xl -> BitVector (Div xl 8) +byteMaskX yl@SNat = + shiftL (shiftL 1 (fromIntegral $ natVal $ divSNat yl d8) - 1) . unpack . + (.&.) (fromIntegral $ complement $ natVal yl `div` 8 - 1) . zeroResize . + (resizeTo =<< flogBaseSNat d2 . flip divSNat d8 . snatProxy) + +sliceX :: forall xl yl + . (KnownNat xl, 1 <= yl) + => SNat yl -> BitVector (Div xl 8) -> BitVector xl -> BitVector yl +sliceX yl@SNat mask = resizeTo yl . (pure 0 `fromMaybe` fold (<|>) (imap f mask' :< empty)) + where + mask' :: Vec (Div xl yl) (BitVector (Div yl 8)) + mask' = unconcatBitVector# (resize mask) --- | check if memory address misaligned on word boundary -isMisaligned :: (Bits a, Num a) => a -> Bool -isMisaligned a = a .&. 0x3 /= 0 + f k m = flip shiftR (fromIntegral (natVal yl)*fromEnum k) <$ guard (0 == complement m) --- | check if memory address misaligned on half-word boundary -isMisalignedHalf :: (Bits a, Num a) => a -> Bool -isMisalignedHalf a = a .&. 0x1 /= 0 +-- | check if memory address misaligned on word boundary +isMisaligned :: (Bits a, Num a, KnownNat xl) => SNat xl -> a -> Bool +isMisaligned xl a = 0 /= a .&. fromIntegral (natVal xl `div` 8 - 1) -- | run monadic action when instruction is Just withInstr :: MonadState s m => Lens' s (Maybe a) -> (a -> m ()) -> m () diff --git a/src/Lion/Rvfi.hs b/src/Lion/Rvfi.hs index cad8b79..2ddfe99 100644 --- a/src/Lion/Rvfi.hs +++ b/src/Lion/Rvfi.hs @@ -27,7 +27,7 @@ data RvfiCsr n = RvfiCsr makeLenses ''RvfiCsr -- | RISC-V Formal Interface -data Rvfi = Rvfi +data Rvfi xl = Rvfi { -- | When the core retires an instruction, it asserts the `rvfiValid` signal -- and uses the signals described in Rvfi to output the details of the -- retired instruction. The signals below are only valid during such a @@ -85,8 +85,8 @@ data Rvfi = Rvfi -- | `rvfiRs1Data` and `rvfiRs2Data` are the values of the register -- addressed by rs1 and rs2 before execute of this instruction. -- This output must be zero when rs1/rs2 is zero. - , _rvfiRs1Data :: "rs1_rdata" ::: BitVector 32 - , _rvfiRs2Data :: "rs2_rdata" ::: BitVector 32 + , _rvfiRs1Data :: "rs1_rdata" ::: BitVector xl + , _rvfiRs2Data :: "rs2_rdata" ::: BitVector xl -- | `rvfiRdAddr` is the decoded rd register address for the retired -- instruction. For an instruction that writes no rd register, this output @@ -96,51 +96,51 @@ data Rvfi = Rvfi -- | `rvfiRdWData` is the value of the register addressed by rd after -- execution of this instruction. This output must be zero when rd -- is zero. - , _rvfiRdWData :: "rd_wdata" ::: BitVector 32 + , _rvfiRdWData :: "rd_wdata" ::: BitVector xl -- | This is the program counter (pc) before (`rvfiPcRData`) and after -- (`rvfiPcWData`) execution of this instruciton. I.e. this is the -- address of the retired instruction and the address of the next -- instruction. - , _rvfiPcRData :: "pc_rdata" ::: BitVector 32 - , _rvfiPcWData :: "pc_wdata" ::: BitVector 32 + , _rvfiPcRData :: "pc_rdata" ::: BitVector xl + , _rvfiPcWData :: "pc_wdata" ::: BitVector xl -- | For memory operations (`rvfiMemRMask` and/or `rvfiMemWMask` are non-zero), -- `rvfiMemAddr` holds the accessed memory location. - , _rvfiMemAddr :: "mem_addr" ::: BitVector 32 + , _rvfiMemAddr :: "mem_addr" ::: BitVector xl -- | `rvfiMemRMask` is a bitmask that specifies which bytes in `rvfiMemRData` -- contain valid read data from `rvfiMemAddr`. - , _rvfiMemRMask :: "mem_rmask" ::: BitVector 4 + , _rvfiMemRMask :: "mem_rmask" ::: BitVector (Div xl 8) -- | `rvfiMemWMask` is a bitmask that specifies which bytes in `rvfiMemWData` -- contain valid data this is written to `rvfiMemAddr`. - , _rvfiMemWMask :: "mem_wmask" ::: BitVector 4 + , _rvfiMemWMask :: "mem_wmask" ::: BitVector (Div xl 8) -- | `rvfiMemRData` is the pre-state data read from `rvfiMemAddr`. -- `rvfiMemRMask` specifies which bytes are valid. - , _rvfiMemRData :: "mem_rdata" ::: BitVector 32 + , _rvfiMemRData :: "mem_rdata" ::: BitVector xl -- | `rvfiMemWData` is the post-state data written to `rvfiMemAddr`. -- `rvfiMemWMask` specifies which bytes are valid. - , _rvfiMemWData :: "mem_wdata" ::: BitVector 32 + , _rvfiMemWData :: "mem_wdata" ::: BitVector xl , _rvfiCsrMinstret :: "csr_minstret" ::: RvfiCsr 64 , _rvfiCsrMcycle :: "csr_mcycle" ::: RvfiCsr 64 - , _rvfiCsrMscratch :: "csr_mscratch" ::: RvfiCsr 32 - , _rvfiCsrMstatus :: "csr_mstatus" ::: RvfiCsr 32 - , _rvfiCsrMisa :: "csr_misa" ::: RvfiCsr 32 + , _rvfiCsrMscratch :: "csr_mscratch" ::: RvfiCsr xl + , _rvfiCsrMstatus :: "csr_mstatus" ::: RvfiCsr xl + , _rvfiCsrMisa :: "csr_misa" ::: RvfiCsr xl } deriving stock (Generic, Show, Eq) deriving anyclass NFDataX makeLenses ''Rvfi -- | Unwrap Rvfi from First monoid -fromRvfi :: First Rvfi -> Rvfi +fromRvfi :: KnownNat xl => First (Rvfi xl) -> Rvfi xl fromRvfi = fromMaybe mkRvfi . getFirst -- | Construct the RISC-V Formal Interface -mkRvfi :: Rvfi +mkRvfi :: KnownNat xl => Rvfi xl mkRvfi = Rvfi { _rvfiValid = False , _rvfiOrder = 0 diff --git a/src/Lion/Util/Clash.hs b/src/Lion/Util/Clash.hs new file mode 100644 index 0000000..d8e58b5 --- /dev/null +++ b/src/Lion/Util/Clash.hs @@ -0,0 +1,16 @@ +module Lion.Util.Clash where + +import Clash.Prelude + +signResize, zeroResize :: forall m n . (KnownNat m, KnownNat n) => BitVector m -> BitVector n +signResize = resize +zeroResize = pack . (resize :: Unsigned m -> Unsigned n) . unpack + +resizeTo :: (Resize a, KnownNat m) => SNat n -> a m -> a n +resizeTo SNat = resize + +sign :: KnownNat n => BitVector n -> Signed n +sign = unpack + +concatReplicateI :: forall m n . (KnownNat m, KnownNat n, 1 <= m) => BitVector m -> BitVector n +concatReplicateI = resize . concatBitVector# . replicate (SNat :: SNat (Div n m + 1)) From e4bbe51b752c235a939f2f1f6d45d0df15c27279 Mon Sep 17 00:00:00 2001 From: M Farkas-Dyck Date: Thu, 4 Nov 2021 23:09:48 -0800 Subject: [PATCH 2/3] Add *W instructions for RV64I. --- src/Lion/Instruction.hs | 80 +++++++++++++++++++++++++++-------------- src/Lion/Pipe.hs | 27 +++++++------- 2 files changed, 68 insertions(+), 39 deletions(-) diff --git a/src/Lion/Instruction.hs b/src/Lion/Instruction.hs index 96ca2a5..a15ca18 100644 --- a/src/Lion/Instruction.hs +++ b/src/Lion/Instruction.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} + {-| Module : Lion.Instruction Description : RISC-V ISA @@ -9,6 +13,7 @@ Maintainer : standardsemiconductor@gmail.com module Lion.Instruction where import Clash.Prelude +import Data.Either ( isLeft ) import Data.Function ( on ) import Lion.Util.Clash @@ -19,7 +24,7 @@ data Exception = IllegalInstruction -- | Writeback pipeline instruction data WbInstr xl - = WbRegWr (Unsigned 5) (BitVector xl) + = WbRegWr (Unsigned 5) (BitVector xl) (OpWidth xl) | WbLoad Load (Unsigned 5) (BitVector (Div xl 8)) | WbStore | WbNop @@ -28,7 +33,7 @@ data WbInstr xl -- | Memory pipeline instruction data MeInstr xl - = MeRegWr (Unsigned 5) + = MeRegWr (Unsigned 5) (OpWidth xl) | MeJump (Unsigned 5) (BitVector xl) | MeBranch | MeStore (BitVector xl) (BitVector (Div xl 8)) (BitVector xl) @@ -44,11 +49,29 @@ data ExInstr xl | ExBranch Branch (BitVector xl) | ExStore Store (BitVector xl) | ExLoad Load (Unsigned 5) (BitVector xl) - | ExAlu Op (Unsigned 5) - | ExAluImm Op (Unsigned 5) (BitVector xl) + | ExAlu Op (Unsigned 5) (OpWidth xl) + | ExAluImm Op (Unsigned 5) (BitVector xl) (OpWidth xl) deriving stock (Generic, Show, Eq) deriving anyclass NFDataX +data OpWidth xl where + FullWidth :: OpWidth xl + ShortWidth32 :: 33 <= xl => OpWidth xl + +deriving instance Show (OpWidth xl) +deriving instance Eq (OpWidth xl) + +instance NFDataX (OpWidth xl) where + deepErrorX = errorX + hasUndefined = isLeft . isX + ensureSpine = id + rnfX = rwhnfX + +shorten :: forall xl . KnownNat xl => OpWidth xl -> BitVector xl -> BitVector xl +shorten = \ case + FullWidth -> id + ShortWidth32 -> bitCoerce . (signResize :: _ 32 -> _) . resize + -- | ALU operation data Op = Add | Sub @@ -136,28 +159,28 @@ parseInstr i = case i of $(bitPattern ".................001.....0100011") -> Right $ ExStore Sh immS -- sh $(bitPattern ".................010.....0100011") -> Right $ ExStore Sw immS -- sw $(bitPattern ".................011.....0100011") -> Right $ ExStore Sd immS -- sd - $(bitPattern ".................000.....0010011") -> Right $ ExAluImm Add rd immI -- addi - $(bitPattern ".................010.....0010011") -> Right $ ExAluImm Slt rd immI -- slti - $(bitPattern ".................011.....0010011") -> Right $ ExAluImm Sltu rd immI -- sltiu - $(bitPattern ".................100.....0010011") -> Right $ ExAluImm Xor rd immI -- xori - $(bitPattern ".................110.....0010011") -> Right $ ExAluImm Or rd immI -- ori - $(bitPattern ".................111.....0010011") -> Right $ ExAluImm And rd immI -- andi - $(bitPattern "000000x..........001.....0010011") - | 0 == x || 32 < natVal immI -> Right $ ExAluImm Sll rd immI -- slli - $(bitPattern "000000x..........101.....0010011") - | 0 == x || 32 < natVal immI -> Right $ ExAluImm Srl rd immI -- srli - $(bitPattern "010000x..........101.....0010011") - | 0 == x || 32 < natVal immI -> Right $ ExAluImm Sra rd immI -- srai - $(bitPattern "0000000..........000.....0110011") -> Right $ ExAlu Add rd -- add - $(bitPattern "0100000..........000.....0110011") -> Right $ ExAlu Sub rd -- sub - $(bitPattern "0000000..........001.....0110011") -> Right $ ExAlu Sll rd -- sll - $(bitPattern "0000000..........010.....0110011") -> Right $ ExAlu Slt rd -- slt - $(bitPattern "0000000..........011.....0110011") -> Right $ ExAlu Sltu rd -- sltu - $(bitPattern "0000000..........100.....0110011") -> Right $ ExAlu Xor rd -- xor - $(bitPattern "0000000..........101.....0110011") -> Right $ ExAlu Srl rd -- srl - $(bitPattern "0100000..........101.....0110011") -> Right $ ExAlu Sra rd -- sra - $(bitPattern "0000000..........110.....0110011") -> Right $ ExAlu Or rd -- or - $(bitPattern "0000000..........111.....0110011") -> Right $ ExAlu And rd -- and + $(bitPattern ".................000.....001.011") -> ExAluImm Add rd immI <$> opWidth -- addi + $(bitPattern ".................010.....0010011") -> Right $ ExAluImm Slt rd immI FullWidth -- slti + $(bitPattern ".................011.....0010011") -> Right $ ExAluImm Sltu rd immI FullWidth -- sltiu + $(bitPattern ".................100.....0010011") -> Right $ ExAluImm Xor rd immI FullWidth -- xori + $(bitPattern ".................110.....0010011") -> Right $ ExAluImm Or rd immI FullWidth -- ori + $(bitPattern ".................111.....0010011") -> Right $ ExAluImm And rd immI FullWidth -- andi + $(bitPattern "000000x..........001.....001.011") + | 0 == x || 32 < natVal immI -> ExAluImm Sll rd immI <$> opWidth -- slli + $(bitPattern "000000x..........101.....001.011") + | 0 == x || 32 < natVal immI -> ExAluImm Srl rd immI <$> opWidth -- srli + $(bitPattern "010000x..........101.....001.011") + | 0 == x || 32 < natVal immI -> ExAluImm Sra rd immI <$> opWidth -- srai + $(bitPattern "0000000..........000.....011.011") -> ExAlu Add rd <$> opWidth -- add + $(bitPattern "0100000..........000.....011.011") -> ExAlu Sub rd <$> opWidth -- sub + $(bitPattern "0000000..........001.....011.011") -> ExAlu Sll rd <$> opWidth -- sll + $(bitPattern "0000000..........010.....0110011") -> Right $ ExAlu Slt rd FullWidth -- slt + $(bitPattern "0000000..........011.....0110011") -> Right $ ExAlu Sltu rd FullWidth -- sltu + $(bitPattern "0000000..........100.....0110011") -> Right $ ExAlu Xor rd FullWidth -- xor + $(bitPattern "0000000..........101.....011.011") -> ExAlu Srl rd <$> opWidth -- srl + $(bitPattern "0100000..........101.....011.011") -> ExAlu Sra rd <$> opWidth -- sra + $(bitPattern "0000000..........110.....0110011") -> Right $ ExAlu Or rd FullWidth -- or + $(bitPattern "0000000..........111.....0110011") -> Right $ ExAlu And rd FullWidth -- and _ -> Left IllegalInstruction where -- npcB = immB + pc @@ -180,6 +203,11 @@ parseInstr i = case i of immJ :: BitVector xl immJ = signResize (slice d31 d31 i ++# slice d19 d12 i ++# slice d20 d20 i ++# slice d30 d25 i ++# slice d24 d21 i) `shiftL` 1 + opWidth + | testBit i 3 = case compareSNat d33 (SNat :: SNat xl) of + SNatLE -> pure ShortWidth32 + SNatGT -> Left IllegalInstruction + | otherwise = pure FullWidth sliceRd :: BitVector 32 -> Unsigned 5 sliceRd = unpack . slice d11 d7 diff --git a/src/Lion/Pipe.hs b/src/Lion/Pipe.hs index 67faaaf..c6e447a 100644 --- a/src/Lion/Pipe.hs +++ b/src/Lion/Pipe.hs @@ -14,6 +14,7 @@ module Lion.Pipe where import Clash.Prelude import Control.Lens hiding ( (:<), (:>), imap, indices, op ) import Control.Monad.RWS +import Data.Function ( on ) import Data.Maybe ( isJust, fromMaybe ) import Data.Monoid.Generic import Lion.Instruction @@ -221,10 +222,10 @@ writeback = withInstr wbIR $ \instr -> do wbRvfi.rvfiValid .= True wbRvfi.rvfiOrder <~ wbNRet <<+= 1 case instr of - WbRegWr rdAddr wr -> do + WbRegWr rdAddr wr opWidth -> do wbRvfi.rvfiRdAddr .= rdAddr rdData <- wbRvfi.rvfiRdWData <.= guardZero rdAddr wr - scribe toRd . First =<< control.wbRegFwd <.= Just (rdAddr, rdData) + scribe toRd . First =<< control.wbRegFwd <.= Just (rdAddr, shorten opWidth rdData) WbLoad op rdAddr mask -> do control.wbMemory .= True wbRvfi.rvfiRdAddr .= rdAddr @@ -256,14 +257,14 @@ memory = do wbRvfi <~ use meRvfi withInstr meIR $ \case MeNop -> wbIR ?= WbNop - MeRegWr rd -> do + MeRegWr rd opWidth -> do wr <- view fromAlu control.meRegFwd ?= (rd, wr) - wbIR ?= WbRegWr rd wr + wbIR ?= WbRegWr rd wr opWidth MeJump rd pc4 -> do control.meBranching .= True control.meRegFwd ?= (rd, pc4) - wbIR ?= WbRegWr rd pc4 + wbIR ?= WbRegWr rd pc4 FullWidth MeBranch -> do control.meBranching .= True wbIR ?= WbNop @@ -297,7 +298,7 @@ execute = do scribeAlu Add imm $ case op of Lui -> 0 Auipc -> pc - meIR ?= MeRegWr rd + meIR ?= MeRegWr rd FullWidth ExJump jump rd imm -> do npc <- meRvfi.rvfiPcWData <<~ control.exBranching pc + imm @@ -339,12 +340,12 @@ execute = do | op == Lh || op == Lhu -> helper d16 | op == Lw || op == Lwu -> helper d32 | otherwise -> helper d64 - ExAlu op rd -> do - scribeAlu op rs1Data rs2Data - meIR ?= MeRegWr rd - ExAluImm op rd imm -> do - scribeAlu op rs1Data imm - meIR ?= MeRegWr rd + ExAlu op rd opWidth -> do + (scribeAlu op `on` shorten opWidth) rs1Data rs2Data + meIR ?= MeRegWr rd FullWidth + ExAluImm op rd imm opWidth -> do + scribeAlu op (shorten opWidth rs1Data) imm + meIR ?= MeRegWr rd FullWidth where scribeAlu op in1 in2 = do scribe toAluOp $ First $ Just op @@ -395,7 +396,7 @@ decode = do ExLoad{} -> True _ -> False Left IllegalInstruction -> do -- trap and instr=Nop (addi x0 x0 0) - unless bubble $ exIR ?= ExAlu Add 0 + unless bubble $ exIR ?= ExAlu Add 0 FullWidth exRvfi.rvfiTrap .= True -- | fetch instruction From b3911eb31e4b88a5f2ea711f06c47c15ce565793 Mon Sep 17 00:00:00 2001 From: M Farkas-Dyck Date: Fri, 5 Nov 2021 00:38:49 -0800 Subject: [PATCH 3/3] lion-soc: Generalize XLEN. --- lion-soc/lion-soc.cabal | 1 + lion-soc/src/Bus.hs | 68 +++++++++++++++++++++-------------------- lion-soc/src/Soc.hs | 41 ++++++++++++------------- lion-soc/src/Spi.hs | 34 +++++++++++---------- lion-soc/src/Spram.hs | 28 ++++++++--------- lion-soc/src/Uart.hs | 36 +++++++++++----------- lion.cabal | 2 +- src/Lion/Util/Clash.hs | 3 ++ 8 files changed, 110 insertions(+), 103 deletions(-) diff --git a/lion-soc/lion-soc.cabal b/lion-soc/lion-soc.cabal index 3be1852..b371346 100644 --- a/lion-soc/lion-soc.cabal +++ b/lion-soc/lion-soc.cabal @@ -55,6 +55,7 @@ library ViewPatterns TemplateHaskell TypeOperators + ScopedTypeVariables executable soc main-is: Main.hs diff --git a/lion-soc/src/Bus.hs b/lion-soc/src/Bus.hs index c8c8109..1392385 100644 --- a/lion-soc/src/Bus.hs +++ b/lion-soc/src/Bus.hs @@ -21,56 +21,57 @@ data Peripheral = Rom deriving stock (Generic, Show, Eq) deriving anyclass NFDataX -data BusIn (p :: Peripheral) where +data BusIn xl (p :: Peripheral) where ToRom :: Unsigned 8 -- ^ ROM word address - -> BusIn 'Rom -- ^ ROM access + -> BusIn xl 'Rom -- ^ ROM access ToLed :: BitVector 4 -- ^ LED IP register address -> BitVector 8 -- ^ LED IP register write data -> Bool -- ^ LED IP enable - -> BusIn 'Led -- ^ LED access + -> BusIn xl 'Led -- ^ LED access ToUart :: BitVector 3 -- ^ UART mask -> Maybe (BitVector 8) -- ^ UART write value - -> BusIn 'Uart -- ^ UART access + -> BusIn xl 'Uart -- ^ UART access ToSpram :: BitVector 15 -- ^ SPRAM address - -> BitVector 32 -- ^ SPRAM dataIn - -> BitVector 8 -- ^ SPRAM mask write enable + -> BitVector xl -- ^ SPRAM dataIn + -> BitVector (Div xl 4) -- ^ SPRAM mask write enable -> Bit -- ^ SPRAM write enable - -> BusIn 'Spram -- ^ SPRAM access + -> BusIn xl 'Spram -- ^ SPRAM access - ToSpi :: BitVector 4 -- ^ SPI mask - -> Maybe (BitVector 32) -- ^ SPI read/write, read=Nothing, write=Just value - -> BusIn 'Spi -- ^ SPI access + ToSpi :: BitVector (Div xl 8) -- ^ SPI mask + -> Maybe (BitVector xl) -- ^ SPI read/write, read=Nothing, write=Just value + -> BusIn xl 'Spi -- ^ SPI access -data BusOut (p :: Peripheral) where - FromRom :: BitVector 32 -> BusOut 'Rom - FromUart :: BitVector 32 -> BusOut 'Uart - FromSpram :: BitVector 32 -> BusOut 'Spram - FromSpi :: BitVector 32 -> BusOut 'Spi +data BusOut xl (p :: Peripheral) where + FromRom :: BitVector xl -> BusOut xl 'Rom + FromUart :: BitVector xl -> BusOut xl 'Uart + FromSpram :: BitVector xl -> BusOut xl 'Spram + FromSpi :: BitVector xl -> BusOut xl 'Spi -romMap :: Maybe (ToMem 32) -> BusIn 'Rom +romMap :: forall xl . KnownNat xl => Maybe (ToMem xl) -> BusIn xl 'Rom romMap = ToRom . wordAddr . maybe 0 memAddress where - wordAddr :: BitVector 32 -> Unsigned 8 - wordAddr a = unpack $ slice d7 d0 $ a `shiftR` 2 + wordAddr :: BitVector xl -> Unsigned 8 + wordAddr a = unpack $ resize $ a `shiftR` 2 -uartMap :: Peripheral -> Maybe (ToMem 32) -> BusIn 'Uart -uartMap Uart (Just (ToMem DataMem _ msk wrM)) = ToUart (slice d2 d0 msk) $ slice d7 d0 <$> wrM +uartMap :: KnownNat xl => Peripheral -> Maybe (ToMem xl) -> BusIn xl 'Uart +uartMap Uart (Just (ToMem DataMem _ msk wrM)) = ToUart (resize msk) $ resize <$> wrM uartMap _ _ = ToUart 0 Nothing -ledMap :: Peripheral -> Maybe (ToMem 32) -> BusIn 'Led -ledMap Led (Just (ToMem _ _ $(bitPattern "..11") (Just d))) = ToLed (slice d11 d8 d) (slice d7 d0 d) True +ledMap :: KnownNat xl => Peripheral -> Maybe (ToMem xl) -> BusIn xl 'Led +ledMap Led (Just (ToMem _ _ $(bitPattern "..11") (Just d'))) = ToLed (slice d11 d8 d) (slice d7 d0 d) True + where d = resize d' :: BitVector 12 ledMap _ _ = ToLed 0 0 False -spramMap :: Peripheral -> Maybe (ToMem 32) -> BusIn 'Spram +spramMap :: KnownNat xl => Peripheral -> Maybe (ToMem xl) -> BusIn xl 'Spram spramMap _ Nothing = ToSpram 0 0 0 0 spramMap periph (Just mem) = case (periph, memWrite mem) of - (Spram, Just wr) -> ToSpram wordAddr wr nybMask 1 + (Spram, Just wr) -> ToSpram wordAddr wr (resize nybMask) 1 _ -> ToSpram wordAddr 0 0 0 where - wordAddr = slice d14 d0 $ memAddress mem `shiftR` 2 + wordAddr = resize $ memAddress mem `shiftR` 2 nybMask = concatBitVector# $ map expandBit $ bv2v $ memByteMask mem where expandBit :: Bit -> BitVector 2 @@ -78,11 +79,11 @@ spramMap periph (Just mem) = case (periph, memWrite mem) of | b == high = 0b11 | otherwise = 0b00 -spiMap :: Peripheral -> Maybe (ToMem 32) -> BusIn 'Spi +spiMap :: KnownNat xl => Peripheral -> Maybe (ToMem xl) -> BusIn xl 'Spi spiMap Spi (Just (ToMem DataMem _ mask wrM)) = ToSpi mask wrM spiMap _ _ = ToSpi 0 Nothing -selectPeripheral :: Maybe (ToMem 32) -> Peripheral +selectPeripheral :: forall xl . KnownNat xl => Maybe (ToMem xl) -> Peripheral selectPeripheral Nothing = Rom selectPeripheral (Just toMem) | checkRegion 17 = Spram @@ -91,16 +92,17 @@ selectPeripheral (Just toMem) | checkRegion 2 = Uart | otherwise = Led where - checkRegion :: Index 32 -> Bool + checkRegion :: Index xl -> Bool checkRegion = bitToBool . (memAddress toMem !) busMapOut - :: BusOut 'Rom - -> BusOut 'Uart - -> BusOut 'Spram - -> BusOut 'Spi + :: KnownNat xl + => BusOut xl 'Rom + -> BusOut xl 'Uart + -> BusOut xl 'Spram + -> BusOut xl 'Spi -> Peripheral - -> BitVector 32 + -> BitVector xl busMapOut (FromRom fromBios) (FromUart fromUart) (FromSpram fromSpram) diff --git a/lion-soc/src/Soc.hs b/lion-soc/src/Soc.hs index a0b24a3..92a5729 100644 --- a/lion-soc/src/Soc.hs +++ b/lion-soc/src/Soc.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE PartialTypeSignatures #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} + {-| Module : Soc Description : Lion SoC on the VELDT @@ -10,6 +13,7 @@ module Soc where import Clash.Prelude import Clash.Annotations.TH +import Control.Applicative ((<|>)) import Data.Functor ( (<&>) ) import Ice40.Clock import Ice40.Osc ( hf12Mhz ) @@ -32,7 +36,7 @@ data FromSoc dom = FromSoc --------- type Rgb = ("red" ::: Bit, "green" ::: Bit, "blue" ::: Bit) -rgb :: HiddenClock dom => Signal dom (BusIn 'Led) -> Signal dom Rgb +rgb :: HiddenClock dom => Signal dom (BusIn xl 'Led) -> Signal dom Rgb rgb mem = rgbPrim "0b0" "0b111111" "0b111111" "0b111111" (pure 1) (pure 1) r g b where (r, g, b, _) = led (pure 1) wr addr en (pure True) @@ -43,33 +47,25 @@ rgb mem = rgbPrim "0b0" "0b111111" "0b111111" "0b111111" (pure 1) (pure 1) r g b -- ROM -- ---------- bios - :: HiddenClockResetEnable dom - => Signal dom (BusIn 'Rom) - -> Signal dom (BusOut 'Rom) -bios mem = fmap FromRom $ concat4 <$> b3 <*> b2 <*> b1 <*> b0 + :: forall dom xl . HiddenClockResetEnable dom + => Signal dom (BusIn xl 'Rom) + -> Signal dom (BusOut xl 'Rom) +bios mem = fmap FromRom $ resize . concatBitVector# <$> bs where - b3 = romFilePow2 "_build/bios/bios.rom3" addr - b2 = romFilePow2 "_build/bios/bios.rom2" addr - b1 = romFilePow2 "_build/bios/bios.rom1" addr - b0 = romFilePow2 "_build/bios/bios.rom0" addr + bs :: Signal dom (Vec (Div xl 8) (BitVector 8)) + bs = bundle $ (\ n -> romFilePow2 ("_build/bios/bios.rom" <|> show n) addr) <$> iterate (divSNat (SNat :: SNat xl) 8) succ (0 :: Int) addr = mem <&> \case ToRom a -> a -concat4 - :: KnownNat n - => BitVector n - -> BitVector n - -> BitVector n - -> BitVector n - -> BitVector (4 * n) -concat4 b3 b2 b1 b0 = b3 ++# b2 ++# b1 ++# b0 - -------------- -- Lion SoC -- -------------- -{-# NOINLINE lion #-} -lion :: HiddenClockResetEnable dom => Signal dom Bit -> FromSoc dom -lion rxIn = FromSoc +{-# NOINLINE lion32 #-} +lion32 :: HiddenClockResetEnable dom => Signal dom Bit -> FromSoc dom +lion32 = lion d32 + +lion :: forall dom xl . (HiddenClockResetEnable dom, 1 <= Div xl 8, 1025 <= (2^xl)) => SNat xl -> Signal dom Bit -> FromSoc dom +lion _ rxIn = FromSoc { rgbOut = fromRgb , txOut = tx , spiIO = spiio @@ -77,6 +73,7 @@ lion rxIn = FromSoc where config :: CoreConfig 0x400 'Hard config = CoreConfig PipeConfig + fromBios :: _ (_ xl _) fromBios = bios $ romMap <$> fromCore fromRgb = rgb $ ledMap <$> peripheral <*> fromCore (tx, fromUart) = uart rxIn $ uartMap <$> peripheral <*> fromCore @@ -97,7 +94,7 @@ lion rxIn = FromSoc topEntity :: "uart_rx" ::: Signal Lattice12Mhz Bit -> FromSoc Lattice12Mhz -topEntity = withClockResetEnable clk latticeRst enableGen lion +topEntity = withClockResetEnable clk latticeRst enableGen lion32 where clk = hf12Mhz (pure True :: Signal System Bool) (pure True :: Signal System Bool) diff --git a/lion-soc/src/Spi.hs b/lion-soc/src/Spi.hs index 52596a0..a333130 100644 --- a/lion-soc/src/Spi.hs +++ b/lion-soc/src/Spi.hs @@ -24,6 +24,7 @@ import Data.Monoid.Generic import qualified Ice40.Spi as S import Ice40.IO import Bus +import Lion.Util.Clash data SpiIO = SpiIO ("biwo" ::: Bit) ("bowi" ::: Bit) @@ -32,24 +33,24 @@ data SpiIO = SpiIO ("biwo" ::: Bit) deriving stock (Generic, Show, Eq) deriving anyclass NFDataX -data ToSysBus = ToSysBus +data ToSysBus xl = ToSysBus { _sbAckO :: Bool , _sbDatO :: BitVector 8 - , _fromCore :: BusIn 'Spi + , _fromCore :: BusIn xl 'Spi } makeLenses ''ToSysBus -data FromSysBus = FromSysBus +data FromSysBus xl = FromSysBus { _sbRWI :: First Bool , _sbStbI :: First Bool , _sbAdrI :: First (BitVector 8) , _sbDatI :: First (BitVector 8) - , _toCore :: First (BitVector 32) + , _toCore :: First (BitVector xl) } deriving stock (Generic, Show, Eq) deriving anyclass NFDataX - deriving Semigroup via GenericSemigroup FromSysBus - deriving Monoid via GenericMonoid FromSysBus + deriving Semigroup via GenericSemigroup (FromSysBus xl) + deriving Monoid via GenericMonoid (FromSysBus xl) makeLenses ''FromSysBus data SysBus = SysBus @@ -63,7 +64,7 @@ makeLenses ''SysBus mkSysBus :: SysBus mkSysBus = SysBus Nothing 0 -sysBusM :: RWS ToSysBus FromSysBus SysBus () +sysBusM :: KnownNat xl => RWS (ToSysBus xl) (FromSysBus xl) SysBus () sysBusM = do instr <- use sbInstr @@ -87,22 +88,23 @@ sysBusM = do Just _ -> return () -- busy, ignore command Nothing -> -- idle, execute command let isWrite = bitToBool $ wr!(16 :: Index 32) - adri = slice d15 d8 wr - dati = slice d7 d0 wr + adri = slice' d15 d8 wr + dati = slice' d7 d0 wr in sbInstr ?= if isWrite then (adri, Just dati) else (adri, Nothing) ToSpi $(bitPattern "0100") Nothing -> -- read received - scribe toCore . First . Just =<< uses sbRecv ((`shiftL` 16).zeroExtend) + scribe toCore . First . Just =<< uses sbRecv ((`shiftL` 16).zeroResize) _ -> -- read status, default instruction scribe toCore $ First $ Just $ if isJust instr then 0x01000000 else 0x00000000 sysBus - :: HiddenClockResetEnable dom - => Signal dom ToSysBus - -> Signal dom FromSysBus + :: KnownNat xl + => HiddenClockResetEnable dom + => Signal dom (ToSysBus xl) + -> Signal dom (FromSysBus xl) sysBus = mealy sysBusMealy mkSysBus where sysBusMealy s i = (s', o) @@ -111,9 +113,9 @@ sysBus = mealy sysBusMealy mkSysBus {-# NOINLINE spi #-} spi - :: HiddenClockResetEnable dom - => Signal dom (BusIn 'Spi) - -> Unbundled dom (SpiIO, BusOut 'Spi) + :: (HiddenClockResetEnable dom, KnownNat xl) + => Signal dom (BusIn xl 'Spi) + -> Unbundled dom (SpiIO, BusOut xl 'Spi) spi toSpi = (spiIO, fromSpi) where fromSpi = fmap (FromSpi . fromMaybe 0) $ register Nothing $ getFirst . _toCore <$> fromSysBus diff --git a/lion-soc/src/Spram.hs b/lion-soc/src/Spram.hs index 72c1eee..60b7eac 100644 --- a/lion-soc/src/Spram.hs +++ b/lion-soc/src/Spram.hs @@ -14,27 +14,27 @@ import Ice40.Spram import Bus spram - :: HiddenClockResetEnable dom - => Signal dom (BusIn 'Spram) - -> Signal dom (BusOut 'Spram) -spram busIn = FromSpram <$> ram32k32 addr dat msk we + :: (HiddenClockResetEnable dom, KnownNat xl) + => Signal dom (BusIn xl 'Spram) + -> Signal dom (BusOut xl 'Spram) +spram busIn = FromSpram <$> ram32k addr dat msk we where (addr, dat, msk, we) = unbundle $ busIn <&> \case ToSpram a d m w -> (a, d, m, w) -ram32k32 - :: HiddenClockResetEnable dom +ram32k :: forall dom xl + . (HiddenClockResetEnable dom, KnownNat xl) => Signal dom (BitVector 15) -- address - -> Signal dom (BitVector 32) -- dataIn - -> Signal dom (BitVector 8) -- maskWrEn + -> Signal dom (BitVector xl) -- dataIn + -> Signal dom (BitVector (Div xl 4)) -- maskWrEn -> Signal dom Bit -- wrEn - -> Signal dom (BitVector 32) -- dataOut -ram32k32 address dataIn maskWrEn wrEn = (++#) <$> dataOutH <*> dataOutL + -> Signal dom (BitVector xl) -- dataOut +ram32k address dataIn maskWrEn wrEn = resize . concatBitVector# <$> sequenceA dataOuts where - dataOutH = ram32k16 address dataInH maskWrEnH wrEn - dataOutL = ram32k16 address dataInL maskWrEnL wrEn - (dataInH, dataInL) = unbundle $ split <$> dataIn - (maskWrEnH, maskWrEnL) = unbundle $ split <$> maskWrEn + dataOuts :: Vec (Div xl 16) (Signal dom (BitVector 16)) + dataOuts = (\ u v -> ram32k16 address u v wrEn) <$> dataIns <*> maskWrEns + dataIns = unbundle $ unconcatBitVector# . resize <$> dataIn + maskWrEns = unbundle $ unconcatBitVector# . resize <$> maskWrEn ram32k16 :: HiddenClockResetEnable dom diff --git a/lion-soc/src/Uart.hs b/lion-soc/src/Uart.hs index a45ac45..d9166d3 100644 --- a/lion-soc/src/Uart.hs +++ b/lion-soc/src/Uart.hs @@ -12,8 +12,10 @@ import Clash.Prelude import qualified Bus as B import Control.Lens hiding (Index, Empty) import Control.Monad.RWS +import Data.Bool ( bool ) import Data.Maybe ( isJust, fromMaybe ) import Data.Monoid.Generic +import Lion.Util.Clash -- | uart register -- 31 - 24 : 23 - 16 : 15 - 8 : 7 - 0 @@ -26,8 +28,8 @@ import Data.Monoid.Generic -- bits 15 - 8 : receiver buffer -- read only -- reading this byte will reset the receiver -- bits 7 - 0 : transmitter buffer -- write only -- writing this byte will reset the transmitter -data ToUart = ToUart - { _fromBus :: B.BusIn 'B.Uart +data ToUart xl = ToUart + { _fromBus :: B.BusIn xl 'B.Uart , _rx :: Bit } makeLenses ''ToUart @@ -41,7 +43,7 @@ data RxFsm = RxIdle deriving anyclass NFDataX -- | Uart state -data Uart = Uart +data Uart xl = Uart { -- transmitter state _txIdx :: Index 10 -- ^ buffer bit index , _txBaud :: Index 625 -- ^ baud rate counter (19200 @ 12Mhz) @@ -51,14 +53,14 @@ data Uart = Uart , _rxIdx :: Index 8 -- ^ buffer index , _rxBaud :: Index 625 -- ^ baud rate counter (19200 @ 12Mhz) , _rxBuffer :: Vec 8 Bit -- ^ receiver data buffer - , _rxRecv :: Maybe (BitVector 32) -- ^ store received bytes for reading + , _rxRecv :: Maybe (BitVector xl) -- ^ store received bytes for reading } deriving stock (Generic, Show, Eq) deriving anyclass NFDataX makeLenses ''Uart -- | Construct a Uart -mkUart :: Uart +mkUart :: Uart xl mkUart = Uart { -- transmitter state _txIdx = 0 @@ -73,17 +75,17 @@ mkUart = Uart } -- | Uart output -data FromUart = FromUart +data FromUart xl = FromUart { _tx :: First Bit - , _toCore :: First (BitVector 32) + , _toCore :: First (BitVector xl) } deriving stock (Generic, Show, Eq) deriving anyclass NFDataX - deriving Semigroup via GenericSemigroup FromUart - deriving Monoid via GenericMonoid FromUart + deriving Semigroup via GenericSemigroup (FromUart xl) + deriving Monoid via GenericMonoid (FromUart xl) makeLenses ''FromUart -uartM :: RWS ToUart FromUart Uart () -- ^ uart monadic action +uartM :: KnownNat xl => RWS (ToUart xl) (FromUart xl) (Uart xl) () -- ^ uart monadic action uartM = do -- transmit bufferM <- use txBuffer @@ -107,8 +109,8 @@ uartM = do _ -> return () -- read status - rxS <- uses rxRecv $ boolToBV . isJust - let txS = boolToBV $ isJust bufferM + rxS <- uses rxRecv $ bool 0 1 . isJust + let txS = bool 0 1 $ isJust bufferM status = (rxS `shiftL` 1) .|. txS scribe toCore $ First $ Just $ status `shiftL` 16 @@ -137,21 +139,21 @@ uartM = do RxStop -> do ctr <- rxBaud <<%= increment when (ctr == maxBound) $ do - rxRecv <~ uses rxBuffer (Just . (`shiftL` 8) . zeroExtend . v2bv) + rxRecv <~ uses rxBuffer (Just . (`shiftL` 8) . zeroResize . v2bv) rxFsm %= increment where frame b = (1 :: BitVector 1) ++# b ++# (0 :: BitVector 1) -uartMealy :: Uart -> ToUart -> (Uart, FromUart) +uartMealy :: KnownNat xl => Uart xl -> ToUart xl -> (Uart xl, FromUart xl) uartMealy s i = (s', o) where (_, s', o) = runRWS uartM i s uart - :: HiddenClockResetEnable dom + :: (HiddenClockResetEnable dom, KnownNat xl) => Signal dom Bit -- ^ uart rx - -> Signal dom (B.BusIn 'B.Uart) -- ^ soc bus - -> Unbundled dom (Bit, B.BusOut 'B.Uart) -- ^ (uart tx, toCore) + -> Signal dom (B.BusIn xl 'B.Uart) -- ^ soc bus + -> Unbundled dom (Bit, B.BusOut xl 'B.Uart) -- ^ (uart tx, toCore) uart rxIn bus = (txOut, B.FromUart <$> uartOut) where uartOut = register 0 $ fromMaybe 0 . getFirst . _toCore <$> fromUart diff --git a/lion.cabal b/lion.cabal index 7441c00..355b24c 100644 --- a/lion.cabal +++ b/lion.cabal @@ -21,10 +21,10 @@ source-repository head library exposed-modules: Lion.Core , Lion.Rvfi + , Lion.Util.Clash other-modules: Lion.Alu , Lion.Instruction , Lion.Pipe - , Lion.Util.Clash hs-source-dirs: src default-language: Haskell2010 build-depends: diff --git a/src/Lion/Util/Clash.hs b/src/Lion/Util/Clash.hs index d8e58b5..ebddf8e 100644 --- a/src/Lion/Util/Clash.hs +++ b/src/Lion/Util/Clash.hs @@ -14,3 +14,6 @@ sign = unpack concatReplicateI :: forall m n . (KnownNat m, KnownNat n, 1 <= m) => BitVector m -> BitVector n concatReplicateI = resize . concatBitVector# . replicate (SNat :: SNat (Div n m + 1)) + +slice' :: (BitPack a, KnownNat m) => SNat m -> SNat n -> a -> BitVector ((m + 1) - n) +slice' m n = slice m n . resizeTo (addSNat m d1) . pack