diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,21 +1,39 @@ # Changelog for [`clash-prelude` package](http://hackage.haskell.org/package/clash-prelude) -## 0.11.2 *April 25th 2017* +## 0.99 *March 31st 2018* +* Major API overhaul: check the migration guide at the end of `Clash.Tutorial` * New features: + * Explicit clock and reset arguments + * Rename `CLaSH` to `Clash` + * Implicit/`Hidden` clock and reset arguments using a combination of + `reflection` and `ImplicitParams`. + * Large overhaul of `TopEntity` annotations + * PLL and other clock sources can now be instantiated using regular functions: + `Clash.Intel.ClockGen` and `Clash.Xilinx.ClockGen`. + * DDR registers: + * Generic/ASIC: `Clash.Explicit.DDR` + * Intel: `Clash.Intel.DDR` + * Xilinx: `Clash.Intel.Xilinx` + * `Bit` is now a `newtype` instead of a `type` synonym and will be mapped to + a HDL scalar instead of an array of one (e.g `std_logic` instead of + `std_logic_vector(0 downto 0)`) + +## 0.11.2 +* New features: * Add `riseEvery`: Give a pulse every @n@ clock cycles. (Thanks to @thoughtpolice) * Add `oscillate`: Oscillate a @'Bool'@ with a given half-period of cycles. (Thanks to @thoughtpolice) * Fixes bugs: * Eagerness bug in `regEn` [#104](https://github.com/clash-lang/clash-prelude/issues/104) (Thanks to @cbiffle) -## 0.11.1 *April 10th 2017* +## 0.11.1 * Changes: * Bundle instance for `()` behaves like a product-type instance [#96](https://github.com/clash-lang/clash-prelude/issues/96) * Fixes bugs: * Ensure that `fold` gets correctly type-applied in `Vec.==` [#202](https://github.com/clash-lang/clash-compiler/issues/202) -## 0.11 *January 16th 2017* +## 0.11 * New features: - * `CLaSH.XException`: a module defining an exception representing uninitialised values. Additionally adds the `ShowX` class which has methods that print values as "X" where they would normally raise an `XException` exception. + * `CLaSH.XException`: a module defining an exception representing uninitialised values. Additionally adds the `ShowX` class which has methods that prints values as "X" where they would normally raise an `XException` exception. * Add `BNat` (and supporting functions) to `CLaSH.Promoted.Nat`: base-2 encoded natural numbers. * Add `divSNat` and `logBaseSNat` to `CLaSH.Promoted.Nat`: division and logarithm for singleton natural numbers. * Add `predUNat` and `subUNat` to `CLaSH.Promoted.Nat`: predecessor and subtraction for unary-encoded natural numbers. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,5 +1,6 @@ Copyright (c) 2013-2016, University of Twente, - 2017, QBayLogic + 2016-2017, Myrtle Software Ltd, + 2017 , QBayLogic, Google Inc. All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/benchmarks/BenchBitVector.hs b/benchmarks/BenchBitVector.hs --- a/benchmarks/BenchBitVector.hs +++ b/benchmarks/BenchBitVector.hs @@ -6,8 +6,8 @@ module BenchBitVector where -import CLaSH.Sized.Internal.BitVector -import CLaSH.Class.Num +import Clash.Sized.Internal.BitVector +import Clash.Class.Num import GHC.TypeLits (type (*)) import Criterion (Benchmark, env, bench, nf) import Language.Haskell.TH.Syntax (lift) diff --git a/benchmarks/BenchFixed.hs b/benchmarks/BenchFixed.hs --- a/benchmarks/BenchFixed.hs +++ b/benchmarks/BenchFixed.hs @@ -6,9 +6,9 @@ module BenchFixed where -import CLaSH.Class.Num -import CLaSH.Sized.Fixed -import CLaSH.Sized.Unsigned +import Clash.Class.Num +import Clash.Sized.Fixed +import Clash.Sized.Unsigned import Criterion (Benchmark, env, bench, nf) import Language.Haskell.TH.Syntax (lift) diff --git a/benchmarks/BenchSigned.hs b/benchmarks/BenchSigned.hs --- a/benchmarks/BenchSigned.hs +++ b/benchmarks/BenchSigned.hs @@ -6,8 +6,8 @@ module BenchSigned where -import CLaSH.Sized.BitVector -import CLaSH.Sized.Internal.Signed +import Clash.Sized.BitVector +import Clash.Sized.Internal.Signed import Criterion (Benchmark, env, bench, nf) import Language.Haskell.TH.Syntax (lift) diff --git a/clash-prelude.cabal b/clash-prelude.cabal --- a/clash-prelude.cabal +++ b/clash-prelude.cabal @@ -1,5 +1,5 @@ Name: clash-prelude -Version: 0.11.2 +Version: 0.99 Synopsis: CAES Language for Synchronous Hardware - Prelude library Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that @@ -30,14 +30,17 @@ . To use the library: . - * Import "CLaSH.Prelude" + * Import "Clash.Prelude" . - * Additionally import "CLaSH.Prelude.Explicit" if you want to design - explicitly clocked circuits in a multi-clock setting + * Alternatively, if you want to explicitly route clock and reset ports, + for more straightforward multi-clock designs, you can import the + "Clash.Explicit.Prelude" module. Note that you should not import + "Clash.Prelude" and "Clash.Explicit.Prelude" at the same time as they + have overlapping definitions. . - A preliminary version of a tutorial can be found in "CLaSH.Tutorial", for a - general overview of the library you should however check out "CLaSH.Prelude". - Some circuit examples can be found in "CLaSH.Examples". + A preliminary version of a tutorial can be found in "Clash.Tutorial", for a + general overview of the library you should however check out "Clash.Prelude". + Some circuit examples can be found in "Clash.Examples". Homepage: http://www.clash-lang.org/ bug-reports: http://github.com/clash-lang/clash-prelude/issues License: BSD2 @@ -45,7 +48,8 @@ Author: Christiaan Baaij Maintainer: Christiaan Baaij Copyright: Copyright © 2013-2016, University of Twente, - 2017, QBayLogic + 2016-2017, Myrtle Software Ltd, + 2017 , QBayLogic, Google Inc. Category: Hardware Build-type: Simple @@ -55,7 +59,8 @@ extra-doc-files: doc/*.svg -Cabal-version: >=1.10 +Cabal-version: 1.18 +Tested-with: GHC == 8.2.2, GHC == 8.4.1, GHC == 8.5 source-repository head type: git @@ -73,75 +78,87 @@ default: True manual: True -flag doclinks - description: - Create hyperlinks to non-dependent packages using `-fdoclinks`. - default: False - manual: True - Library HS-Source-Dirs: src default-language: Haskell2010 - ghc-options: -Wall -fexpose-all-unfoldings + ghc-options: -Wall -fexpose-all-unfoldings -fno-worker-wrapper - Exposed-modules: CLaSH.Annotations.TopEntity - CLaSH.Annotations.Primitive + Exposed-modules: Clash.Annotations.TopEntity + Clash.Annotations.Primitive - CLaSH.Class.BitPack - CLaSH.Class.Num - CLaSH.Class.Resize + Clash.Class.BitPack + Clash.Class.Num + Clash.Class.Resize - CLaSH.NamedTypes + Clash.Explicit.BlockRam + Clash.Explicit.BlockRam.File + Clash.Explicit.DDR + Clash.Explicit.Mealy + Clash.Explicit.Moore + Clash.Explicit.RAM + Clash.Explicit.ROM + Clash.Explicit.ROM.File + Clash.Explicit.Prelude + Clash.Explicit.Prelude.Safe + Clash.Explicit.Signal + Clash.Explicit.Signal.Delayed + Clash.Explicit.Synchronizer + Clash.Explicit.Testbench - CLaSH.Prelude - CLaSH.Prelude.BitIndex - CLaSH.Prelude.BitReduction - CLaSH.Prelude.BlockRam - CLaSH.Prelude.BlockRam.File - CLaSH.Prelude.DataFlow - CLaSH.Prelude.Explicit - CLaSH.Prelude.Explicit.Safe - CLaSH.Prelude.Mealy - CLaSH.Prelude.Moore - CLaSH.Prelude.RAM - CLaSH.Prelude.ROM - CLaSH.Prelude.ROM.File - CLaSH.Prelude.Safe - CLaSH.Prelude.Synchronizer - CLaSH.Prelude.Testbench + Clash.Hidden - CLaSH.Promoted.Nat - CLaSH.Promoted.Nat.Literals - CLaSH.Promoted.Nat.TH - CLaSH.Promoted.Nat.Unsafe - CLaSH.Promoted.Symbol + Clash.Intel.ClockGen + Clash.Intel.DDR - CLaSH.Signal - CLaSH.Signal.Bundle - CLaSH.Signal.Delayed - CLaSH.Signal.Delayed.Explicit - CLaSH.Signal.Explicit - CLaSH.Signal.Internal + Clash.NamedTypes - CLaSH.Sized.BitVector - CLaSH.Sized.Fixed - CLaSH.Sized.Index - CLaSH.Sized.RTree - CLaSH.Sized.Signed - CLaSH.Sized.Unsigned - CLaSH.Sized.Vector + Clash.Prelude + Clash.Prelude.BitIndex + Clash.Prelude.BitReduction + Clash.Prelude.BlockRam + Clash.Prelude.BlockRam.File + Clash.Prelude.DataFlow + Clash.Prelude.Mealy + Clash.Prelude.Moore + Clash.Prelude.RAM + Clash.Prelude.ROM + Clash.Prelude.ROM.File + Clash.Prelude.Safe + Clash.Prelude.Testbench - CLaSH.Sized.Internal.BitVector - CLaSH.Sized.Internal.Index - CLaSH.Sized.Internal.Signed - CLaSH.Sized.Internal.Unsigned + Clash.Promoted.Nat + Clash.Promoted.Nat.Literals + Clash.Promoted.Nat.TH + Clash.Promoted.Nat.Unsafe + Clash.Promoted.Symbol - CLaSH.XException + Clash.Signal + Clash.Signal.Bundle + Clash.Signal.Delayed + Clash.Signal.Internal - CLaSH.Tutorial - CLaSH.Examples + Clash.Sized.BitVector + Clash.Sized.Fixed + Clash.Sized.Index + Clash.Sized.RTree + Clash.Sized.Signed + Clash.Sized.Unsigned + Clash.Sized.Vector + Clash.Sized.Internal.BitVector + Clash.Sized.Internal.Index + Clash.Sized.Internal.Signed + Clash.Sized.Internal.Unsigned + + Clash.XException + + Clash.Xilinx.ClockGen + Clash.Xilinx.DDR + + Clash.Tutorial + Clash.Examples + other-extensions: CPP BangPatterns ConstraintKinds @@ -172,6 +189,7 @@ Build-depends: array >= 0.5.1.0 && < 0.6, base >= 4.8.0.0 && < 5, + bifunctors >= 5.4.0 && < 6.0, constraints >= 0.8 && < 1.0, data-binary-ieee754 >= 0.4.4 && < 0.6, data-default >= 0.5.3 && < 0.8, @@ -179,20 +197,17 @@ deepseq >= 1.4.1.0 && < 1.5, ghc-prim >= 0.3.1.0 && < 0.6, ghc-typelits-extra >= 0.2.1 && < 0.3, - ghc-typelits-knownnat >= 0.2.2 && < 0.3, + ghc-typelits-knownnat >= 0.2.2 && < 0.5, ghc-typelits-natnormalise >= 0.4.2 && < 0.6, half >= 0.2.2.3 && < 1.0, - lens >= 4.9 && < 4.16, - QuickCheck >= 2.7 && < 2.10, + lens >= 4.9 && < 4.17, + QuickCheck >= 2.7 && < 2.12, reflection >= 2 && < 2.2, singletons >= 1.0 && < 3.0, - template-haskell >= 2.9.0.0 && < 2.12, + template-haskell >= 2.12.0.0 && < 2.14, + transformers >= 0.4.2.0 && < 0.6, vector >= 0.11 && < 1.0 - if flag(doclinks) - CPP-Options: -DDOCLINKS - build-depends: transformers >= 0.4.2.0 - test-suite doctests type: exitcode-stdio-1.0 default-language: Haskell2010 @@ -205,13 +220,13 @@ else build-depends: base >= 4 && < 5, - doctest >= 0.9.1 && < 0.12 + doctest >= 0.9.1 && < 0.16 benchmark benchmark-clash-prelude type: exitcode-stdio-1.0 default-language: Haskell2010 main-is: benchmark-main.hs - ghc-options: -O2 -Wall + ghc-options: -Wall hs-source-dirs: benchmarks if !flag(benchmarks) @@ -220,9 +235,9 @@ build-depends: base >= 4 && < 5, clash-prelude, - criterion >= 1.1.1.0 && < 1.2, + criterion >= 1.3.0.0 && < 1.6, deepseq >= 1.4.0.1 && < 1.5, - template-haskell >= 2.9.0.0 && < 2.12 + template-haskell >= 2.9.0.0 && < 2.14 Other-Modules: BenchBitVector BenchFixed diff --git a/src/CLaSH/Annotations/Primitive.hs b/src/CLaSH/Annotations/Primitive.hs deleted file mode 100644 --- a/src/CLaSH/Annotations/Primitive.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-| -Copyright : (C) 2017, QBayLogic -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij --} - -{-# LANGUAGE DeriveDataTypeable #-} - -{-# LANGUAGE Safe #-} - -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Annotations.Primitive where - -import Data.Data - -data HDL - = SystemVerilog - | Verilog - | VHDL - deriving (Eq, Show, Read, Data) - -data Primitive - = Primitive HDL FilePath - deriving (Show, Read, Data) diff --git a/src/CLaSH/Annotations/TopEntity.hs b/src/CLaSH/Annotations/TopEntity.hs deleted file mode 100644 --- a/src/CLaSH/Annotations/TopEntity.hs +++ /dev/null @@ -1,443 +0,0 @@ -{-| -Copyright : (C) 2015-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij - -The 'TopEntity' annotations described in this module make it easier to put your -design on an FPGA. - -We can exert some control how the top level function is created by the CλaSH -compiler by annotating the @topEntity@ function with a 'TopEntity' annotation. -You apply these annotations using the @ANN@ pragma like so: - -@ -{\-\# ANN topEntity (TopEntity {t_name = ..., ... }) \#-\} -topEntity x = ... -@ - -For example, given the following specification: - -@ -topEntity :: Signal Bit -> Signal (BitVector 8) -topEntity key1 = leds - where - key1R = isRising 1 key1 - leds = mealy blinkerT (1,False,0) key1R - -blinkerT (leds,mode,cntr) key1R = ((leds',mode',cntr'),leds) - where - -- clock frequency = 50e6 (50 MHz) - -- led update rate = 333e-3 (every 333ms) - cnt_max = 16650000 -- 50e6 * 333e-3 - - cntr' | cntr == cnt_max = 0 - | otherwise = cntr + 1 - - mode' | key1R = not mode - | otherwise = mode - - leds' | cntr == 0 = if mode then complement leds - else rotateL leds 1 - | otherwise = leds -@ - -The CλaSH compiler will normally generate the following @topEntity.vhdl@ file: - -@ --- Automatically generated VHDL -library IEEE; -use IEEE.STD_LOGIC_1164.ALL; -use IEEE.NUMERIC_STD.ALL; -use IEEE.MATH_REAL.ALL; -use work.all; -use work.types.all; - -entity topEntity is - port(input_0 : in std_logic_vector(0 downto 0); - -- clock - system1000 : in std_logic; - -- asynchronous reset: active low - system1000_rstn : in std_logic; - output_0 : out std_logic_vector(7 downto 0)); -end; - -architecture structural of topEntity is -begin - topEntity_0_inst : entity topEntity_0 - port map - (key1_i1 => input_0 - ,system1000 => system1000 - ,system1000_rstn => system1000_rstn - ,topLet_o => output_0); -end; -@ - -However, if we add the following 'TopEntity' annotation in the file: - -@ -{\-\# ANN topEntity - ('defTop' - { t_name = "blinker" - , t_inputs = [\"KEY1\"] - , t_outputs = [\"LED\"] - , t_extraIn = [ (\"CLOCK_50\", 1) - , (\"KEY0\" , 1) - ] - , t_clocks = [ 'altpll' "altpll50" "CLOCK_50(0)" "not KEY0(0)" ] - }) \#-\} -@ - -The CλaSH compiler will generate the following @blinker.vhdl@ file instead: - -@ --- Automatically generated VHDL -library IEEE; -use IEEE.STD_LOGIC_1164.ALL; -use IEEE.NUMERIC_STD.ALL; -use IEEE.MATH_REAL.ALL; -use work.all; -use work.types.all; - -entity blinker is - port(KEY1 : in std_logic_vector(0 downto 0); - CLOCK_50 : in std_logic_vector(0 downto 0); - KEY0 : in std_logic_vector(0 downto 0); - LED : out std_logic_vector(7 downto 0)); -end; - -architecture structural of blinker is - signal system1000 : std_logic; - signal system1000_rstn : std_logic; - signal altpll50_locked : std_logic; -begin - altpll50_inst : entity altpll50 - port map - (inclk0 => CLOCK_50(0) - ,c0 => system1000 - ,areset => not KEY0(0) - ,locked => altpll50_locked); - - -- reset system1000_rstn is asynchronously asserted, but synchronously de-asserted - resetSync_n_0 : block - signal n_1 : std_logic; - signal n_2 : std_logic; - begin - process(system1000,altpll50_locked) - begin - if altpll50_locked = '0' then - n_1 <= '0'; - n_2 <= '0'; - elsif rising_edge(system1000) then - n_1 <= '1'; - n_2 <= n_1; - end if; - end process; - - system1000_rstn <= n_2; - end block; - - topEntity_0_inst : entity topEntity_0 - port map - (key1_i1 => KEY1 - ,system1000 => system1000 - ,system1000_rstn => system1000_rstn - ,topLet_o => LED); -end; -@ - -Where we now have: - -* A top-level component that is called @blinker@. -* Inputs and outputs that have a /user/-chosen name: @KEY1@, @LED@, etc. -* An instantiated - component providing a stable clock signal from the free-running clock pin - @CLOCK_50@. -* A reset that is /asynchronously/ asserted by the @lock@ signal originating from - the PLL, meaning that your design is kept in reset until the PLL is - providing a stable clock. - The reset is additionally /synchronously/ de-asserted to prevent - - of your design due to unlucky timing of the de-assertion of the reset. - -See the documentation of 'TopEntity' for the meaning of all its fields. --} - -{-# LANGUAGE DeriveDataTypeable #-} - -{-# LANGUAGE Safe #-} - -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Annotations.TopEntity - ( -- * Data types - TopEntity (..) - , ClockSource (..) - -- * Convenience functions - , defTop - -- ** Altera clock sources - , altpll - , alteraPll - -- ** Xilinx clock sources - , clockWizard - , clockWizardDifferential - ) -where - -import Data.Data -import CLaSH.Signal.Explicit (systemClock) - --- | TopEntity annotation -data TopEntity - = TopEntity - { t_name :: String -- ^ The name the top-level component should - -- have, put in a correspondingly named file. - , t_inputs :: [String] -- ^ List of names that are assigned in-order - -- to the inputs of the component. - , t_outputs :: [String] -- ^ List of names that are assigned in-order - -- to the outputs of the component. - , t_extraIn :: [(String,Int)] - -- ^ Extra input ports, where every tuple holds the name of the input port and - -- the number of bits are used for that input port. - -- - -- So given a bit-width @n@, the port has type: - -- - -- * __VHDL__: @std_logic_vector (n-1 downto 0)@ - -- * __Verilog__: @[n-1:0]@ - -- * __SystemVerilog__: @logic [n-1:0]@ - , t_extraOut :: [(String,Int)] - -- ^ Extra output ports, where every tuple holds the name of the output port - -- and the number of bits are used for that output port. - -- - -- So given a bit-width @n@, the port has type: - -- - -- * __VHDL__: @std_logic_vector (n-1 downto 0)@ - -- * __Verilog__: @[n-1:0]@ - -- * __SystemVerilog__: @logic [n-1:0]@ - , t_clocks :: [ClockSource] -- ^ List of clock sources - } - deriving (Data,Show,Read) - --- | A clock source -data ClockSource - = ClockSource - { c_name :: String -- ^ Component name - , c_inp :: [(String,String)] -- ^ Zero..two times: @(Input port, clock pin/expression)@ - , c_outp :: [(String,String)] - -- ^ List of @(Output port, clock)@ - -- - -- The best way to create the 'String' representing the name of the clock is - -- to 'show' the corresponding singleton clock ('CLaSH.Signal.Explicit.sclock'). - -- - -- So given that you your design is synchronised to the 'CLaSH.Signal.Explicit.SystemClock' - -- and some another clock @ClkA@ - -- - -- > type ClkA = 'Clk "clkA" 2000 - -- - -- the best way to connect output clock ports is by doing: - -- - -- > ClockSource { .. - -- > , c_outp = [("c0", show (sclock :: SClock SystemClock)) - -- > ,("c1", show (sclock :: SClock ClkA)) - -- > ] - -- > , .. - -- > } - , c_reset :: Maybe (String,String) -- ^ optional: @(Reset port, reset pin/expression)@ - , c_lock :: String -- ^ Output port name of the clock source - -- component indicating that the clock signal - -- is stable. - , c_sync :: Bool - -- ^ Indicates whether the components synchronised by the clocks generated by - -- this clock source are pulled out of reset simultaneously. - -- - -- The recommended setting if 'False'. - -- - -- When 'c_sync' is set to 'False', the compiler generates reset synchronisers - -- which ensure that each component is synchronously pulled out of reset, - -- preventing - -- introduced by unlucky timing of the reset de-assertion. - -- - -- When 'c_sync' is set to 'True' those reset synchronisers are not generated - -- and there is change for reset-induced metastability. - } - deriving (Data,Show,Read) - --- | Default 'TopEntity' which has no clocks, and no specified names for the --- input and output ports. Also has no clock sources: --- --- >>> defTop --- TopEntity {t_name = "topentity", t_inputs = [], t_outputs = [], t_extraIn = [], t_extraOut = [], t_clocks = []} -defTop :: TopEntity -defTop = TopEntity - { t_name = "topentity" - , t_inputs = [] - , t_outputs = [] - , t_extraIn = [] - , t_extraOut = [] - , t_clocks = [] - } - --- | A clock source that corresponds to the Altera/Quartus \"ALTPLL\" component --- with default settings to provide a stable 'systemClock'. --- --- >>> altpll "altpll50" "CLOCK(0)" "not KEY(0)" --- ClockSource {c_name = "altpll50", c_inp = [("inclk0","CLOCK(0)")], c_outp = [("c0","system1000")], c_reset = Just ("areset","not KEY(0)"), c_lock = "locked", c_sync = False} --- --- Will generate the following VHDL: --- --- > altpll50_inst : entity altpll50 --- > port map --- > (inclk0 => CLOCK_50(0) --- > ,c0 => system1000 --- > ,areset => not KEY0(0) --- > ,locked => altpll50_locked); --- --- If you are however generating (System)Verilog you should write: --- --- >>> altpll "altpll50" "CLOCK[0]" "~ KEY[0]" --- ClockSource {c_name = "altpll50", c_inp = [("inclk0","CLOCK[0]")], c_outp = [("c0","system1000")], c_reset = Just ("areset","~ KEY[0]"), c_lock = "locked", c_sync = False} --- --- so that the following (System)Verilog is created: --- --- > altpll50 altpll50_inst --- > (.inclk0 (CLOCK_50[0]) --- > ,.c0 (system1000) --- > ,.areset (~ KEY0[0]) --- > ,.locked (altpll50_locked)); -altpll :: String -- ^ Name of the component. - -> String -- ^ Clock Pin/Expression of the free running clock. - -> String -- ^ Reset Pin/Expression controlling the reset of the PLL. - -> ClockSource -altpll pllName clkExpr resExpr = ClockSource - { c_name = pllName - , c_inp = pure ("inclk0",clkExpr) - , c_outp = [("c0",show systemClock)] - , c_reset = Just ("areset",resExpr) - , c_lock = "locked" - , c_sync = False - } - --- | A clock source that corresponds to the Altera \"Altera PLL\" component --- with default settings to provide a stable 'systemClock'. --- --- >>> alteraPll "alteraPll50" "CLOCK(0)" "not KEY(0)" --- ClockSource {c_name = "alteraPll50", c_inp = [("refclk","CLOCK(0)")], c_outp = [("outclk_0","system1000")], c_reset = Just ("rst","not KEY(0)"), c_lock = "locked", c_sync = False} --- --- Will generate the following VHDL: --- --- > alteraPll50_inst : entity alteraPll --- > port map --- > (refclk => CLOCK_50(0) --- > ,outclk_0 => system1000 --- > ,rst => not KEY0(0) --- > ,locked => alteraPll50_locked); --- --- If you are however generating (System)Verilog you should write: --- --- >>> alteraPll "alteraPll50" "CLOCK[0]" "~ KEY[0]" --- ClockSource {c_name = "alteraPll50", c_inp = [("refclk","CLOCK[0]")], c_outp = [("outclk_0","system1000")], c_reset = Just ("rst","~ KEY[0]"), c_lock = "locked", c_sync = False} --- --- so that the following (System)Verilog is created: --- --- > alteraPll50 alteraPll50_inst --- > (.refclk (CLOCK_50[0]) --- > ,.outclk_0 (system1000) --- > ,.rst (~ KEY0[0]) --- > ,.locked (alteraPll50_locked)); -alteraPll :: String -- ^ Name of the component. - -> String -- ^ Clock Pin/Expression of the free running clock. - -> String -- ^ Reset Pin/Expression controlling the reset of the PLL. - -> ClockSource -alteraPll pllName clkExpr resExpr = ClockSource - { c_name = pllName - , c_inp = pure ("refclk",clkExpr) - , c_outp = [("outclk_0",show systemClock)] - , c_reset = Just ("rst",resExpr) - , c_lock = "locked" - , c_sync = False - } - --- | A clock source that corresponds to the Xilinx PLL/MMCM component created --- with the \"Clock Wizard\", with settings to provide a stable 'systemClock'. --- --- >>> clockWizard "clkwiz50" "CLOCK(0)" "not KEY(0)" --- ClockSource {c_name = "clkwiz50", c_inp = [("CLK_IN1","CLOCK(0)")], c_outp = [("CLK_OUT1","system1000")], c_reset = Just ("RESET","not KEY(0)"), c_lock = "LOCKED", c_sync = False} --- --- Will generate the following VHDL: --- --- > clkwiz50_inst : entity clkwiz50 --- > port map --- > (CLK_IN1 => CLOCK(0) --- > ,CLK_OUT1 => system1000 --- > ,RESET => not KEY(0) --- > ,LOCKED => clkwiz50_locked); --- --- If you are however generating (System)Verilog you should write: --- --- >>> clockWizard "clkwiz50" "CLOCK[0]" "~ KEY[0]" --- ClockSource {c_name = "clkwiz50", c_inp = [("CLK_IN1","CLOCK[0]")], c_outp = [("CLK_OUT1","system1000")], c_reset = Just ("RESET","~ KEY[0]"), c_lock = "LOCKED", c_sync = False} --- --- so that the following (System)Verilog is created: --- --- > clkwiz50 clkwiz50_inst --- > (.CLK_IN1 (CLOCK[0]) --- > ,.CLK_OUT1 (system1000) --- > ,.RESET (~ KEY[0]) --- > ,.LOCKED (clkwiz50_locked)); -clockWizard :: String -- ^ Name of the component. - -> String -- ^ Clock Pin/Expression of the free running clock. - -> String -- ^ Reset Pin/Expression controlling the reset of the PLL. - -> ClockSource -clockWizard pllName clkExpr resExpr = ClockSource - { c_name = pllName - , c_inp = pure ("CLK_IN1",clkExpr) - , c_outp = [("CLK_OUT1",show systemClock)] - , c_reset = Just ("RESET",resExpr) - , c_lock = "LOCKED" - , c_sync = False - } - --- | A clock source that corresponds to the Xilinx PLL/MMCM component created --- with the \"Clock Wizard\", with settings to provide a stable 'systemClock' --- from differential free-running inputs. --- --- >>> clockWizardDifferential "clkwiz50" "CLOCK(0)" "CLOCK(1)" "not KEY(0)" --- ClockSource {c_name = "clkwiz50", c_inp = [("CLK_IN1_D_clk_n","CLOCK(0)"),("CLK_IN1_D_clk_p","CLOCK(1)")], c_outp = [("CLK_OUT1","system1000")], c_reset = Just ("RESET","not KEY(0)"), c_lock = "LOCKED", c_sync = False} --- --- Will generate the following VHDL: --- --- > clkwiz50_inst : entity clkwiz50 --- > port map --- > (CLK_IN1_D_clk_n => CLOCK(0) --- > ,CLK_IN1_D_clk_p => CLOCK(1) --- > ,CLK_OUT1 => system1000 --- > ,RESET => not KEY(0) --- > ,LOCKED => clkwiz50_locked); --- --- If you are however generating (System)Verilog you should write: --- --- >>> clockWizardDifferential "clkwiz50" "CLOCK[0]" "CLOCK[1]" "~ KEY[0]" --- ClockSource {c_name = "clkwiz50", c_inp = [("CLK_IN1_D_clk_n","CLOCK[0]"),("CLK_IN1_D_clk_p","CLOCK[1]")], c_outp = [("CLK_OUT1","system1000")], c_reset = Just ("RESET","~ KEY[0]"), c_lock = "LOCKED", c_sync = False} --- --- so that the following (System)Verilog is created: --- --- > clkwiz50 clkwiz50_inst --- > (.CLK_IN1_D_clk_n (CLOCK[0]) --- > ,.CLK_IN1_D_clk_p (CLOCK[1]) --- > ,.CLK_OUT1 (system1000) --- > ,.RESET (~ KEY[0]) --- > ,.LOCKED (clkwiz50_locked)); -clockWizardDifferential :: String -- ^ Name of the component. - -> String -- ^ Clock Pin/Expression of the differential free running clock, negative phase. - -> String -- ^ Clock Pin/Expression of the differential free running clock, positive phase. - -> String -- ^ Reset Pin/Expression controlling the reset of the PLL. - -> ClockSource -clockWizardDifferential pllName clkExpr_n clkExpr_p resExpr = ClockSource - { c_name = pllName - , c_inp = [ ("CLK_IN1_D_clk_n",clkExpr_n) - , ("CLK_IN1_D_clk_p",clkExpr_p) - ] - , c_outp = [("CLK_OUT1",show systemClock)] - , c_reset = Just ("RESET",resExpr) - , c_lock = "LOCKED" - , c_sync = False - } diff --git a/src/CLaSH/Class/BitPack.hs b/src/CLaSH/Class/BitPack.hs deleted file mode 100644 --- a/src/CLaSH/Class/BitPack.hs +++ /dev/null @@ -1,249 +0,0 @@ -{-| -Copyright : (C) 2013-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - -{-# LANGUAGE Trustworthy #-} - -{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} -{-# OPTIONS_HADDOCK show-extensions #-} - -#include "MachDeps.h" - -module CLaSH.Class.BitPack - ( BitPack (..) - , bitCoerce - , boolToBV - ) -where - -import Data.Binary.IEEE754 (doubleToWord, floatToWord, wordToDouble, - wordToFloat) -import Data.Int -import Data.Word -import Foreign.C.Types (CUShort) -import GHC.TypeLits (KnownNat, Nat, type (+)) -import Numeric.Half (Half (..)) -import Prelude hiding (map) - -import CLaSH.Class.Resize (zeroExtend) -import CLaSH.Sized.BitVector (BitVector, (++#), high, low) -import CLaSH.Sized.Internal.BitVector (unsafeToInteger, split#) - -{- $setup ->>> :set -XDataKinds ->>> import CLaSH.Prelude --} - --- | Convert to and from a 'BitVector' -class BitPack a where - -- | Number of 'CLaSH.Sized.BitVector.Bit's needed to represents elements - -- of type @a@ - type BitSize a :: Nat - -- | Convert element of type @a@ to a 'BitVector' - -- - -- >>> pack (-5 :: Signed 6) - -- 11_1011 - pack :: a -> BitVector (BitSize a) - -- | Convert a 'BitVector' to an element of type @a@ - -- - -- >>> pack (-5 :: Signed 6) - -- 11_1011 - -- >>> let x = pack (-5 :: Signed 6) - -- >>> unpack x :: Unsigned 6 - -- 59 - -- >>> pack (59 :: Unsigned 6) - -- 11_1011 - unpack :: BitVector (BitSize a) -> a - -{-# INLINE bitCoerce #-} --- | Coerce a value from one type to another through its bit representation. --- --- >>> pack (-5 :: Signed 6) --- 11_1011 --- >>> bitCoerce (-5 :: Signed 6) :: Unsigned 6 --- 59 --- >>> pack (59 :: Unsigned 6) --- 11_1011 -bitCoerce :: (BitPack a, BitPack b, BitSize a ~ BitSize b) - => a - -> b -bitCoerce = unpack . pack - -instance BitPack Bool where - type BitSize Bool = 1 - pack True = high - pack False = low - - unpack bv = if bv == high then True else False - -instance BitPack (BitVector n) where - type BitSize (BitVector n) = n - pack v = v - unpack v = v - -instance BitPack Int where - type BitSize Int = WORD_SIZE_IN_BITS - pack = fromIntegral - unpack = fromIntegral - -instance BitPack Int8 where - type BitSize Int8 = 8 - pack = fromIntegral - unpack = fromIntegral - -instance BitPack Int16 where - type BitSize Int16 = 16 - pack = fromIntegral - unpack = fromIntegral - -instance BitPack Int32 where - type BitSize Int32 = 32 - pack = fromIntegral - unpack = fromIntegral - -#if WORD_SIZE_IN_BITS >= 64 -instance BitPack Int64 where - type BitSize Int64 = 64 - pack = fromIntegral - unpack = fromIntegral -#endif - -instance BitPack Word where - type BitSize Word = WORD_SIZE_IN_BITS - pack = fromIntegral - unpack = fromIntegral - -instance BitPack Word8 where - type BitSize Word8 = 8 - pack = fromIntegral - unpack = fromIntegral - -instance BitPack Word16 where - type BitSize Word16 = 16 - pack = fromIntegral - unpack = fromIntegral - -instance BitPack Word32 where - type BitSize Word32 = 32 - pack = fromIntegral - unpack = fromIntegral - -#if WORD_SIZE_IN_BITS >= 64 -instance BitPack Word64 where - type BitSize Word64 = 64 - pack = fromIntegral - unpack = fromIntegral -#endif - -instance BitPack Float where - type BitSize Float = 32 - pack = packFloat# - unpack = unpackFloat# - -packFloat# :: Float -> BitVector 32 -packFloat# = fromIntegral . floatToWord -{-# NOINLINE packFloat# #-} - -unpackFloat# :: BitVector 32 -> Float -unpackFloat# = wordToFloat . fromInteger . unsafeToInteger -{-# NOINLINE unpackFloat# #-} - -instance BitPack Double where - type BitSize Double = 64 - pack = packDouble# - unpack = unpackDouble# - -packDouble# :: Double -> BitVector 64 -packDouble# = fromIntegral . doubleToWord -{-# NOINLINE packDouble# #-} - -unpackDouble# :: BitVector 64 -> Double -unpackDouble# = wordToDouble . fromInteger . unsafeToInteger -{-# NOINLINE unpackDouble# #-} - -instance BitPack CUShort where - type BitSize CUShort = 16 - pack = fromIntegral - unpack = fromIntegral - -instance BitPack Half where - type BitSize Half = 16 - pack (Half x) = pack x - unpack x = Half (unpack x) - -instance BitPack () where - type BitSize () = 0 - pack _ = minBound - unpack _ = () - -instance (KnownNat (BitSize b), BitPack a, BitPack b) => - BitPack (a,b) where - type BitSize (a,b) = BitSize a + BitSize b - pack (a,b) = pack a ++# pack b - unpack ab = let (a,b) = split# ab in (unpack a, unpack b) - -instance (KnownNat (BitSize c), BitPack (a,b), BitPack c) => - BitPack (a,b,c) where - type BitSize (a,b,c) = BitSize (a,b) + BitSize c - pack (a,b,c) = pack (a,b) ++# pack c - unpack (unpack -> ((a,b), c)) = (a,b,c) - -instance (KnownNat (BitSize d), BitPack (a,b,c), BitPack d) => - BitPack (a,b,c,d) where - type BitSize (a,b,c,d) = BitSize (a,b,c) + BitSize d - pack (a,b,c,d) = pack (a,b,c) ++# pack d - unpack (unpack -> ((a,b,c), d)) = (a,b,c,d) - -instance (KnownNat (BitSize e), BitPack (a,b,c,d), BitPack e) => - BitPack (a,b,c,d,e) where - type BitSize (a,b,c,d,e) = BitSize (a,b,c,d) + BitSize e - pack (a,b,c,d,e) = pack (a,b,c,d) ++# pack e - unpack (unpack -> ((a,b,c,d), e)) = (a,b,c,d,e) - -instance (KnownNat (BitSize f), BitPack (a,b,c,d,e), BitPack f) => - BitPack (a,b,c,d,e,f) where - type BitSize (a,b,c,d,e,f) = BitSize (a,b,c,d,e) + BitSize f - pack (a,b,c,d,e,f) = pack (a,b,c,d,e) ++# pack f - unpack (unpack -> ((a,b,c,d,e), f)) = (a,b,c,d,e,f) - -instance (KnownNat (BitSize g), BitPack (a,b,c,d,e,f), BitPack g) => - BitPack (a,b,c,d,e,f,g) where - type BitSize (a,b,c,d,e,f,g) = BitSize (a,b,c,d,e,f) + BitSize g - pack (a,b,c,d,e,f,g) = pack (a,b,c,d,e,f) ++# pack g - unpack (unpack -> ((a,b,c,d,e,f), g)) = (a,b,c,d,e,f,g) - -instance (KnownNat (BitSize h), BitPack (a,b,c,d,e,f,g), BitPack h) => - BitPack (a,b,c,d,e,f,g,h) where - type BitSize (a,b,c,d,e,f,g,h) = BitSize (a,b,c,d,e,f,g) + BitSize h - pack (a,b,c,d,e,f,g,h) = pack (a,b,c,d,e,f,g) ++# pack h - unpack (unpack -> ((a,b,c,d,e,f,g), h)) = (a,b,c,d,e,f,g,h) - -instance (BitPack a, KnownNat (BitSize a)) => BitPack (Maybe a) where - type BitSize (Maybe a) = 1 + BitSize a - pack Nothing = low ++# 0 - -- We cannot do `low ++# undefined`, because `BitVector`s underlying - -- representation is `Integer`, so `low ++# undefined` would make the - -- entire `BitVector` undefined. - pack (Just x) = high ++# pack x - unpack x = case split# x of - (c,rest) | c == low -> Nothing - | otherwise -> Just (unpack rest) - --- | Zero-extend a 'Bool'ean value to a 'BitVector' of the appropriate size. --- --- >>> boolToBV True :: BitVector 6 --- 00_0001 --- >>> boolToBV False :: BitVector 6 --- 00_0000 -boolToBV :: KnownNat n => Bool -> BitVector (n + 1) -boolToBV = zeroExtend . pack diff --git a/src/CLaSH/Class/Num.hs b/src/CLaSH/Class/Num.hs deleted file mode 100644 --- a/src/CLaSH/Class/Num.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-| -Copyright : (C) 2013-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij --} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} - -{-# LANGUAGE Safe #-} - -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Class.Num - ( -- * Arithmetic functions for arguments and results of different precision - ExtendingNum (..) - -- * Saturating arithmetic functions - , SaturationMode (..) - , SaturatingNum (..) - , boundedPlus - , boundedMin - , boundedMult - ) -where - --- * Arithmetic functions for arguments and results of different precision - --- | Adding, subtracting, and multiplying values of two different (sub-)types. -class ExtendingNum a b where - -- | Type of the result of the addition or subtraction - type AResult a b - -- | Add values of different (sub-)types, return a value of a (sub-)type - -- that is potentially different from either argument. - plus :: a -> b -> AResult a b - -- | Subtract values of different (sub-)types, return a value of a (sub-)type - -- that is potentially different from either argument. - minus :: a -> b -> AResult a b - -- | Type of the result of the multiplication - type MResult a b - -- | Multiply values of different (sub-)types, return a value of a (sub-)type - -- that is potentially different from either argument. - times :: a -> b -> MResult a b - --- * Saturating arithmetic functions - --- | Determine how overflow and underflow are handled by the functions in --- 'SaturatingNum' -data SaturationMode - = SatWrap -- ^ Wrap around on overflow and underflow - | SatBound -- ^ Become 'maxBound' on overflow, and 'minBound' on underflow - | SatZero -- ^ Become @0@ on overflow and underflow - | SatSymmetric -- ^ Become 'maxBound' on overflow, and (@'minBound' + 1@) on - -- underflow for signed numbers, and 'minBound' for unsigned - -- numbers. - deriving Eq - --- | 'Num' operators in which overflow and underflow behaviour can be specified --- using 'SaturationMode'. -class (Bounded a, Num a) => SaturatingNum a where - -- | Addition with parametrisable over- and underflow behaviour - satPlus :: SaturationMode -> a -> a -> a - -- | Subtraction with parametrisable over- and underflow behaviour - satMin :: SaturationMode -> a -> a -> a - -- | Multiplication with parametrisable over- and underflow behaviour - satMult :: SaturationMode -> a -> a -> a - -{-# INLINE boundedPlus #-} --- | Addition that clips to 'maxBound' on overflow, and 'minBound' on underflow -boundedPlus :: SaturatingNum a => a -> a -> a -boundedPlus = satPlus SatBound - -{-# INLINE boundedMin #-} --- | Subtraction that clips to 'maxBound' on overflow, and 'minBound' on --- underflow -boundedMin :: SaturatingNum a => a -> a -> a -boundedMin = satMin SatBound - -{-# INLINE boundedMult #-} --- | Multiplication that clips to 'maxBound' on overflow, and 'minBound' on --- underflow -boundedMult :: SaturatingNum a => a -> a -> a -boundedMult = satMult SatBound diff --git a/src/CLaSH/Class/Resize.hs b/src/CLaSH/Class/Resize.hs deleted file mode 100644 --- a/src/CLaSH/Class/Resize.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-| -Copyright : (C) 2013-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij --} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} - -{-# LANGUAGE Safe #-} - -{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Class.Resize where - -import GHC.TypeLits (Nat, KnownNat, type (+)) - --- | Coerce a value to be represented by a different number of bits -class Resize (f :: Nat -> *) where - -- | A sign-preserving resize operation - -- - -- * For signed datatypes: Increasing the size of the number replicates the - -- sign bit to the left. Truncating a number to length L keeps the sign bit - -- and the rightmost L-1 bits. - -- - -- * For unsigned datatypes: Increasing the size of the number extends with - -- zeros to the left. Truncating a number of length N to a length L just - -- removes the left (most significant) N-L bits. - resize :: (KnownNat a, KnownNat b) => f a -> f b - -- | Perform a 'zeroExtend' for unsigned datatypes, and 'signExtend' for a - -- signed datatypes - extend :: (KnownNat a, KnownNat b) => f a -> f (b + a) - extend = resize - -- | Add extra zero bits in front of the MSB - zeroExtend :: (KnownNat a, KnownNat b) => f a -> f (b + a) - -- | Add extra sign bits in front of the MSB - signExtend :: (KnownNat a, KnownNat b) => f a -> f (b + a) - signExtend = resize - -- | Remove bits from the MSB - truncateB :: KnownNat a => f (a + b) -> f a diff --git a/src/CLaSH/Examples.hs b/src/CLaSH/Examples.hs deleted file mode 100644 --- a/src/CLaSH/Examples.hs +++ /dev/null @@ -1,657 +0,0 @@ -{-| -Copyright : © Christiaan Baaij, 2015-2016 -Licence : Creative Commons 4.0 (CC BY 4.0) (http://creativecommons.org/licenses/by/4.0/) --} - -{-# LANGUAGE NoImplicitPrelude, CPP, TemplateHaskell, DataKinds #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -{-# OPTIONS_GHC -fno-warn-unused-binds #-} - -module CLaSH.Examples ( - -- * Decoders and Encoders - -- $decoders_and_encoders - - -- * Counters - -- $counters - - -- * Parity and CRC - -- $parity_and_crc - - -- * UART model - -- $uart - ) -where - -import CLaSH.Prelude -import Control.Lens -import Control.Monad -import Test.QuickCheck - -#ifdef DOCLINKS -import Control.Monad.Trans.State -#endif - -{- $setup ->>> :set -XDataKinds -XFlexibleContexts -XBinaryLiterals -XTypeFamilies -XTemplateHaskell -XRecordWildCards ->>> :set -fplugin GHC.TypeLits.Normalise ->>> import CLaSH.Prelude ->>> import Test.QuickCheck ->>> import Control.Lens ->>> import Control.Monad.Trans.State ->>> :{ -let decoderCase :: Bool -> BitVector 4 -> BitVector 16 - decoderCase enable binaryIn | enable = - case binaryIn of - 0x0 -> 0x0001 - 0x1 -> 0x0002 - 0x2 -> 0x0004 - 0x3 -> 0x0008 - 0x4 -> 0x0010 - 0x5 -> 0x0020 - 0x6 -> 0x0040 - 0x7 -> 0x0080 - 0x8 -> 0x0100 - 0x9 -> 0x0200 - 0xA -> 0x0400 - 0xB -> 0x0800 - 0xC -> 0x1000 - 0xD -> 0x2000 - 0xE -> 0x4000 - 0xF -> 0x8000 - decoderCase _ _ = 0 -:} - ->>> :{ -let decoderShift :: Bool -> BitVector 4 -> BitVector 16 - decoderShift enable binaryIn = - if enable - then 1 `shiftL` (fromIntegral binaryIn) - else 0 -:} - ->>> :{ -let encoderCase :: Bool -> BitVector 16 -> BitVector 4 - encoderCase enable binaryIn | enable = - case binaryIn of - 0x0001 -> 0x0 - 0x0002 -> 0x1 - 0x0004 -> 0x2 - 0x0008 -> 0x3 - 0x0010 -> 0x4 - 0x0020 -> 0x5 - 0x0040 -> 0x6 - 0x0080 -> 0x7 - 0x0100 -> 0x8 - 0x0200 -> 0x9 - 0x0400 -> 0xA - 0x0800 -> 0xB - 0x1000 -> 0xC - 0x2000 -> 0xD - 0x4000 -> 0xE - 0x8000 -> 0xF - encoderCase _ _ = 0 -:} - ->>> :{ -let upCounter :: Signal Bool -> Signal (Unsigned 8) - upCounter enable = s - where - s = register 0 (mux enable (s + 1) s) -:} - ->>> :{ -let upCounterLdT s (ld,en,dIn) = (s',s) - where - s' | ld = dIn - | en = s + 1 - | otherwise = s -:} - ->>> :{ -let upCounterLd :: Signal (Bool,Bool,Unsigned 8) -> Signal (Unsigned 8) - upCounterLd = mealy upCounterLdT 0 -:} - ->>> :{ -let upDownCounter :: Signal Bool -> Signal (Unsigned 8) - upDownCounter upDown = s - where - s = register 0 (mux upDown (s + 1) (s - 1)) -:} - ->>> :{ -let lfsrF' :: BitVector 16 -> BitVector 16 - lfsrF' s = feedback ++# slice d15 d1 s - where - feedback = s!5 `xor` s!3 `xor` s!2 `xor` s!0 -:} - ->>> :{ -let lfsrF :: BitVector 16 -> Signal Bit - lfsrF seed = msb <$> r - where r = register seed (lfsrF' <$> r) -:} - ->>> :{ -let lfsrGP taps regs = zipWith xorM taps (fb +>> regs) - where - fb = last regs - xorM i x | i = x `xor` fb - | otherwise = x -:} - ->>> :{ -let lfsrG :: BitVector 16 -> Signal Bit - lfsrG seed = last (unbundle r) - where r = register (unpack seed) (lfsrGP (unpack 0b0011010000000000) <$> r) -:} - ->>> :{ -let grayCounter :: Signal Bool -> Signal (BitVector 8) - grayCounter en = gray <$> upCounter en - where gray xs = msb xs ++# xor (slice d7 d1 xs) (slice d6 d0 xs) -:} - ->>> :{ -let oneHotCounter :: Signal Bool -> Signal (BitVector 8) - oneHotCounter enable = s - where - s = register 1 (mux enable (rotateL <$> s <*> 1) s) -:} - ->>> :{ -let parity :: Unsigned 8 -> Bit - parity data_in = reduceXor data_in -:} - ->>> :{ -let crcT bv dIn = replaceBit 0 dInXor - $ replaceBit 5 (bv!4 `xor` dInXor) - $ replaceBit 12 (bv!11 `xor` dInXor) - rotated - where - dInXor = dIn `xor` fb - rotated = rotateL bv 1 - fb = msb bv -:} - ->>> :{ -let crc :: Signal Bool -> Signal Bool -> Signal Bit -> Signal (BitVector 16) - crc enable ld dIn = s - where - s = register 0xFFFF (mux enable (mux ld 0xFFFF (crcT <$> s <*> dIn)) s) -:} - ->>> :{ -let uartTX t@(TxReg {..}) ld_tx_data tx_data tx_enable = flip execState t $ do - when ld_tx_data $ do - if not _tx_empty then - tx_over_run .= False - else do - tx_reg .= tx_data - tx_empty .= False - when (tx_enable && not _tx_empty) $ do - tx_cnt += 1 - when (_tx_cnt == 0) $ - tx_out .= 0 - when (_tx_cnt > 0 && _tx_cnt < 9) $ - tx_out .= _tx_reg ! (_tx_cnt - 1) - when (_tx_cnt == 9) $ do - tx_out .= 1 - tx_cnt .= 0 - tx_empty .= True - unless tx_enable $ - tx_cnt .= 0 -:} - ->>> :{ -let uartRX r@(RxReg {..}) rx_in uld_rx_data rx_enable = flip execState r $ do - -- Synchronise the async signal - rx_d1 .= rx_in - rx_d2 .= _rx_d1 - -- Uload the rx data - when uld_rx_data $ do - rx_data .= _rx_reg - rx_empty .= True - -- Receive data only when rx is enabled - if rx_enable then do - -- Check if just received start of frame - when (not _rx_busy && _rx_d2 == 0) $ do - rx_busy .= True - rx_sample_cnt .= 1 - rx_cnt .= 0 - -- Star of frame detected, Proceed with rest of data - when _rx_busy $ do - rx_sample_cnt += 1 - -- Logic to sample at middle of data - when (_rx_sample_cnt == 7) $ do - if _rx_d1 == 1 && _rx_cnt == 0 then - rx_busy .= False - else do - rx_cnt += 1 - -- start storing the rx data - when (_rx_cnt > 0 && _rx_cnt < 9) $ do - rx_reg %= replaceBit (_rx_cnt - 1) _rx_d2 - when (_rx_cnt == 9) $ do - rx_busy .= False - -- Check if End of frame received correctly - if _rx_d2 == 0 then - rx_frame_err .= True - else do - rx_empty .= False - rx_frame_err .= False - -- Check if last rx data was not unloaded - rx_over_run .= not _rx_empty - else do - rx_busy .= False -:} - ->>> :{ -let uart ld_tx_data tx_data tx_enable rx_in uld_rx_data rx_enable = - ( _tx_out <$> txReg - , _tx_empty <$> txReg - , _rx_data <$> rxReg - , _rx_empty <$> rxReg - ) - where - rxReg = register rxRegInit (uartRX <$> rxReg <*> rx_in <*> uld_rx_data - <*> rx_enable) - rxRegInit = RxReg { _rx_reg = 0 - , _rx_data = 0 - , _rx_sample_cnt = 0 - , _rx_cnt = 0 - , _rx_frame_err = False - , _rx_over_run = False - , _rx_empty = True - , _rx_d1 = 1 - , _rx_d2 = 1 - , _rx_busy = False - } - txReg = register txRegInit (uartTX <$> txReg <*> ld_tx_data <*> tx_data - <*> tx_enable) - txRegInit = TxReg { _tx_reg = 0 - , _tx_empty = True - , _tx_over_run = False - , _tx_out = 1 - , _tx_cnt = 0 - } -:} --} - -data RxReg - = RxReg - { _rx_reg :: BitVector 8 - , _rx_data :: BitVector 8 - , _rx_sample_cnt :: Unsigned 4 - , _rx_cnt :: Unsigned 4 - , _rx_frame_err :: Bool - , _rx_over_run :: Bool - , _rx_empty :: Bool - , _rx_d1 :: Bit - , _rx_d2 :: Bit - , _rx_busy :: Bool - } - -makeLenses ''RxReg - -data TxReg - = TxReg - { _tx_reg :: BitVector 8 - , _tx_empty :: Bool - , _tx_over_run :: Bool - , _tx_out :: Bit - , _tx_cnt :: Unsigned 4 - } - -makeLenses ''TxReg - -{- $decoders_and_encoders -= Decoder - -Using a @case@ statement: - -@ -decoderCase :: Bool -> BitVector 4 -> BitVector 16 -decoderCase enable binaryIn | enable = - case binaryIn of - 0x0 -> 0x0001 - 0x1 -> 0x0002 - 0x2 -> 0x0004 - 0x3 -> 0x0008 - 0x4 -> 0x0010 - 0x5 -> 0x0020 - 0x6 -> 0x0040 - 0x7 -> 0x0080 - 0x8 -> 0x0100 - 0x9 -> 0x0200 - 0xA -> 0x0400 - 0xB -> 0x0800 - 0xC -> 0x1000 - 0xD -> 0x2000 - 0xE -> 0x4000 - 0xF -> 0x8000 -decoderCase _ _ = 0 -@ - -Using the `shiftL` function: - -@ -decoderShift :: Bool -> BitVector 4 -> BitVector 16 -decoderShift enable binaryIn = - if enable - then 1 ``shiftL`` ('fromIntegral' binaryIn) - else 0 -@ - -Examples: - ->>> decoderCase True 3 -0000_0000_0000_1000 ->>> decoderShift True 7 -0000_0000_1000_0000 - -The following property holds: - -prop> \enable binaryIn -> decoderShift enable binaryIn === decoderCase enable binaryIn - -= Encoder - -Using a @case@ statement: - -@ -encoderCase :: Bool -> BitVector 16 -> BitVector 4 -encoderCase enable binaryIn | enable = - case binaryIn of - 0x0001 -> 0x0 - 0x0002 -> 0x1 - 0x0004 -> 0x2 - 0x0008 -> 0x3 - 0x0010 -> 0x4 - 0x0020 -> 0x5 - 0x0040 -> 0x6 - 0x0080 -> 0x7 - 0x0100 -> 0x8 - 0x0200 -> 0x9 - 0x0400 -> 0xA - 0x0800 -> 0xB - 0x1000 -> 0xC - 0x2000 -> 0xD - 0x4000 -> 0xE - 0x8000 -> 0xF -encoderCase _ _ = 0 -@ - -The following property holds: - -prop> \en decIn -> en ==> (encoderCase en (decoderCase en decIn) === decIn) --} - -{- $counters -= 8-bit Simple Up Counter - -Using `register`: - -@ -upCounter :: Signal Bool -> Signal (Unsigned 8) -upCounter enable = s - where - s = `register` 0 (`mux` enable (s + 1) s) -@ - -= 8-bit Up Counter With Load - -Using `mealy`: - -@ -upCounterLd :: Signal (Bool,Bool,Unsigned 8) -> Unsigned 8 -upCounterLd = `mealy` upCounterLdT 0 - -upCounterLdT s (ld,en,dIn) = (s',s) - where - s' | ld = dIn - | en = s + 1 - | otherwise = s -@ - -= 8-bit Up-Down counter - -Using `register` and `mux`: - -@ -upDownCounter :: Signal Bool -> Signal (Unsigned 8) -upDownCounter upDown = s - where - s = `register` 0 (`mux` upDown (s + 1) (s - 1)) -@ - -The following property holds: - -prop> \en -> en ==> testFor 1000 (upCounter (signal en) .==. upDownCounter (signal en)) - -= LFSR - -External/Fibonacci LFSR, for @n=16@ and using the primitive polynominal @1 + x^11 + x^13 + x^14 + x^16@ - -@ -lfsrF' :: BitVector 16 -> BitVector 16 -lfsrF' s = feedback '++#' 'slice' d15 d1 s - where - feedback = s'!'5 ``xor`` s'!'3 ``xor`` s'!'2 ``xor`` s'!'0 - -lfsrF :: BitVector 16 -> Signal Bit -lfsrF seed = 'msb' '<$>' r - where r = 'register' seed (lfsrF' '<$>' r) -@ - -We can also build a internal/Galois LFSR which has better timing characteristics. -We first define a Galois LFSR parametrizable in its filter taps: - -@ -lfsrGP taps regs = 'zipWith' xorM taps (fb '+>>' regs) - where - fb = 'last' regs - xorM i x | i = x ``xor`` fb - | otherwise = x -@ - -Then we can instantiate a 16-bit LFSR as follows: - -@ -lfsrG :: BitVector 16 -> Signal Bit -lfsrG seed = 'last' ('unbundle' r) - where r = 'register' ('unpack' seed) (lfsrGP ('unpack' 0b0011010000000000) '<$>' r) -@ - -The following property holds: - -prop> testFor 100 (lfsrF 0xACE1 .==. lfsrG 0x4645) - -= Gray counter - -Using the previously defined @upCounter@: - -@ -grayCounter :: Signal Bool -> Signal (BitVector 8) -grayCounter en = gray '<$>' upCounter en - where gray xs = 'msb' xs '++#' 'xor' ('slice' d7 d1 xs) ('slice' d6 d0 xs) -@ - -= One-hot counter - -Basically a barrel-shifter: - -@ -oneHotCounter :: Signal Bool -> Signal (BitVector 8) -oneHotCounter enable = s - where - s = 'register' 1 ('mux' enable ('rotateL' '<$>' s '<*>' 1) s) -@ --} - -{- $parity_and_crc -= Parity - -Just 'reduceXor': - -@ -parity :: Unsigned 8 -> Bit -parity data_in = `reduceXor` data_in -@ - -= Serial CRC - -* Width = 16 bits -* Truncated polynomial = 0x1021 -* Initial value = 0xFFFF -* Input data is NOT reflected -* Output CRC is NOT reflected -* No XOR is performed on the output CRC - -@ -crcT bv dIn = 'replaceBit' 0 dInXor - $ 'replaceBit' 5 (bv'!'4 ``xor`` dInXor) - $ 'replaceBit' 12 (bv'!'11 ``xor`` dInXor) - rotated - where - dInXor = dIn ``xor`` fb - rotated = 'rotateL' bv 1 - fb = 'msb' bv - -crc :: Signal Bool -> Signal Bool -> Signal Bit -> Signal (BitVector 16) -crc enable ld dIn = s - where - s = 'register' 0xFFFF ('mux' enable ('mux' ld 0xFFFF (crcT '<$>' s '<*>' dIn)) s) -@ --} - -{- $uart -@ -{\-\# LANGUAGE RecordWildCards \#-\} -module UART (uart) where - -import CLaSH.Prelude -import Control.Lens -import Control.Monad -import Control.Monad.Trans.State - --- UART RX Logic -data RxReg - = RxReg - { _rx_reg :: BitVector 8 - , _rx_data :: BitVector 8 - , _rx_sample_cnt :: Unsigned 4 - , _rx_cnt :: Unsigned 4 - , _rx_frame_err :: Bool - , _rx_over_run :: Bool - , _rx_empty :: Bool - , _rx_d1 :: Bit - , _rx_d2 :: Bit - , _rx_busy :: Bool - } - -makeLenses ''RxReg - -uartRX r\@(RxReg {..}) rx_in uld_rx_data rx_enable = 'flip' 'execState' r $ do - -- Synchronise the async signal - rx_d1 '.=' rx_in - rx_d2 '.=' _rx_d1 - -- Uload the rx data - 'when' uld_rx_data $ do - rx_data '.=' _rx_reg - rx_empty '.=' True - -- Receive data only when rx is enabled - if rx_enable then do - -- Check if just received start of frame - 'when' (not _rx_busy && _rx_d2 == 0) $ do - rx_busy '.=' True - rx_sample_cnt '.=' 1 - rx_cnt '.=' 0 - -- Star of frame detected, Proceed with rest of data - 'when' _rx_busy $ do - rx_sample_cnt '+=' 1 - -- Logic to sample at middle of data - 'when' (_rx_sample_cnt == 7) $ do - if _rx_d1 == 1 && _rx_cnt == 0 then - rx_busy '.=' False - else do - rx_cnt '+=' 1 - -- start storing the rx data - 'when' (_rx_cnt > 0 && _rx_cnt < 9) $ do - rx_reg '%=' 'replaceBit' (_rx_cnt - 1) _rx_d2 - 'when' (_rx_cnt == 9) $ do - rx_busy .= False - -- Check if End of frame received correctly - if _rx_d2 == 0 then - rx_frame_err '.=' True - else do - rx_empty '.=' False - rx_frame_err '.=' False - -- Check if last rx data was not unloaded - rx_over_run '.=' not _rx_empty - else do - rx_busy .= False - --- UART TX Logic -data TxReg - = TxReg - { _tx_reg :: BitVector 8 - , _tx_empty :: Bool - , _tx_over_run :: Bool - , _tx_out :: Bit - , _tx_cnt :: Unsigned 4 - } - -makeLenses ''TxReg - -uartTX t\@(TxReg {..}) ld_tx_data tx_data tx_enable = 'flip' 'execState' t $ do - 'when' ld_tx_data $ do - if not _tx_empty then - tx_over_run '.=' False - else do - tx_reg '.=' tx_data - tx_empty '.=' False - 'when' (tx_enable && not _tx_empty) $ do - tx_cnt '+=' 1 - 'when' (_tx_cnt == 0) $ - tx_out '.=' 0 - 'when' (_tx_cnt > 0 && _tx_cnt < 9) $ - tx_out '.=' _tx_reg '!' (_tx_cnt - 1) - 'when' (_tx_cnt == 9) $ do - tx_out '.=' 1 - tx_cnt '.=' 0 - tx_empty '.=' True - 'unless' tx_enable $ - tx_cnt '.=' 0 - --- Combine RX and TX logic -uart ld_tx_data tx_data tx_enable rx_in uld_rx_data rx_enable = - ( _tx_out '<$>' txReg - , _tx_empty '<$>' txReg - , _rx_data '<$>' rxReg - , _rx_empty '<$>' rxReg - ) - where - rxReg = register rxRegInit (uartRX '<$>' rxReg '<*>' rx_in '<*>' uld_rx_data - '<*>' rx_enable) - rxRegInit = RxReg { _rx_reg = 0 - , _rx_data = 0 - , _rx_sample_cnt = 0 - , _rx_cnt = 0 - , _rx_frame_err = False - , _rx_over_run = False - , _rx_empty = True - , _rx_d1 = 1 - , _rx_d2 = 1 - , _rx_busy = False - } - - txReg = register txRegInit (uartTX '<$>' txReg '<*>' ld_tx_data '<*>' tx_data - '<*>' tx_enable) - txRegInit = TxReg { _tx_reg = 0 - , _tx_empty = True - , _tx_over_run = False - , _tx_out = 1 - , _tx_cnt = 0 - } -@ --} diff --git a/src/CLaSH/NamedTypes.hs b/src/CLaSH/NamedTypes.hs deleted file mode 100644 --- a/src/CLaSH/NamedTypes.hs +++ /dev/null @@ -1,65 +0,0 @@ -{- | -Copyright : (C) 2017, QBayLogic -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij - -Add inline documentation to types: - -@ -fifo - :: SClock clk - -> SNat addrSize - -> "read request" ::: Signal' clk Bool - -> "write request" ::: Signal' clk (Maybe (BitVector dataSize)) - -> ( "q" ::: Signal' clk (BitVector dataSize) - , "full" ::: Signal' clk Bool - , "empty" ::: Signal' clk Bool - ) -@ - -which can subsequently be inspected in the interactive environment: - ->>> :t fifo systemClock -fifo systemClock - :: SNat addrSize - -> "read request" ::: Signal' SystemClock Bool - -> "write request" - ::: Signal' SystemClock (Maybe (BitVector dataSize)) - -> ("q" ::: Signal' SystemClock (BitVector dataSize), - "full" ::: Signal' SystemClock Bool, - "empty" ::: Signal' SystemClock Bool) - --} - -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeOperators #-} - -{-# LANGUAGE Safe #-} - -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.NamedTypes - ((:::)) -where - -type (name :: k) ::: a = a --- ^ Annotate a type with a name - -{- $setup ->>> :set -XDataKinds -XTypeOperators -XNoImplicitPrelude ->>> import CLaSH.Prelude ->>> import CLaSH.Prelude.Explicit ->>> :{ -let fifo - :: SClock clk - -> SNat addrSize - -> "read request" ::: Signal' clk Bool - -> "write request" ::: Signal' clk (Maybe (BitVector dataSize)) - -> ( "q" ::: Signal' clk (BitVector dataSize) - , "full" ::: Signal' clk Bool - , "empty" ::: Signal' clk Bool - ) - fifo = CLaSH.Prelude.undefined -:} - --} diff --git a/src/CLaSH/Prelude.hs b/src/CLaSH/Prelude.hs deleted file mode 100644 --- a/src/CLaSH/Prelude.hs +++ /dev/null @@ -1,213 +0,0 @@ -{-| - Copyright : (C) 2013-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - CλaSH (pronounced ‘clash’) is a functional hardware description language that - borrows both its syntax and semantics from the functional programming language - Haskell. The merits of using a functional language to describe hardware comes - from the fact that combinational circuits can be directly modeled as - mathematical functions and that functional languages lend themselves very well - at describing and (de-)composing mathematical functions. - - This package provides: - - * Prelude library containing datatypes and functions for circuit design - - To use the library: - - * Import "CLaSH.Prelude" - * Additionally import "CLaSH.Prelude.Explicit" if you want to design - explicitly clocked circuits in a multi-clock setting - - For now, "CLaSH.Prelude" is also the best starting point for exploring the - library. A preliminary version of a tutorial can be found in "CLaSH.Tutorial". - Some circuit examples can be found in "CLaSH.Examples". --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeOperators #-} - -{-# LANGUAGE Unsafe #-} - -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Prelude - ( -- * Creating synchronous sequential circuits - mealy - , mealyB - , (<^>) - , moore - , mooreB - , registerB - -- * ROMs - , asyncRom - , asyncRomPow2 - , rom - , romPow2 - -- ** ROMs initialised with a data file - , asyncRomFile - , asyncRomFilePow2 - , romFile - , romFilePow2 - -- * RAM primitives with a combinational read port - , asyncRam - , asyncRamPow2 - -- * BlockRAM primitives - , blockRam - , blockRamPow2 - -- ** BlockRAM primitives initialised with a data file - , blockRamFile - , blockRamFilePow2 - -- * BlockRAM read/write conflict resolution - , readNew - , readNew' - -- * Utility functions - , window - , windowD - , isRising - , isFalling - -- * Testbench functions - , assert - , stimuliGenerator - , outputVerifier - -- * Exported modules - -- ** Synchronous signals - , module CLaSH.Signal - , module CLaSH.Signal.Delayed - -- ** DataFlow interface - , module CLaSH.Prelude.DataFlow - -- ** Datatypes - -- *** Bit vectors - , module CLaSH.Sized.BitVector - , module CLaSH.Prelude.BitIndex - , module CLaSH.Prelude.BitReduction - -- *** Arbitrary-width numbers - , module CLaSH.Sized.Signed - , module CLaSH.Sized.Unsigned - , module CLaSH.Sized.Index - -- *** Fixed point numbers - , module CLaSH.Sized.Fixed - -- *** Fixed size vectors - , module CLaSH.Sized.Vector - -- *** Perfect depth trees - , module CLaSH.Sized.RTree - -- ** Annotations - , module CLaSH.Annotations.TopEntity - -- ** Type-level natural numbers - , module GHC.TypeLits - , module GHC.TypeLits.Extra - , module CLaSH.Promoted.Nat - , module CLaSH.Promoted.Nat.Literals - , module CLaSH.Promoted.Nat.TH - -- ** Template Haskell - , Lift (..) - -- ** Type classes - -- *** CLaSH - , module CLaSH.Class.BitPack - , module CLaSH.Class.Num - , module CLaSH.Class.Resize - -- *** Other - , module Control.Applicative - , module Data.Bits - , module Data.Default - -- ** Exceptions - , module CLaSH.XException - , undefined - -- ** Named types - , module CLaSH.NamedTypes - -- ** Haskell Prelude - -- $hiding - , module Prelude - ) -where - -import Control.Applicative -import Data.Bits -import Data.Default -import GHC.TypeLits -import GHC.TypeLits.Extra -import Language.Haskell.TH.Syntax (Lift(..)) -import Prelude hiding ((++), (!!), concat, drop, foldl, - foldl1, foldr, foldr1, head, init, - iterate, last, length, map, repeat, - replicate, reverse, scanl, scanr, - splitAt, tail, take, unzip, unzip3, - zip, zip3, zipWith, zipWith3, - undefined) - -import CLaSH.Annotations.TopEntity -import CLaSH.Class.BitPack -import CLaSH.Class.Num -import CLaSH.Class.Resize -import CLaSH.NamedTypes -import CLaSH.Prelude.BitIndex -import CLaSH.Prelude.BitReduction -import CLaSH.Prelude.BlockRam.File (blockRamFile, blockRamFilePow2) -import CLaSH.Prelude.DataFlow -import CLaSH.Prelude.Explicit (window', windowD') -import CLaSH.Prelude.ROM.File (asyncRomFile,asyncRomFilePow2,romFile, - romFilePow2) -import CLaSH.Prelude.Safe -import CLaSH.Prelude.Testbench (assert, stimuliGenerator, outputVerifier) -import CLaSH.Promoted.Nat -import CLaSH.Promoted.Nat.TH -import CLaSH.Promoted.Nat.Literals -import CLaSH.Sized.BitVector -import CLaSH.Sized.Fixed -import CLaSH.Sized.Index -import CLaSH.Sized.RTree -import CLaSH.Sized.Signed -import CLaSH.Sized.Unsigned -import CLaSH.Sized.Vector -import CLaSH.Signal -import CLaSH.Signal.Delayed -import CLaSH.Signal.Explicit (systemClock) -import CLaSH.XException - -{- $setup ->>> :set -XDataKinds ->>> let window4 = window :: Signal Int -> Vec 4 (Signal Int) ->>> let windowD3 = windowD :: Signal Int -> Vec 3 (Signal Int) ->>> let rP = registerB (8,8) --} - -{- $hiding -"CLaSH.Prelude" re-exports most of the Haskell "Prelude" with the exception of -the following: (++), (!!), concat, drop, foldl, foldl1, foldr, foldr1, head, -init, iterate, last, length, map, repeat, replicate, reverse, scanl, scanr, -splitAt, tail, take, unzip, unzip3, zip, zip3, zipWith, zipWith3. - -It instead exports the identically named functions defined in terms of -'CLaSH.Sized.Vector.Vec' at "CLaSH.Sized.Vector". --} - -{-# INLINE window #-} --- | Give a window over a 'Signal' --- --- > window4 :: Signal Int -> Vec 4 (Signal Int) --- > window4 = window --- --- >>> simulateB window4 [1::Int,2,3,4,5] :: [Vec 4 Int] --- [<1,0,0,0>,<2,1,0,0>,<3,2,1,0>,<4,3,2,1>,<5,4,3,2>... --- ... -window :: (KnownNat n, Default a) - => Signal a -- ^ Signal to create a window over - -> Vec (n + 1) (Signal a) -- ^ Window of at least size 1 -window = window' systemClock - -{-# INLINE windowD #-} --- | Give a delayed window over a 'Signal' --- --- > windowD3 :: Signal Int -> Vec 3 (Signal Int) --- > windowD3 = windowD --- --- >>> simulateB windowD3 [1::Int,2,3,4] :: [Vec 3 Int] --- [<0,0,0>,<1,0,0>,<2,1,0>,<3,2,1>,<4,3,2>... --- ... -windowD :: (KnownNat n, Default a) - => Signal a -- ^ Signal to create a window over - -> Vec (n + 1) (Signal a) -- ^ Window of at least size 1 -windowD = windowD' systemClock diff --git a/src/CLaSH/Prelude/BitIndex.hs b/src/CLaSH/Prelude/BitIndex.hs deleted file mode 100644 --- a/src/CLaSH/Prelude/BitIndex.hs +++ /dev/null @@ -1,152 +0,0 @@ -{-| -Copyright : (C) 2013-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij --} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} - -{-# LANGUAGE Trustworthy #-} - -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Prelude.BitIndex where - -import GHC.TypeLits (KnownNat, type (+), type (-)) - -import CLaSH.Class.BitPack (BitPack (..)) -import CLaSH.Promoted.Nat (SNat) -import CLaSH.Sized.Internal.BitVector (BitVector, Bit, index#, lsb#, msb#, - replaceBit#, setSlice#, slice#, split#) - -{- $setup ->>> :set -XDataKinds ->>> import CLaSH.Prelude --} - -{-# INLINE (!) #-} --- | Get the bit at the specified bit index. --- --- __NB:__ Bit indices are __DESCENDING__. --- --- >>> pack (7 :: Unsigned 6) --- 00_0111 --- >>> (7 :: Unsigned 6) ! 1 --- 1 --- >>> (7 :: Unsigned 6) ! 5 --- 0 --- >>> (7 :: Unsigned 6) ! 6 --- *** Exception: (!): 6 is out of range [5..0] --- ... -(!) :: (BitPack a, KnownNat (BitSize a), Enum i) => a -> i -> Bit -(!) v i = index# (pack v) (fromEnum i) - -{-# INLINE slice #-} --- | Get a slice between bit index @m@ and and bit index @n@. --- --- __NB:__ Bit indices are __DESCENDING__. --- --- >>> pack (7 :: Unsigned 6) --- 00_0111 --- >>> slice d4 d2 (7 :: Unsigned 6) --- 001 --- >>> slice d6 d4 (7 :: Unsigned 6) --- --- :... --- • Couldn't match type ‘7 + i0’ with ‘6’ --- arising from a use of ‘slice’ --- The type variable ‘i0’ is ambiguous --- • In the expression: slice d6 d4 (7 :: Unsigned 6) --- In an equation for ‘it’: it = slice d6 d4 (7 :: Unsigned 6) -slice :: (BitPack a, BitSize a ~ ((m + 1) + i)) => SNat m -> SNat n -> a - -> BitVector (m + 1 - n) -slice m n v = slice# (pack v) m n - -{-# INLINE split #-} --- | Split a value of a bit size @m + n@ into a tuple of values with size @m@ --- and size @n@. --- --- >>> pack (7 :: Unsigned 6) --- 00_0111 --- >>> split (7 :: Unsigned 6) :: (BitVector 2, BitVector 4) --- (00,0111) -split :: (BitPack a, BitSize a ~ (m + n), KnownNat n) => a - -> (BitVector m, BitVector n) -split v = split# (pack v) - -{-# INLINE replaceBit #-} --- | Set the bit at the specified index --- --- __NB:__ Bit indices are __DESCENDING__. --- --- >>> pack (-5 :: Signed 6) --- 11_1011 --- >>> replaceBit 4 0 (-5 :: Signed 6) --- -21 --- >>> pack (-21 :: Signed 6) --- 10_1011 --- >>> replaceBit 5 0 (-5 :: Signed 6) --- 27 --- >>> pack (27 :: Signed 6) --- 01_1011 --- >>> replaceBit 6 0 (-5 :: Signed 6) --- *** Exception: replaceBit: 6 is out of range [5..0] --- ... -replaceBit :: (BitPack a, KnownNat (BitSize a), Enum i) => i -> Bit -> a - -> a -replaceBit i b v = unpack (replaceBit# (pack v) (fromEnum i) b) - -{-# INLINE setSlice #-} --- | Set the bits between bit index @m@ and bit index @n@. --- --- __NB:__ Bit indices are __DESCENDING__. --- --- >>> pack (-5 :: Signed 6) --- 11_1011 --- >>> setSlice d4 d3 0 (-5 :: Signed 6) --- -29 --- >>> pack (-29 :: Signed 6) --- 10_0011 --- >>> setSlice d6 d5 0 (-5 :: Signed 6) --- --- :... --- • Couldn't match type ‘7 + i0’ with ‘6’ --- arising from a use of ‘setSlice’ --- The type variable ‘i0’ is ambiguous --- • In the expression: setSlice d6 d5 0 (- 5 :: Signed 6) --- In an equation for ‘it’: it = setSlice d6 d5 0 (- 5 :: Signed 6) -setSlice :: (BitPack a, BitSize a ~ ((m + 1) + i)) => SNat m -> SNat n - -> BitVector (m + 1 - n) -> a -> a -setSlice m n w v = unpack (setSlice# (pack v) m n w) - -{-# INLINE msb #-} --- | Get the most significant bit. --- --- >>> pack (-4 :: Signed 6) --- 11_1100 --- >>> msb (-4 :: Signed 6) --- 1 --- >>> pack (4 :: Signed 6) --- 00_0100 --- >>> msb (4 :: Signed 6) --- 0 -msb :: (BitPack a, KnownNat (BitSize a)) => a -> Bit -msb v = msb# (pack v) - -{-# INLINE lsb #-} --- | Get the least significant bit. --- --- >>> pack (-9 :: Signed 6) --- 11_0111 --- >>> lsb (-9 :: Signed 6) --- 1 --- >>> pack (-8 :: Signed 6) --- 11_1000 --- >>> lsb (-8 :: Signed 6) --- 0 -lsb :: BitPack a => a -> Bit -lsb v = lsb# (pack v) diff --git a/src/CLaSH/Prelude/BitReduction.hs b/src/CLaSH/Prelude/BitReduction.hs deleted file mode 100644 --- a/src/CLaSH/Prelude/BitReduction.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-| -Copyright : (C) 2013-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij --} - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MagicHash #-} - -{-# LANGUAGE Trustworthy #-} - -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Prelude.BitReduction where - -import GHC.TypeLits (KnownNat) - -import CLaSH.Class.BitPack (BitPack (..)) -import CLaSH.Sized.Internal.BitVector (Bit, reduceAnd#, reduceOr#, reduceXor#) - -{- $setup ->>> :set -XDataKinds ->>> import CLaSH.Prelude --} - -{-# INLINE reduceAnd #-} --- | Are all bits set to '1'? --- --- >>> pack (-2 :: Signed 6) --- 11_1110 --- >>> reduceAnd (-2 :: Signed 6) --- 0 --- >>> pack (-1 :: Signed 6) --- 11_1111 --- >>> reduceAnd (-1 :: Signed 6) --- 1 -reduceAnd :: (BitPack a, KnownNat (BitSize a)) => a -> Bit -reduceAnd v = reduceAnd# (pack v) - -{-# INLINE reduceOr #-} --- | Is there at least one bit set to '1'? --- --- >>> pack (5 :: Signed 6) --- 00_0101 --- >>> reduceOr (5 :: Signed 6) --- 1 --- >>> pack (0 :: Signed 6) --- 00_0000 --- >>> reduceOr (0 :: Signed 6) --- 0 -reduceOr :: BitPack a => a -> Bit -reduceOr v = reduceOr# (pack v) - -{-# INLINE reduceXor #-} --- | Is the number of bits set to '1' uneven? --- --- >>> pack (5 :: Signed 6) --- 00_0101 --- >>> reduceXor (5 :: Signed 6) --- 0 --- >>> pack (28 :: Signed 6) --- 01_1100 --- >>> reduceXor (28 :: Signed 6) --- 1 --- >>> pack (-5 :: Signed 6) --- 11_1011 --- >>> reduceXor (-5 :: Signed 6) --- 1 -reduceXor :: BitPack a => a -> Bit -reduceXor v = reduceXor# (pack v) diff --git a/src/CLaSH/Prelude/BlockRam.hs b/src/CLaSH/Prelude/BlockRam.hs deleted file mode 100644 --- a/src/CLaSH/Prelude/BlockRam.hs +++ /dev/null @@ -1,820 +0,0 @@ -{-| -Copyright : (C) 2013-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij - -BlockRAM primitives - -= Using RAMs #usingrams# - -We will show a rather elaborate example on how you can, and why you might want -to use 'blockRam's. We will build a \"small\" CPU+Memory+Program ROM where we -will slowly evolve to using blockRams. Note that the code is /not/ meant as a -de-facto standard on how to do CPU design in CλaSH. - -We start with the definition of the Instructions, Register names and machine -codes: - -@ -{\-\# LANGUAGE RecordWildCards, TupleSections \#-\} -module CPU where - -import CLaSH.Prelude - -type InstrAddr = Unsigned 8 -type MemAddr = Unsigned 5 -type Value = Signed 8 - -data Instruction - = Compute Operator Reg Reg Reg - | Branch Reg Value - | Jump Value - | Load MemAddr Reg - | Store Reg MemAddr - | Nop - deriving (Eq,Show) - -data Reg - = Zero - | PC - | RegA - | RegB - | RegC - | RegD - | RegE - deriving (Eq,Show,Enum) - -data Operator = Add | Sub | Incr | Imm | CmpGt - deriving (Eq,Show) - -data MachCode - = MachCode - { inputX :: Reg - , inputY :: Reg - , result :: Reg - , aluCode :: Operator - , ldReg :: Reg - , rdAddr :: MemAddr - , wrAddrM :: Maybe MemAddr - , jmpM :: Maybe Value - } - -nullCode = MachCode { inputX = Zero, inputY = Zero, result = Zero, aluCode = Imm - , ldReg = Zero, rdAddr = 0, wrAddrM = Nothing - , jmpM = Nothing - } -@ - -Next we define the CPU and its ALU: - -@ -cpu :: Vec 7 Value -- ^ Register bank - -> (Value,Instruction) -- ^ (Memory output, Current instruction) - -> ( Vec 7 Value - , (MemAddr, Maybe (MemAddr,Value), InstrAddr) - ) -cpu regbank (memOut,instr) = (regbank',(rdAddr,(,aluOut) '<$>' wrAddrM,fromIntegral ipntr)) - where - -- Current instruction pointer - ipntr = regbank '!!' PC - - -- Decoder - (MachCode {..}) = case instr of - Compute op rx ry res -> nullCode {inputX=rx,inputY=ry,result=res,aluCode=op} - Branch cr a -> nullCode {inputX=cr,jmpM=Just a} - Jump a -> nullCode {aluCode=Incr,jmpM=Just a} - Load a r -> nullCode {ldReg=r,rdAddr=a} - Store r a -> nullCode {inputX=r,wrAddrM=Just a} - Nop -> nullCode - - -- ALU - regX = regbank '!!' inputX - regY = regbank '!!' inputY - aluOut = alu aluCode regX regY - - -- next instruction - nextPC = case jmpM of - Just a | aluOut /= 0 -> ipntr + a - _ -> ipntr + 1 - - -- update registers - regbank' = 'replace' Zero 0 - $ 'replace' PC nextPC - $ 'replace' result aluOut - $ 'replace' ldReg memOut - $ regbank - -alu Add x y = x + y -alu Sub x y = x - y -alu Incr x _ = x + 1 -alu Imm x _ = x -alu CmpGt x y = if x > y then 1 else 0 -@ - -We initially create a memory out of simple registers: - -@ -dataMem :: Signal MemAddr -- ^ Read address - -> Signal (Maybe (MemAddr,Value)) -- ^ (write address, data in) - -> Signal Value -- ^ data out -dataMem rd wrM = 'CLaSH.Prelude.Mealy.mealy' dataMemT ('replicate' d32 0) (bundle (rd,wrM)) - where - dataMemT mem (rd,wrM) = (mem',dout) - where - dout = mem '!!' rd - mem' = case wrM of - Just (wr,din) -> 'replace' wr din mem - _ -> mem -@ - -And then connect everything: - -@ -system :: KnownNat n => Vec n Instruction -> Signal Value -system instrs = memOut - where - memOut = dataMem rdAddr dout - (rdAddr,dout,ipntr) = 'CLaSH.Prelude.Mealy.mealyB' cpu ('replicate' d7 0) (memOut,instr) - instr = 'CLaSH.Prelude.ROM.asyncRom' instrs '<$>' ipntr -@ - -Create a simple program that calculates the GCD of 4 and 6: - -@ --- Compute GCD of 4 and 6 -prog = -- 0 := 4 - Compute Incr Zero RegA RegA :> - replicate d3 (Compute Incr RegA Zero RegA) ++ - Store RegA 0 :> - -- 1 := 6 - Compute Incr Zero RegA RegA :> - replicate d5 (Compute Incr RegA Zero RegA) ++ - Store RegA 1 :> - -- A := 4 - Load 0 RegA :> - -- B := 6 - Load 1 RegB :> - -- start - Compute CmpGt RegA RegB RegC :> - Branch RegC 4 :> - Compute CmpGt RegB RegA RegC :> - Branch RegC 4 :> - Jump 5 :> - -- (a > b) - Compute Sub RegA RegB RegA :> - Jump (-6) :> - -- (b > a) - Compute Sub RegB RegA RegB :> - Jump (-8) :> - -- end - Store RegA 2 :> - Load 2 RegC :> - Nil -@ - -And test our system: - -@ ->>> sampleN 31 $ system prog -[0,0,0,0,0,4,4,4,4,4,4,4,4,6,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,2] - -@ - -to see that our system indeed calculates that the GCD of 6 and 4 is 2. - -=== Improvement 1: using @asyncRam@ - -As you can see, it's fairly straightforward to build a memory using registers -and read ('!!') and write ('replace') logic. This might however not result in -the most efficient hardware structure, especially when building an ASIC. - -Instead it is preferable to use the 'CLaSH.Prelude.RAM.asyncRam' function which -has the potential to be translated to a more efficient structure: - -@ -system2 :: KnownNat n => Vec n Instruction -> Signal Value -system2 instrs = memOut - where - memOut = 'CLaSH.Prelude.RAM.asyncRam' d32 rdAddr dout - (rdAddr,dout,ipntr) = 'mealyB' cpu ('replicate' d7 0) (memOut,instr) - instr = 'CLaSH.Prelude.ROM.asyncRom' instrs '<$>' ipntr -@ - -Again, we can simulate our system and see that it works. This time however, -we need to disregard the first few output samples, because the initial content of an -'CLaSH.Prelude.RAM.asyncRam' is 'undefined', and consequently, the first few -output samples are also 'undefined'. We use the utility function 'printX' to conveniently -filter out the undefinedness and replace it with the string "X" in the few leading outputs. - -@ ->>> printX $ sampleN 31 $ system2 prog -[X,X,X,X,X,4,4,4,4,4,4,4,4,6,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,2] - -@ - -=== Improvement 2: using @blockRam@ - -Finally we get to using 'blockRam'. On FPGAs, 'CLaSH.Prelude.RAM.asyncRam' will -be implemented in terms of LUTs, and therefore take up logic resources. FPGAs -also have large(r) memory structures called /Block RAMs/, which are preferred, -especially as the memories we need for our application get bigger. The -'blockRam' function will be translated to such a /Block RAM/. - -One important aspect of Block RAMs have a /synchronous/ read port, meaning that, -unlike the behaviour of 'CLaSH.Prelude.RAM.asyncRam', given a read address @r@ -at time @t@, the value @v@ in the RAM at address @r@ is only available at time -@t+1@. - -For us that means we need to change the design of our CPU. Right now, upon a -load instruction we generate a read address for the memory, and the value at -that read address is immediately available to be put in the register bank. -Because we will be using a BlockRAM, the value is delayed until the next cycle. -We hence need to also delay the register address to which the memory address -is loaded: - -@ -cpu2 :: (Vec 7 Value,Reg) -- ^ (Register bank, Load reg addr) - -> (Value,Instruction) -- ^ (Memory output, Current instruction) - -> ( (Vec 7 Value,Reg) - , (MemAddr, Maybe (MemAddr,Value), InstrAddr) - ) -cpu2 (regbank,ldRegD) (memOut,instr) = ((regbank',ldRegD'),(rdAddr,(,aluOut) '<$>' wrAddrM,fromIntegral ipntr)) - where - -- Current instruction pointer - ipntr = regbank '!!' PC - - -- Decoder - (MachCode {..}) = case instr of - Compute op rx ry res -> nullCode {inputX=rx,inputY=ry,result=res,aluCode=op} - Branch cr a -> nullCode {inputX=cr,jmpM=Just a} - Jump a -> nullCode {aluCode=Incr,jmpM=Just a} - Load a r -> nullCode {ldReg=r,rdAddr=a} - Store r a -> nullCode {inputX=r,wrAddrM=Just a} - Nop -> nullCode - - -- ALU - regX = regbank '!!' inputX - regY = regbank '!!' inputY - aluOut = alu aluCode regX regY - - -- next instruction - nextPC = case jmpM of - Just a | aluOut /= 0 -> ipntr + a - _ -> ipntr + 1 - - -- update registers - ldRegD' = ldReg -- Delay the ldReg by 1 cycle - regbank' = 'replace' Zero 0 - $ 'replace' PC nextPC - $ 'replace' result aluOut - $ 'replace' ldRegD memOut - $ regbank -@ - -We can now finally instantiate our system with a 'blockRam': - -@ -system3 :: KnownNat n => Vec n Instruction -> Signal Value -system3 instrs = memOut - where - memOut = 'blockRam' (replicate d32 0) rdAddr dout - (rdAddr,dout,ipntr) = 'mealyB' cpu2 (('replicate' d7 0),Zero) (memOut,instr) - instr = 'CLaSH.Prelude.ROM.asyncRom' instrs '<$>' ipntr -@ - -We are, however, not done. We will also need to update our program. The reason -being that values that we try to load in our registers won't be loaded into the -register until the next cycle. This is a problem when the next instruction -immediately depended on this memory value. In our case, this was only the case -when the loaded the value @6@, which was stored at address @1@, into @RegB@. -Our updated program is thus: - -@ -prog2 = -- 0 := 4 - Compute Incr Zero RegA RegA :> - replicate d3 (Compute Incr RegA Zero RegA) ++ - Store RegA 0 :> - -- 1 := 6 - Compute Incr Zero RegA RegA :> - replicate d5 (Compute Incr RegA Zero RegA) ++ - Store RegA 1 :> - -- A := 4 - Load 0 RegA :> - -- B := 6 - Load 1 RegB :> - Nop :> -- Extra NOP - -- start - Compute CmpGt RegA RegB RegC :> - Branch RegC 4 :> - Compute CmpGt RegB RegA RegC :> - Branch RegC 4 :> - Jump 5 :> - -- (a > b) - Compute Sub RegA RegB RegA :> - Jump (-6) :> - -- (b > a) - Compute Sub RegB RegA RegB :> - Jump (-8) :> - -- end - Store RegA 2 :> - Load 2 RegC :> - Nil -@ - -When we simulate our system we see that it works. This time again, -we need to disregard the first sample, because the initial output of a -'blockRam' is 'undefined'. We use the utility function 'printX' to conveniently -filter out the undefinedness and replace it with the string "X". - -@ ->>> printX $ sampleN 33 $ system3 prog2 -[X,0,0,0,0,0,4,4,4,4,4,4,4,4,6,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,2] - -@ - -This concludes the short introduction to using 'blockRam'. - --} - -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} - -{-# LANGUAGE Trustworthy #-} - -{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} -{-# OPTIONS_HADDOCK show-extensions #-} - --- See: https://github.com/clash-lang/clash-compiler/commit/721fcfa9198925661cd836668705f817bddaae3c --- as to why we need this. -{-# OPTIONS_GHC -fno-cpr-anal #-} - -module CLaSH.Prelude.BlockRam - ( -- * BlockRAM synchronised to the system clock - blockRam - , blockRamPow2 - -- * BlockRAM synchronised to an arbitrary clock - , blockRam' - , blockRamPow2' - -- * Read/Write conflict resolution - , readNew - , readNew' - -- * Internal - , blockRam# - ) -where - -import Data.Maybe (fromJust, isJust) -import qualified Data.Vector as V -import GHC.TypeLits (KnownNat, type (^)) -import Prelude hiding (length) - -import CLaSH.Signal (Signal, mux) -import CLaSH.Signal.Explicit (SClock, register', systemClock) -import CLaSH.Signal.Internal (Signal' (..)) -import CLaSH.Signal.Bundle (unbundle) -import CLaSH.Sized.Unsigned (Unsigned) -import CLaSH.Sized.Vector (Vec, toList) -import CLaSH.XException (errorX) - -{- $setup ->>> import CLaSH.Prelude as C ->>> import qualified Data.List as L ->>> :set -XDataKinds -XRecordWildCards -XTupleSections ->>> type InstrAddr = Unsigned 8 ->>> type MemAddr = Unsigned 5 ->>> type Value = Signed 8 ->>> :{ -data Reg - = Zero - | PC - | RegA - | RegB - | RegC - | RegD - | RegE - deriving (Eq,Show,Enum) -:} - ->>> :{ -data Operator = Add | Sub | Incr | Imm | CmpGt - deriving (Eq,Show) -:} - ->>> :{ -data Instruction - = Compute Operator Reg Reg Reg - | Branch Reg Value - | Jump Value - | Load MemAddr Reg - | Store Reg MemAddr - | Nop - deriving (Eq,Show) -:} - ->>> :{ -data MachCode - = MachCode - { inputX :: Reg - , inputY :: Reg - , result :: Reg - , aluCode :: Operator - , ldReg :: Reg - , rdAddr :: MemAddr - , wrAddrM :: Maybe MemAddr - , jmpM :: Maybe Value - } -:} - ->>> :{ -nullCode = MachCode { inputX = Zero, inputY = Zero, result = Zero, aluCode = Imm - , ldReg = Zero, rdAddr = 0, wrAddrM = Nothing - , jmpM = Nothing - } -:} - ->>> :{ -alu Add x y = x + y -alu Sub x y = x - y -alu Incr x _ = x + 1 -alu Imm x _ = x -alu CmpGt x y = if x > y then 1 else 0 -:} - ->>> :{ -cpu :: Vec 7 Value -- ^ Register bank - -> (Value,Instruction) -- ^ (Memory output, Current instruction) - -> ( Vec 7 Value - , (MemAddr,Maybe (MemAddr,Value),InstrAddr) - ) -cpu regbank (memOut,instr) = (regbank',(rdAddr,(,aluOut) <$> wrAddrM,fromIntegral ipntr)) - where - -- Current instruction pointer - ipntr = regbank C.!! PC - -- Decoder - (MachCode {..}) = case instr of - Compute op rx ry res -> nullCode {inputX=rx,inputY=ry,result=res,aluCode=op} - Branch cr a -> nullCode {inputX=cr,jmpM=Just a} - Jump a -> nullCode {aluCode=Incr,jmpM=Just a} - Load a r -> nullCode {ldReg=r,rdAddr=a} - Store r a -> nullCode {inputX=r,wrAddrM=Just a} - Nop -> nullCode - -- ALU - regX = regbank C.!! inputX - regY = regbank C.!! inputY - aluOut = alu aluCode regX regY - -- next instruction - nextPC = case jmpM of - Just a | aluOut /= 0 -> ipntr + a - _ -> ipntr + 1 - -- update registers - regbank' = replace Zero 0 - $ replace PC nextPC - $ replace result aluOut - $ replace ldReg memOut - $ regbank -:} - ->>> :{ -dataMem :: Signal MemAddr - -> Signal (Maybe (MemAddr,Value)) - -> Signal Value -dataMem rd wrM = mealy dataMemT (C.replicate d32 0) (bundle (rd,wrM)) - where - dataMemT mem (rd,wrM) = (mem',dout) - where - dout = mem C.!! rd - mem' = case wrM of - Just (wr,din) -> replace wr din mem - Nothing -> mem -:} - ->>> :{ -system :: KnownNat n => Vec n Instruction -> Signal Value -system instrs = memOut - where - memOut = dataMem rdAddr dout - (rdAddr,dout,ipntr) = mealyB cpu (C.replicate d7 0) (memOut,instr) - instr = asyncRom instrs <$> ipntr -:} - ->>> :{ --- Compute GCD of 4 and 6 -prog = -- 0 := 4 - Compute Incr Zero RegA RegA :> - C.replicate d3 (Compute Incr RegA Zero RegA) C.++ - Store RegA 0 :> - -- 1 := 6 - Compute Incr Zero RegA RegA :> - C.replicate d5 (Compute Incr RegA Zero RegA) C.++ - Store RegA 1 :> - -- A := 4 - Load 0 RegA :> - -- B := 6 - Load 1 RegB :> - -- start - Compute CmpGt RegA RegB RegC :> - Branch RegC 4 :> - Compute CmpGt RegB RegA RegC :> - Branch RegC 4 :> - Jump 5 :> - -- (a > b) - Compute Sub RegA RegB RegA :> - Jump (-6) :> - -- (b > a) - Compute Sub RegB RegA RegB :> - Jump (-8) :> - -- end - Store RegA 2 :> - Load 2 RegC :> - Nil -:} - ->>> :{ -system2 :: KnownNat n => Vec n Instruction -> Signal Value -system2 instrs = memOut - where - memOut = asyncRam d32 rdAddr dout - (rdAddr,dout,ipntr) = mealyB cpu (C.replicate d7 0) (memOut,instr) - instr = asyncRom instrs <$> ipntr -:} - ->>> :{ -cpu2 :: (Vec 7 Value,Reg) -- ^ (Register bank, Load reg addr) - -> (Value,Instruction) -- ^ (Memory output, Current instruction) - -> ( (Vec 7 Value,Reg) - , (MemAddr,Maybe (MemAddr,Value),InstrAddr) - ) -cpu2 (regbank,ldRegD) (memOut,instr) = ((regbank',ldRegD'),(rdAddr,(,aluOut) <$> wrAddrM,fromIntegral ipntr)) - where - -- Current instruction pointer - ipntr = regbank C.!! PC - -- Decoder - (MachCode {..}) = case instr of - Compute op rx ry res -> nullCode {inputX=rx,inputY=ry,result=res,aluCode=op} - Branch cr a -> nullCode {inputX=cr,jmpM=Just a} - Jump a -> nullCode {aluCode=Incr,jmpM=Just a} - Load a r -> nullCode {ldReg=r,rdAddr=a} - Store r a -> nullCode {inputX=r,wrAddrM=Just a} - Nop -> nullCode - -- ALU - regX = regbank C.!! inputX - regY = regbank C.!! inputY - aluOut = alu aluCode regX regY - -- next instruction - nextPC = case jmpM of - Just a | aluOut /= 0 -> ipntr + a - _ -> ipntr + 1 - -- update registers - ldRegD' = ldReg -- Delay the ldReg by 1 cycle - regbank' = replace Zero 0 - $ replace PC nextPC - $ replace result aluOut - $ replace ldRegD memOut - $ regbank -:} - ->>> :{ -system3 :: KnownNat n => Vec n Instruction -> Signal Value -system3 instrs = memOut - where - memOut = blockRam (C.replicate d32 0) rdAddr dout - (rdAddr,dout,ipntr) = mealyB cpu2 ((C.replicate d7 0),Zero) (memOut,instr) - instr = asyncRom instrs <$> ipntr -:} - ->>> :{ -prog2 = -- 0 := 4 - Compute Incr Zero RegA RegA :> - C.replicate d3 (Compute Incr RegA Zero RegA) C.++ - Store RegA 0 :> - -- 1 := 6 - Compute Incr Zero RegA RegA :> - C.replicate d5 (Compute Incr RegA Zero RegA) C.++ - Store RegA 1 :> - -- A := 4 - Load 0 RegA :> - -- B := 6 - Load 1 RegB :> - Nop :> -- Extra NOP - -- start - Compute CmpGt RegA RegB RegC :> - Branch RegC 4 :> - Compute CmpGt RegB RegA RegC :> - Branch RegC 4 :> - Jump 5 :> - -- (a > b) - Compute Sub RegA RegB RegA :> - Jump (-6) :> - -- (b > a) - Compute Sub RegB RegA RegB :> - Jump (-8) :> - -- end - Store RegA 2 :> - Load 2 RegC :> - Nil -:} - --} - -{-# INLINE blockRam #-} --- | Create a blockRAM with space for @n@ elements. --- --- * __NB__: Read value is delayed by 1 cycle --- * __NB__: Initial output value is 'undefined' --- --- @ --- bram40 :: 'Signal' ('Unsigned' 6) --- -> 'Signal' (Maybe ('Unsigned' 6, 'CLaSH.Sized.BitVector.Bit')) --- -> 'Signal' 'CLaSH.Sized.BitVector.Bit' --- bram40 = 'blockRam' ('CLaSH.Sized.Vector.replicate' d40 1) --- @ --- --- Additional helpful information: --- --- * See "CLaSH.Prelude.BlockRam#usingrams" for more information on how to use a --- Block RAM. --- * Use the adapter 'readNew' for obtaining write-before-read semantics like this: @readNew (blockRam inits) rd wrM@. -blockRam :: Enum addr - => Vec n a -- ^ Initial content of the BRAM, also - -- determines the size, @n@, of the BRAM. - -- - -- __NB__: __MUST__ be a constant. - -> Signal addr -- ^ Read address @r@ - -> Signal (Maybe (addr, a)) - -- ^ (write address @w@, value to write) - -> Signal a - -- ^ Value of the @blockRAM@ at address @r@ from the previous clock - -- cycle -blockRam = blockRam' systemClock - -{-# INLINE blockRamPow2 #-} --- | Create a blockRAM with space for 2^@n@ elements --- --- * __NB__: Read value is delayed by 1 cycle --- * __NB__: Initial output value is 'undefined' --- --- @ --- bram32 :: 'Signal' ('Unsigned' 5) --- -> 'Signal' (Maybe ('Unsigned' 5, 'CLaSH.Sized.BitVector.Bit')) --- -> 'Signal' 'CLaSH.Sized.BitVector.Bit' --- bram32 = 'blockRamPow2' ('CLaSH.Sized.Vector.replicate' d32 1) --- @ --- --- Additional helpful information: --- --- * See "CLaSH.Prelude.BlockRam#usingrams" for more information on how to use a --- Block RAM. --- * Use the adapter 'readNew' for obtaining write-before-read semantics like this: @readNew (blockRamPow2 inits) rd wrM@. -blockRamPow2 :: KnownNat n - => Vec (2^n) a -- ^ Initial content of the BRAM, also - -- determines the size, @2^n@, of the BRAM. - -- - -- __NB__: __MUST__ be a constant. - -> Signal (Unsigned n) -- ^ Read address @r@ - -> Signal (Maybe (Unsigned n, a)) - -- ^ (write address @w@, value to write) - -> Signal a - -- ^ Value of the @blockRAM@ at address @r@ from the previous clock - -- cycle -blockRamPow2 = blockRamPow2' systemClock - -{-# INLINE blockRam' #-} --- | Create a blockRAM with space for @n@ elements --- --- * __NB__: Read value is delayed by 1 cycle --- * __NB__: Initial output value is 'undefined' --- --- @ --- type ClkA = Clk \"A\" 100 --- --- clkA100 :: SClock ClkA --- clkA100 = 'CLaSH.Signal.Explicit.sclock' --- --- bram40 :: 'Signal'' ClkA ('Unsigned' 6) --- -> 'Signal'' ClkA (Maybe ('Unsigned' 6, 'CLaSH.Sized.BitVector.Bit')) --- -> 'Signal'' ClkA 'CLaSH.Sized.BitVector.Bit' --- bram40 = 'blockRam'' clkA100 ('CLaSH.Sized.Vector.replicate' d40 1) --- @ --- --- Additional helpful information: --- --- * See "CLaSH.Prelude.BlockRam#usingrams" for more information on how to use a --- Block RAM. --- * Use the adapter 'readNew'' for obtaining write-before-read semantics like this: @readNew' clk (blockRam' clk inits) rd wrM@. -blockRam' :: Enum addr - => SClock clk -- ^ 'Clock' to synchronize to - -> Vec n a -- ^ Initial content of the BRAM, also - -- determines the size, @n@, of the BRAM. - -- - -- __NB__: __MUST__ be a constant. - -> Signal' clk addr -- ^ Read address @r@ - -> Signal' clk (Maybe (addr, a)) - -- ^ (write address @w@, value to write) - -> Signal' clk a - -- ^ Value of the @blockRAM@ at address @r@ from the previous clock - -- cycle -blockRam' clk content rd wrM = - let en = isJust <$> wrM - (wr,din) = unbundle (fromJust <$> wrM) - in blockRam# clk content (fromEnum <$> rd) en (fromEnum <$> wr) din - -{-# INLINE blockRamPow2' #-} --- | Create a blockRAM with space for 2^@n@ elements --- --- * __NB__: Read value is delayed by 1 cycle --- * __NB__: Initial output value is 'undefined' --- --- @ --- type ClkA = Clk \"A\" 100 --- --- clkA100 :: SClock ClkA --- clkA100 = 'CLaSH.Signal.Explicit.sclock' --- --- bram32 :: 'Signal'' ClkA ('Unsigned' 5) --- -> 'Signal'' ClkA (Maybe ('Unsigned' 5, 'CLaSH.Sized.BitVector.Bit')) --- -> 'Signal'' ClkA 'CLaSH.Sized.BitVector.Bit' --- bram32 = 'blockRamPow2'' clkA100 ('CLaSH.Sized.Vector.replicate' d32 1) --- @ --- --- Additional helpful information: --- --- * See "CLaSH.Prelude.BlockRam#usingrams" for more information on how to use a --- Block RAM. --- * Use the adapter 'readNew'' for obtaining write-before-read semantics like this: @readNew' clk (blockRamPow2' clk inits) rd wrM@. -blockRamPow2' :: KnownNat n - => SClock clk -- ^ 'Clock' to synchronize to - -> Vec (2^n) a -- ^ Initial content of the BRAM, also - -- determines the size, @2^n@, of - -- the BRAM. - -- - -- __NB__: __MUST__ be a constant. - -> Signal' clk (Unsigned n) -- ^ Read address @r@ - -> Signal' clk (Maybe (Unsigned n, a)) - -- ^ (Write address @w@, value to write) - -> Signal' clk a - -- ^ Value of the @blockRAM@ at address @r@ from the previous - -- clock cycle -blockRamPow2' = blockRam' - --- | blockRAM primitive -blockRam# :: SClock clk -- ^ 'Clock' to synchronize to - -> Vec n a -- ^ Initial content of the BRAM, also - -- determines the size, @n@, of the BRAM. - -- - -- __NB__: __MUST__ be a constant. - -> Signal' clk Int -- ^ Read address @r@ - -> Signal' clk Bool -- ^ Write enable - -> Signal' clk Int -- ^ Write address @w@ - -> Signal' clk a -- ^ Value to write (at address @w@) - -> Signal' clk a - -- ^ Value of the @blockRAM@ at address @r@ from the previous clock - -- cycle -blockRam# _clk content = - go (V.fromList (toList content)) (errorX "blockRam#: intial value undefined") - where - go !ram o (r :- rs) (e :- en) (w :- wr) (d :- din) = - let ram' = upd ram e w d - o' = ram V.! r - in o :- go ram' o' rs en wr din - - upd ram True addr d = ram V.// [(addr,d)] - upd ram False _ _ = ram -{-# NOINLINE blockRam# #-} - --- | Create read-after-write blockRAM from a read-before-write one (synchronised to specified clock) --- -readNew' :: Eq addr - => SClock clk - -> (Signal' clk addr -> Signal' clk (Maybe (addr, a)) -> Signal' clk a) - -- ^ The @ram@ component - -> Signal' clk addr -- ^ Read address @r@ - -> Signal' clk (Maybe (addr, a)) -- ^ (Write address @w@, value to write) - -> Signal' clk a - -- ^ Value of the @ram@ at address @r@ from the previous clock - -- cycle -readNew' clk ram rdAddr wrM = mux wasSame wasWritten $ ram rdAddr wrM - where readNewT rd (Just (wr, wrdata)) = (wr == rd, wrdata) - readNewT _ Nothing = (False , undefined) - - (wasSame,wasWritten) = unbundle (register' clk (False,undefined) - (readNewT <$> rdAddr <*> wrM)) - --- | Create read-after-write blockRAM from a read-before-write one (synchronised to system clock) --- --- >>> import CLaSH.Prelude --- >>> :t readNew (blockRam (0 :> 1 :> Nil)) --- readNew (blockRam (0 :> 1 :> Nil)) --- :: ... => --- Signal addr -> Signal (Maybe (addr, a)) -> Signal a -readNew :: Eq addr - => (Signal addr -> Signal (Maybe (addr, a)) -> Signal a) - -- ^ The @ram@ component - -> Signal addr -- ^ Read address @r@ - -> Signal (Maybe (addr, a)) -- ^ (Write address @w@, value to write) - -> Signal a - -- ^ Value of the @ram@ at address @r@ from the previous clock - -- cycle -readNew = readNew' systemClock diff --git a/src/CLaSH/Prelude/BlockRam/File.hs b/src/CLaSH/Prelude/BlockRam/File.hs deleted file mode 100644 --- a/src/CLaSH/Prelude/BlockRam/File.hs +++ /dev/null @@ -1,306 +0,0 @@ -{-| -Copyright : (C) 2015-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij - -= Initialising a BlockRAM with a data file #usingramfiles# - -BlockRAM primitives that can be initialised with a data file. The BNF grammar -for this data file is simple: - -@ -FILE = LINE+ -LINE = BIT+ -BIT = '0' - | '1' -@ - -Consecutive @LINE@s correspond to consecutive memory addresses starting at @0@. -For example, a data file @memory.bin@ containing the 9-bit unsigned number -@7@ to @13@ looks like: - -@ -000000111 -000001000 -000001001 -000001010 -000001011 -000001100 -000001101 -@ - -We can instantiate a BlockRAM using the content of the above file like so: - -@ -topEntity :: Signal (Unsigned 3) -> Signal (Unsigned 9) -topEntity rd = 'CLaSH.Class.BitPack.unpack' '<$>' 'blockRamFile' d7 \"memory.bin\" rd (signal Nothing) -@ - -In the example above, we basically treat the BlockRAM as an synchronous ROM. -We can see that it works as expected: - -@ -__>>> import qualified Data.List as L__ -__>>> L.tail $ sampleN 4 $ topEntity (fromList [3..5])__ -[10,11,12] -@ - -However, we can also interpret the same data as a tuple of a 6-bit unsigned -number, and a 3-bit signed number: - -@ -topEntity2 :: Signal (Unsigned 3) -> Signal (Unsigned 6,Signed 3) -topEntity2 rd = 'CLaSH.Class.BitPack.unpack' '<$>' 'blockRamFile' d7 \"memory.bin\" rd (signal Nothing) -@ - -And then we would see: - -@ -__>>> import qualified Data.List as L__ -__>>> L.tail $ sampleN 4 $ topEntity2 (fromList [3..5])__ -[(1,2),(1,3)(1,-4)] -@ - --} - -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - -{-# LANGUAGE Unsafe #-} - -{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} -{-# OPTIONS_HADDOCK show-extensions #-} - --- See: https://github.com/clash-lang/clash-compiler/commit/721fcfa9198925661cd836668705f817bddaae3c --- as to why we need this. -{-# OPTIONS_GHC -fno-cpr-anal #-} - -module CLaSH.Prelude.BlockRam.File - ( -- * BlockRAM synchronised to the system clock - blockRamFile - , blockRamFilePow2 - -- * BlockRAM synchronised to an arbitrary clock - , blockRamFile' - , blockRamFilePow2' - -- * Internal - , blockRamFile# - , initMem - ) -where - -import Data.Char (digitToInt) -import Data.Maybe (fromJust, isJust, listToMaybe) -import qualified Data.Vector as V -import GHC.TypeLits (KnownNat) -import Numeric (readInt) -import System.IO.Unsafe (unsafePerformIO) - -import CLaSH.Promoted.Nat (SNat (..), pow2SNat) -import CLaSH.Sized.BitVector (BitVector) -import CLaSH.Signal (Signal) -import CLaSH.Signal.Explicit (SClock, systemClock) -import CLaSH.Signal.Internal (Signal' (..)) -import CLaSH.Signal.Bundle (unbundle) -import CLaSH.Sized.Unsigned (Unsigned) -import CLaSH.XException (errorX) - -{-# INLINE blockRamFile #-} --- | Create a blockRAM with space for @n@ elements --- --- * __NB__: Read value is delayed by 1 cycle --- * __NB__: Initial output value is 'undefined' --- * __NB__: This function might not work for specific combinations of --- code-generation backends and hardware targets. Please check the support table --- below: --- --- @ --- | VHDL | Verilog | SystemVerilog | --- ===============+==========+==========+===============+ --- Altera/Quartus | Broken | Works | Works | --- Xilinx/ISE | Works | Works | Works | --- ASIC | Untested | Untested | Untested | --- ===============+==========+==========+===============+ --- @ --- --- Additional helpful information: --- --- * See "CLaSH.Prelude.BlockRam#usingrams" for more information on how to use a --- Block RAM. --- * Use the adapter 'readNew' for obtaining write-before-read semantics like this: @readNew (blockRamFile size file) rd wrM@. --- * See "CLaSH.Prelude.BlockRam.File#usingramfiles" for more information on how --- to instantiate a Block RAM with the contents of a data file. --- * See "CLaSH.Sized.Fixed#creatingdatafiles" for ideas on how to create your --- own data files. -blockRamFile :: (KnownNat m, Enum addr) - => SNat n -- ^ Size of the blockRAM - -> FilePath -- ^ File describing the initial content - -- of the blockRAM - -> Signal addr -- ^ Read address @r@ - -> Signal (Maybe (addr, BitVector m)) - -- ^ (write address @w@, value to write) - -> Signal (BitVector m) - -- ^ Value of the @blockRAM@ at address @r@ from the previous clock - -- cycle -blockRamFile = blockRamFile' systemClock - -{-# INLINE blockRamFilePow2 #-} --- | Create a blockRAM with space for 2^@n@ elements --- --- * __NB__: Read value is delayed by 1 cycle --- * __NB__: Initial output value is 'undefined' --- * __NB__: This function might not work for specific combinations of --- code-generation backends and hardware targets. Please check the support table --- below: --- --- @ --- | VHDL | Verilog | SystemVerilog | --- ===============+==========+==========+===============+ --- Altera/Quartus | Broken | Works | Works | --- Xilinx/ISE | Works | Works | Works | --- ASIC | Untested | Untested | Untested | --- ===============+==========+==========+===============+ --- @ --- --- Additional helpful information: --- --- * See "CLaSH.Prelude.BlockRam#usingrams" for more information on how to use a --- Block RAM. --- * Use the adapter 'readNew' for obtaining write-before-read semantics like this: @readNew (blockRamFilePow2 file) rd wrM@. --- * See "CLaSH.Prelude.BlockRam.File#usingramfiles" for more information on how --- to instantiate a Block RAM with the contents of a data file. --- * See "CLaSH.Sized.Fixed#creatingdatafiles" for ideas on how to create your --- own data files. -blockRamFilePow2 :: (KnownNat m, KnownNat n) - => FilePath -- ^ File describing the initial - -- content of the blockRAM - -> Signal (Unsigned n) -- ^ Read address @r@ - -> Signal (Maybe (Unsigned n, BitVector m)) - -- ^ (write address @w@, value to write) - -> Signal (BitVector m) - -- ^ Value of the @blockRAM@ at address @r@ from the previous - -- clock cycle -blockRamFilePow2 = blockRamFilePow2' systemClock - -{-# INLINE blockRamFilePow2' #-} --- | Create a blockRAM with space for 2^@n@ elements --- --- * __NB__: Read value is delayed by 1 cycle --- * __NB__: Initial output value is 'undefined' --- * __NB__: This function might not work for specific combinations of --- code-generation backends and hardware targets. Please check the support table --- below: --- --- @ --- | VHDL | Verilog | SystemVerilog | --- ===============+==========+==========+===============+ --- Altera/Quartus | Broken | Works | Works | --- Xilinx/ISE | Works | Works | Works | --- ASIC | Untested | Untested | Untested | --- ===============+==========+==========+===============+ --- @ --- --- Additional helpful information: --- --- * See "CLaSH.Prelude.BlockRam#usingrams" for more information on how to use a --- Block RAM. --- * Use the adapter 'readNew'' for obtaining write-before-read semantics like this: @readNew' clk (blockRamFilePow2' clk file) rd wrM@. --- * See "CLaSH.Prelude.BlockRam.File#usingramfiles" for more information on how --- to instantiate a Block RAM with the contents of a data file. --- * See "CLaSH.Sized.Fixed#creatingdatafiles" for ideas on how to create your --- own data files. -blockRamFilePow2' :: forall clk n m . (KnownNat m, KnownNat n) - => SClock clk -- ^ 'Clock' to synchronize to - -> FilePath -- ^ File describing the initial - -- content of the blockRAM - -> Signal' clk (Unsigned n) -- ^ Read address @r@ - -> Signal' clk (Maybe (Unsigned n, BitVector m)) - -- ^ (write address @w@, value to write) - -> Signal' clk (BitVector m) - -- ^ Value of the @blockRAM@ at address @r@ from the previous - -- clock cycle -blockRamFilePow2' clk = blockRamFile' clk (pow2SNat (SNat @ n)) - -{-# INLINE blockRamFile' #-} --- | Create a blockRAM with space for @n@ elements --- --- * __NB__: Read value is delayed by 1 cycle --- * __NB__: Initial output value is 'undefined' --- * __NB__: This function might not work for specific combinations of --- code-generation backends and hardware targets. Please check the support table --- below: --- --- @ --- | VHDL | Verilog | SystemVerilog | --- ===============+==========+==========+===============+ --- Altera/Quartus | Broken | Works | Works | --- Xilinx/ISE | Works | Works | Works | --- ASIC | Untested | Untested | Untested | --- ===============+==========+==========+===============+ --- @ --- --- Additional helpful information: --- --- * See "CLaSH.Prelude.BlockRam#usingrams" for more information on how to use a --- Block RAM. --- * Use the adapter 'readNew'' for obtaining write-before-read semantics like this: @readNew' clk (blockRamFile' clk size file) rd wrM@. --- * See "CLaSH.Prelude.BlockRam.File#usingramfiles" for more information on how --- to instantiate a Block RAM with the contents of a data file. --- * See "CLaSH.Sized.Fixed#creatingdatafiles" for ideas on how to create your --- own data files. -blockRamFile' :: (KnownNat m, Enum addr) - => SClock clk -- ^ 'Clock' to synchronize to - -> SNat n -- ^ Size of the blockRAM - -> FilePath -- ^ File describing the initial - -- content of the blockRAM - -> Signal' clk addr -- ^ Read address @r@ - -> Signal' clk (Maybe (addr, BitVector m)) - -- ^ (write address @w@, value to write) - -> Signal' clk (BitVector m) - -- ^ Value of the @blockRAM@ at address @r@ from the previous - -- clock cycle -blockRamFile' clk sz file rd wrM = - let en = isJust <$> wrM - (wr,din) = unbundle (fromJust <$> wrM) - in blockRamFile# clk sz file (fromEnum <$> rd) en (fromEnum <$> wr) din - --- | blockRamFile primitive -blockRamFile# :: KnownNat m - => SClock clk -- ^ 'Clock' to synchronize to - -> SNat n -- ^ Size of the blockRAM - -> FilePath -- ^ File describing the initial - -- content of the blockRAM - -> Signal' clk Int -- ^ Read address @r@ - -> Signal' clk Bool -- ^ Write enable - -> Signal' clk Int -- ^ Write address @w@ - -> Signal' clk (BitVector m) -- ^ Value to write (at address @w@) - -> Signal' clk (BitVector m) - -- ^ Value of the @blockRAM@ at address @r@ from the previous - -- clock cycle -blockRamFile# _clk _sz file = - go ramI (errorX "blockRamFile#: intial value undefined") - where - go !ram o (r :- rs) (e :- en) (w :- wr) (d :- din) = - let ram' = upd ram e w d - o' = ram V.! r - in o :- go ram' o' rs en wr din - - upd ram True addr d = ram V.// [(addr,d)] - upd ram False _ _ = ram - - content = unsafePerformIO (initMem file) - ramI = V.fromList content -{-# NOINLINE blockRamFile# #-} - -{-# NOINLINE initMem #-} --- | __NB:__ Not synthesisable -initMem :: KnownNat n => FilePath -> IO [BitVector n] -initMem = fmap (map parseBV . lines) . readFile - where - parseBV s = case parseBV' s of - Just i -> fromInteger i - Nothing -> error ("Failed to parse: " ++ s) - parseBV' = fmap fst . listToMaybe . readInt 2 (`elem` "01") digitToInt diff --git a/src/CLaSH/Prelude/DataFlow.hs b/src/CLaSH/Prelude/DataFlow.hs deleted file mode 100644 --- a/src/CLaSH/Prelude/DataFlow.hs +++ /dev/null @@ -1,539 +0,0 @@ -{-| -Copyright : (C) 2013-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij - -Self-synchronising circuits based on data-flow principles. --} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -{-# LANGUAGE Trustworthy #-} - -{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Prelude.DataFlow - ( -- * Data types - DataFlow - , DataFlow' (..) - -- * Creating DataFlow circuits - , liftDF - , pureDF - , mealyDF - , mooreDF - , fifoDF - -- * Composition combinators - , idDF - , seqDF - , firstDF - , swapDF - , secondDF - , parDF - , parNDF - , loopDF - , loopDF_nobuf - -- * Lock-Step operation - , LockStep (..) - ) -where - -import GHC.TypeLits (KnownNat, KnownSymbol, type (+), type (^)) -import Prelude hiding ((++), (!!), length, map, repeat, tail, unzip3, zip3 - , zipWith) - -import CLaSH.Class.BitPack (boolToBV) -import CLaSH.Class.Resize (truncateB) -import CLaSH.Prelude.BitIndex (msb) -import CLaSH.Prelude.Mealy (mealyB') -import CLaSH.Promoted.Nat (SNat) -import CLaSH.Signal ((.&&.), unbundle) -import CLaSH.Signal.Bundle (Bundle (..)) -import CLaSH.Signal.Internal (regEn#) -import CLaSH.Signal.Explicit (Clock (..), Signal', SystemClock, sclock) -import CLaSH.Sized.BitVector (BitVector) -import CLaSH.Sized.Vector - -{- | Dataflow circuit with bidirectional synchronisation channels. - -In the /forward/ direction we assert /validity/ of the data. In the /backward/ -direction we assert that the circuit is /ready/ to receive new data. A circuit -adhering to the 'DataFlow' type should: - - * Not consume data when validity is deasserted. - * Only update its output when readiness is asserted. - -The 'DataFlow'' type is defined as: - -@ -newtype DataFlow' clk iEn oEn i o - = DF - { df :: 'Signal'' clk i -- Incoming data - -> 'Signal'' clk iEn -- Flagged with /valid/ bits @iEn@. - -> 'Signal'' clk oEn -- Incoming back-pressure, /ready/ edge. - -> ( 'Signal'' clk o -- Outgoing data. - , 'Signal'' clk oEn -- Flagged with /valid/ bits @oEn@. - , 'Signal'' clk iEn -- Outgoing back-pressure, /ready/ edge. - ) - } -@ - -where: - - * @clk@ is the clock to which the circuit is synchronised. - * @iEn@ is the type of the bidirectional incoming synchronisation channel. - * @oEn@ is the type of the bidirectional outgoing synchronisation channel. - * @i@ is the incoming data type. - * @o@ is the outgoing data type. - -We define several composition operators for our 'DataFlow' circuits: - - * 'seqDF' sequential composition. - * 'parDF' parallel composition. - * 'loopDF' add a feedback arc. - * 'lockStep' proceed in lock-step. - -When you look at the types of the above operators it becomes clear why we -parametrise in the types of the synchronisation channels. --} -newtype DataFlow' clk iEn oEn i o - = DF - { -- | Create an ordinary circuit from a 'DataFlow' circuit - df :: Signal' clk i -- Incoming data - -> Signal' clk iEn -- Flagged with /valid/ bits @iEn@. - -> Signal' clk oEn -- Incoming back-pressure, /ready/ edge. - -> ( Signal' clk o -- Outgoing data. - , Signal' clk oEn -- Flagged with /valid/ bits @oEn@. - , Signal' clk iEn -- Outgoing back-pressure, /ready/ edge. - ) - } - --- | Dataflow circuit synchronised to the 'SystemClock'. -type DataFlow iEn oEn i o = DataFlow' SystemClock iEn oEn i o - --- | Create a 'DataFlow' circuit from a circuit description with the appropriate --- type: --- --- @ --- 'Signal'' clk i -- Incoming data. --- -> 'Signal'' clk Bool -- Flagged with a single /valid/ bit. --- -> 'Signal'' clk Bool -- Incoming back-pressure, /ready/ bit. --- -> ( 'Signal'' clk o -- Outgoing data. --- , 'Signal'' clk oEn -- Flagged with a single /valid/ bit. --- , 'Signal'' clk iEn -- Outgoing back-pressure, /ready/ bit. --- ) --- @ --- --- A circuit adhering to the 'DataFlow' type should: --- --- * Not consume data when validity is deasserted. --- * Only update its output when readiness is asserted. -liftDF :: (Signal' clk i -> Signal' clk Bool -> Signal' clk Bool - -> (Signal' clk o, Signal' clk Bool, Signal' clk Bool)) - -> DataFlow' clk Bool Bool i o -liftDF = DF - --- | Create a 'DataFlow' circuit where the given function @f@ operates on the --- data, and the synchronisation channels are passed unaltered. -pureDF :: (i -> o) - -> DataFlow' clk Bool Bool i o -pureDF f = DF (\i iV oR -> (fmap f i,iV,oR)) - --- | Create a 'DataFlow' circuit from a Mealy machine description as those of --- "CLaSH.Prelude.Mealy" -mealyDF :: (KnownSymbol nm, KnownNat rate) - => (s -> i -> (s,o)) - -> s - -> DataFlow' ('Clk nm rate) Bool Bool i o -mealyDF f iS = DF (\i iV oR -> let en = iV .&&. oR - (s',o) = unbundle (f <$> s <*> i) - s = regEn# sclock iS en s' - in (o,iV,oR)) - --- | Create a 'DataFlow' circuit from a Moore machine description as those of --- "CLaSH.Prelude.Moore" -mooreDF :: (KnownSymbol nm, KnownNat rate) - => (s -> i -> s) - -> (s -> o) - -> s - -> DataFlow' ('Clk nm rate) Bool Bool i o -mooreDF ft fo iS = DF (\i iV oR -> let en = iV .&&. oR - s' = ft <$> s <*> i - s = regEn# sclock iS en s' - o = fo <$> s - in (o,iV,oR)) - -fifoDF_mealy :: forall addrSize a . KnownNat addrSize - => (Vec (2^addrSize) a, BitVector (addrSize + 1), BitVector (addrSize + 1)) - -> (a, Bool, Bool) - -> ((Vec (2^addrSize) a, BitVector (addrSize + 1), BitVector (addrSize + 1)) - ,(a, Bool, Bool)) -fifoDF_mealy (mem,rptr,wptr) (wdata,winc,rinc) = - let raddr = truncateB rptr :: BitVector addrSize - waddr = truncateB wptr :: BitVector addrSize - - mem' | winc && not full = replace waddr wdata mem - | otherwise = mem - - rdata = mem !! raddr - - rptr' = rptr + boolToBV (rinc && not empty) - wptr' = wptr + boolToBV (winc && not full) - empty = rptr == wptr - full = msb rptr /= msb wptr && raddr == waddr - in ((mem',rptr',wptr'), (rdata,empty,full)) - --- | Create a FIFO buffer adhering to the 'DataFlow' protocol. Can be filled --- with initial content. --- --- To create a FIFO of size 4, with two initial values 2 and 3 you would write: --- --- @ --- fifo4 = 'fifoDF' d4 (2 :> 3 :> Nil) --- @ -fifoDF :: forall addrSize m n a nm rate . - (KnownNat addrSize, KnownNat n, KnownNat m, (m + n) ~ (2 ^ addrSize), - KnownSymbol nm, KnownNat rate) - => SNat (m + n) -- ^ Depth of the FIFO buffer. Must be a power of two. - -> Vec m a -- ^ Initial content. Can be smaller than the size of the - -- FIFO. Empty spaces are initialised with 'undefined'. - -> DataFlow' ('Clk nm rate) Bool Bool a a -fifoDF _ iS = DF $ \i iV oR -> - let clk = sclock - initRdPtr = 0 - initWrPtr = fromIntegral (length iS) - initMem = iS ++ repeat undefined :: Vec (m + n) a - initS = (initMem,initRdPtr,initWrPtr) - (o,empty,full) = mealyB' clk fifoDF_mealy initS (i,iV,oR) - in (o,not <$> empty, not <$> full) - --- | Identity circuit --- --- <> -idDF :: DataFlow' clk en en a a -idDF = DF (\a val rdy -> (a,val,rdy)) - --- | Sequential composition of two 'DataFlow' circuits. --- --- <> -seqDF :: DataFlow' clk aEn bEn a b - -> DataFlow' clk bEn cEn b c - -> DataFlow' clk aEn cEn a c -(DF f) `seqDF` (DF g) = DF (\a aVal cRdy -> let (b,bVal,aRdy) = f a aVal bRdy - (c,cVal,bRdy) = g b bVal cRdy - in (c,cVal,aRdy)) - --- | Apply the circuit to the first halve of the communication channels, leave --- the second halve unchanged. --- --- <> -firstDF :: DataFlow' clk aEn bEn a b - -> DataFlow' clk (aEn,cEn) (bEn,cEn) (a,c) (b,c) -firstDF (DF f) = DF (\ac acV bcR -> let (a,c) = unbundle ac - (aV,cV) = unbundle acV - (bR,cR) = unbundle bcR - (b,bV,aR) = f a aV bR - bc = bundle (b,c) - bcV = bundle (bV,cV) - acR = bundle (aR,cR) - in (bc,bcV,acR) - ) - --- | Swap the two communication channels. --- --- <> -swapDF :: DataFlow' clk (aEn,bEn) (bEn,aEn) (a,b) (b,a) -swapDF = DF (\ab abV baR -> (swap <$> ab, swap <$> abV, swap <$> baR)) - where - swap ~(a,b) = (b,a) - --- | Apply the circuit to the second halve of the communication channels, leave --- the first halve unchanged. --- --- <> -secondDF :: DataFlow' clk aEn bEn a b - -> DataFlow' clk (cEn,aEn) (cEn,bEn) (c,a) (c,b) -secondDF f = swapDF `seqDF` firstDF f `seqDF` swapDF - --- | Compose two 'DataFlow' circuits in parallel. --- --- <> -parDF :: DataFlow' clk aEn bEn a b - -> DataFlow' clk cEn dEn c d - -> DataFlow' clk (aEn,cEn) (bEn,dEn) (a,c) (b,d) -f `parDF` g = firstDF f `seqDF` secondDF g - --- | Compose /n/ 'DataFlow' circuits in parallel. -parNDF :: KnownNat n - => Vec n (DataFlow' clk aEn bEn a b) - -> DataFlow' clk - (Vec n aEn) - (Vec n bEn) - (Vec n a) - (Vec n b) -parNDF fs = - DF (\as aVs bRs -> - let as' = unbundle as - aVs' = unbundle aVs - bRs' = unbundle bRs - (bs,bVs,aRs) = unzip3 (zipWith (\k (a,b,r) -> df k a b r) fs - (zip3 (lazyV as') (lazyV aVs') bRs')) - in (bundle bs,bundle bVs, bundle aRs) - ) - --- | Feed back the second halve of the communication channel. The feedback loop --- is buffered by a 'fifoDF' circuit. --- --- So given a circuit /h/ with two synchronisation channels: --- --- @ --- __h__ :: 'DataFlow' (Bool,Bool) (Bool,Bool) (a,d) (b,d) --- @ --- --- Feeding back the /d/ part (including its synchronisation channels) results --- in: --- --- @ --- 'loopDF' d4 Nil h --- @ --- --- <> --- --- When you have a circuit @h'@, with only a single synchronisation channel: --- --- @ --- __h'__ :: 'DataFlow' Bool Bool (a,d) (b,d) --- @ --- --- and you want to compose /h'/ in a feedback loop, the following will not work: --- --- @ --- f \`@'seqDF'@\` ('loopDF' d4 Nil h') \`@'seqDF'@\` g --- @ --- --- The circuits @f@, @h@, and @g@, must operate in /lock-step/ because the /h'/ --- circuit only has a single synchronisation channel. Consequently, there --- should only be progress when all three circuits are producing /valid/ data --- and all three circuits are /ready/ to receive new data. We need to compose --- /h'/ with the 'lockStep' and 'stepLock' functions to achieve the /lock-step/ --- operation. --- --- @ --- f \`@'seqDF'@\` ('lockStep' \`@'seqDF'@\` 'loopDF' d4 Nil h' \`@'seqDF'@\` 'stepLock') \`@'seqDF'@\` g --- @ --- --- <> -loopDF :: (KnownNat m, KnownNat n, KnownNat addrSize, KnownNat rate - ,KnownSymbol nm,(m+n) ~ (2^addrSize)) - => SNat (m + n) -- ^ Depth of the FIFO buffer. Must be a power of two - -> Vec m d -- ^ Initial content of the FIFO buffer. Can be smaller than - -- the size of the FIFO. Empty spaces are initialised with - -- 'undefined'. - -> DataFlow' ('Clk nm rate) (Bool,Bool) (Bool,Bool) (a,d) (b,d) - -> DataFlow' ('Clk nm rate) Bool Bool a b -loopDF sz is (DF f) = - DF (\a aV bR -> let (bd,bdV,adR) = f ad adV bdR - (b,d) = unbundle bd - (bV,dV) = unbundle bdV - (aR,dR) = unbundle adR - (d_buf,dV_buf,dR_buf) = df (fifoDF sz is) d dV dR - - ad = bundle (a,d_buf) - adV = bundle (aV,dV_buf) - bdR = bundle (bR,dR_buf) - in (b,bV,aR) - ) - --- | Feed back the second halve of the communication channel. Unlike 'loopDF', --- the feedback loop is /not/ buffered. -loopDF_nobuf :: DataFlow' clk (Bool,Bool) (Bool,Bool) (a,d) (b,d) - -> DataFlow' clk Bool Bool a b -loopDF_nobuf (DF f) = DF (\a aV bR -> let (bd,bdV,adR) = f ad adV bdR - (b,d) = unbundle bd - (bV,dV) = unbundle bdV - (aR,dR) = unbundle adR - ad = bundle (a,d) - adV = bundle (aV,dV) - bdR = bundle (bR,dR) - in (b,bV,aR) - ) - --- | Reduce or extend the synchronisation granularity of parallel compositions. -class LockStep a b where - -- | Reduce the synchronisation granularity to a single 'Bool'ean value. - -- - -- Given: - -- - -- @ - -- __f__ :: 'DataFlow' Bool Bool a b - -- __g__ :: 'DataFlow' Bool Bool c d - -- __h__ :: 'DataFlow' Bool Bool (b,d) (p,q) - -- @ - -- - -- We /cannot/ simply write: - -- - -- @ - -- (f \`@'parDF'@\` g) \`@'seqDF'@\` h - -- @ - -- - -- because, @f \`parDF\` g@, has type, @'DataFlow' (Bool,Bool) (Bool,Bool) (a,c) (b,d)@, - -- which does not match the expected synchronisation granularity of @h@. We - -- need a circuit in between that has the type: - -- - -- @ - -- 'DataFlow' (Bool,Bool) Bool (b,d) (b,d) - -- @ - -- - -- Simply '&&'-ing the /valid/ signals in the forward direction, and - -- duplicating the /ready/ signal in the backward direction is however not - -- enough. We also need to make sure that @f@ does not update its output when - -- @g@'s output is invalid and visa versa, as @h@ can only consume its input - -- when both @f@ and @g@ are producing valid data. @g@'s /ready/ port is hence - -- only asserted when @h@ is ready and @f@ is producing /valid/ data. And @f@'s - -- ready port is only asserted when @h@ is ready and @g@ is producing valid - -- data. @f@ and @g@ will hence be proceeding in /lock-step/. - -- - -- The 'lockStep' function ensures that all synchronisation signals are - -- properly connected: - -- - -- @ - -- (f \`@'parDF'@\` g) \`@'seqDF'@\` 'lockStep' \`@'seqDF'@\` h - -- @ - -- - -- <> - -- - -- __Note 1__: ensure that the components that you are synchronising have - -- buffered/delayed @ready@ and @valid@ signals, or 'lockStep' has the - -- potential to introduce combinational loops. You can do this by placing - -- 'fifoDF's on the parallel channels. Extending the above example, you would - -- write: - -- - -- @ - -- ((f \`@'seqDF'@\` 'fifoDF' d4 Nil) \`@'parDF'@\` (g \`@'seqDF'@\` 'fifoDF' d4 Nil)) \`@'seqDF'@\` 'lockStep' \`@'seqDF'@\` h - -- @ - -- - -- __Note 2__: 'lockStep' works for arbitrarily nested tuples. That is: - -- - -- @ - -- p :: 'DataFlow' Bool Bool ((b,d),d) z - -- - -- q :: 'DataFlow' ((Bool,Bool),Bool) ((Bool,Bool),Bool) ((a,c),c) ((b,d),d) - -- q = f \`@'parDF'@\` g \`@'parDF'@\` g - -- - -- r = q \`@'seqDF'@\` 'lockStep' \`@'seqDF'@\` p - -- @ - -- - -- Does the right thing. - lockStep :: DataFlow' clk a Bool b b - - -- | Extend the synchronisation granularity from a single 'Bool'ean value. - -- - -- Given: - -- - -- @ - -- __f__ :: 'DataFlow' Bool Bool a b - -- __g__ :: 'DataFlow' Bool Bool c d - -- __h__ :: 'DataFlow' Bool Bool (p,q) (a,c) - -- @ - -- - -- We /cannot/ simply write: - -- - -- @ - -- h \`@'seqDF'@\` (f \`@'parDF'@\` g) - -- @ - -- - -- because, @f \`parDF\` g@, has type, @'DataFlow' (Bool,Bool) (Bool,Bool) (a,c) (b,d)@, - -- which does not match the expected synchronisation granularity of @h@. We - -- need a circuit in between that has the type: - -- - -- @ - -- 'DataFlow' Bool (Bool,Bool) (a,c) (a,c) - -- @ - -- - -- Simply '&&'-ing the /ready/ signals in the backward direction, and - -- duplicating the /valid/ signal in the forward direction is however not - -- enough. We need to make sure that @f@ does not consume values when @g@ is - -- not /ready/ and visa versa, because @h@ cannot update the values of its - -- output tuple independently. @f@'s /valid/ port is hence only asserted when - -- @h@ is valid and @g@ is ready to receive new values. @g@'s /valid/ port is - -- only asserted when @h@ is valid and @f@ is ready to receive new values. - -- @f@ and @g@ will hence be proceeding in /lock-step/. - -- - -- The 'stepLock' function ensures that all synchronisation signals are - -- properly connected: - -- - -- @ - -- h \`@'seqDF'@\` 'stepLock' \`@'seqDF'@\` (f \`@'parDF'@\` g) - -- @ - -- - -- <> - -- - -- __Note 1__: ensure that the components that you are synchronising have - -- buffered/delayed @ready@ and @valid@ signals, or 'stepLock' has the - -- potential to introduce combinational loops. You can do this by placing - -- 'fifoDF's on the parallel channels. Extending the above example, you would - -- write: - -- - -- @ - -- h \`@'seqDF'@\` 'stepLock' \`@'seqDF'@\` ((`fifoDF` d4 Nil \`@'seqDF'@\` f) \`@'parDF'@\` (`fifoDF` d4 Nil \`@'seqDF'@\` g)) - -- @ - -- - -- __Note 2__: 'stepLock' works for arbitrarily nested tuples. That is: - -- - -- @ - -- p :: 'DataFlow' Bool Bool z ((a,c),c) - -- - -- q :: 'DataFlow' ((Bool,Bool),Bool) ((Bool,Bool),Bool) ((a,c),c) ((b,d),d) - -- q = f \`@'parDF'@\` g \`@'parDF'@\` g - -- - -- r = p \`@'seqDF'@\` 'stepLock' \`@'seqDF'@\` q - -- @ - -- - -- Does the right thing. - stepLock :: DataFlow' clk Bool a b b - -instance LockStep Bool c where - lockStep = idDF - stepLock = idDF - -instance (LockStep a x, LockStep b y) => LockStep (a,b) (x,y) where - lockStep = (lockStep `parDF` lockStep) `seqDF` - (DF (\xy xyV rdy -> let (xV,yV) = unbundle xyV - val = xV .&&. yV - xR = yV .&&. rdy - yR = xV .&&. rdy - xyR = bundle (xR,yR) - in (xy,val,xyR))) - - stepLock = (DF (\xy val xyR -> let (xR,yR) = unbundle xyR - rdy = xR .&&. yR - xV = val .&&. yR - yV = val .&&. xR - xyV = bundle (xV,yV) - in (xy,xyV,rdy))) `seqDF` (stepLock `parDF` stepLock) - -instance (LockStep en a, KnownNat n) => LockStep (Vec n en) (Vec n a) where - lockStep = parNDF (repeat lockStep) `seqDF` - DF (\xs vals rdy -> - let val = (and . (True :>)) <$> vals - rdys = allReady <$> rdy <*> (repeat . (:< True) <$> vals) - in (xs,val,rdys) - ) - stepLock = - DF (\xs val rdys -> - let rdy = (and . (True :>)) <$> rdys - vals = allReady <$> val <*> (repeat . (:< True) <$> rdys) - in (xs,vals,rdy) - ) `seqDF` parNDF (repeat stepLock) - -allReady :: KnownNat n - => Bool - -> Vec n (Vec (n+1) Bool) - -> Vec n Bool -allReady b vs = map (and . (b :>) . tail) (smap (flip rotateLeftS) vs) diff --git a/src/CLaSH/Prelude/Explicit.hs b/src/CLaSH/Prelude/Explicit.hs deleted file mode 100644 --- a/src/CLaSH/Prelude/Explicit.hs +++ /dev/null @@ -1,136 +0,0 @@ -{-| -Copyright : (C) 2013-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij - -This module defines the explicitly clocked counterparts of the functions -defined in "CLaSH.Prelude". - -This module uses the explicitly clocked 'Signal'' synchronous signals, as -opposed to the implicitly clocked 'Signal' used in "CLaSH.Prelude". Take a -look at "CLaSH.Signal.Explicit" to see how you can make multi-clock designs -using explicitly clocked signals. --} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} - -{-# LANGUAGE Unsafe #-} - -{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Prelude.Explicit - ( -- * Creating synchronous sequential circuits - mealy' - , mealyB' - , moore' - , mooreB' - , registerB' - -- * Synchronizer circuits for safe clock domain crossings - , dualFlipFlopSynchronizer - , asyncFIFOSynchronizer - -- * ROMs - , rom' - , romPow2' - -- ** ROMs initialised with a data file - , romFile' - , romFilePow2' - -- * RAM primitives with a combinational read port - , asyncRam' - , asyncRamPow2' - -- * BlockRAM primitives - , blockRam' - , blockRamPow2' - -- ** BlockRAM primitives initialised with a data file - , blockRamFile' - , blockRamFilePow2' - -- * Utility functions - , window' - , windowD' - , isRising' - , isFalling' - -- * Testbench functions - , assert' - , stimuliGenerator' - , outputVerifier' - -- * Exported modules - -- ** Explicitly clocked synchronous signals - , module CLaSH.Signal.Explicit - ) -where - -import Data.Default (Default (..)) -import GHC.TypeLits (KnownNat, type (+), natVal) -import Prelude hiding (repeat) - -import CLaSH.Prelude.Explicit.Safe -import CLaSH.Prelude.BlockRam.File (blockRamFile', blockRamFilePow2') -import CLaSH.Prelude.ROM.File (romFile', romFilePow2') -import CLaSH.Prelude.Testbench (assert', stimuliGenerator', outputVerifier') -import CLaSH.Signal.Explicit -import CLaSH.Sized.Vector (Vec (..), (+>>), asNatProxy, repeat) - -{- $setup ->>> :set -XDataKinds ->>> import CLaSH.Prelude ->>> type ClkA = Clk "A" 100 ->>> let clkA = sclock :: SClock ClkA ->>> let window4 = window' clkA :: Signal' ClkA Int -> Vec 4 (Signal' ClkA Int) ->>> let windowD3 = windowD' clkA :: Signal' ClkA Int -> Vec 3 (Signal' ClkA Int) --} - -{-# INLINABLE window' #-} --- | Give a window over a 'Signal'' --- --- @ --- type ClkA = 'Clk' \"A\" 100 --- --- clkA :: 'SClock' ClkA --- clkA = 'sclock' --- --- window4 :: 'Signal'' ClkA Int -> 'Vec' 4 ('Signal'' ClkA Int) --- window4 = 'window'' clkA --- @ --- --- >>> simulateB window4 [1::Int,2,3,4,5] :: [Vec 4 Int] --- [<1,0,0,0>,<2,1,0,0>,<3,2,1,0>,<4,3,2,1>,<5,4,3,2>... --- ... -window' :: (KnownNat n, Default a) - => SClock clk -- ^ Clock to which the incoming - -- signal is synchronized - -> Signal' clk a -- ^ Signal to create a window over - -> Vec (n + 1) (Signal' clk a) -- ^ Window of at least size 1 -window' clk x = res - where - res = x :> prev - prev = case natVal (asNatProxy prev) of - 0 -> repeat def - _ -> let next = x +>> prev - in registerB' clk (repeat def) next - -{-# INLINABLE windowD' #-} --- | Give a delayed window over a 'Signal'' --- --- @ --- type ClkA = 'Clk' \"A\" 100 --- --- clkA :: 'SClock' ClkA --- clkA = 'sclock' --- --- windowD3 :: 'Signal'' ClkA Int -> 'Vec' 3 ('Signal'' ClkA Int) --- windowD3 = 'windowD'' clkA --- @ --- --- >>> simulateB windowD3 [1::Int,2,3,4] :: [Vec 3 Int] --- [<0,0,0>,<1,0,0>,<2,1,0>,<3,2,1>,<4,3,2>... --- ... -windowD' :: (KnownNat n, Default a) - => SClock clk -- ^ Clock to which the incoming signal - -- is synchronized - -> Signal' clk a -- ^ Signal to create a window over - -> Vec (n + 1) (Signal' clk a) -- ^ Window of at least size 1 -windowD' clk x = - let prev = registerB' clk (repeat def) next - next = x +>> prev - in prev diff --git a/src/CLaSH/Prelude/Explicit/Safe.hs b/src/CLaSH/Prelude/Explicit/Safe.hs deleted file mode 100644 --- a/src/CLaSH/Prelude/Explicit/Safe.hs +++ /dev/null @@ -1,148 +0,0 @@ -{-| -Copyright : (C) 2013-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij - -__This is the API only of "CLaSH.Prelude.Explicit"__ - -This module defines the explicitly clocked counterparts of the functions -defined in "CLaSH.Prelude". - -This module uses the explicitly clocked 'Signal'' synchronous signals, as -opposed to the implicitly clocked 'Signal' used in "CLaSH.Prelude". Take a -look at "CLaSH.Signal.Explicit" to see how you can make multi-clock designs -using explicitly clocked signals. --} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{-# LANGUAGE Safe #-} - -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Prelude.Explicit.Safe - ( -- * Creating synchronous sequential circuits - mealy' - , mealyB' - , moore' - , mooreB' - , registerB' - -- * Synchronizer circuits for safe clock domain crossing - , dualFlipFlopSynchronizer - , asyncFIFOSynchronizer - -- * ROMs - , rom' - , romPow2' - -- * RAM primitives with a combinational read port - , asyncRam' - , asyncRamPow2' - -- * BlockRAM primitives - , blockRam' - , blockRamPow2' - -- * Utility functions - , isRising' - , isFalling' - , riseEvery' - , oscillate' - -- * Exported modules - -- ** Explicitly clocked synchronous signals - , module CLaSH.Signal.Explicit - ) -where - -import GHC.TypeLits -import Control.Applicative (liftA2) -import Prelude hiding (repeat) - -import CLaSH.Prelude.BlockRam (blockRam', blockRamPow2') -import CLaSH.Prelude.Mealy (mealy', mealyB') -import CLaSH.Prelude.Moore (moore', mooreB') -import CLaSH.Prelude.RAM (asyncRam',asyncRamPow2') -import CLaSH.Prelude.ROM (rom', romPow2') -import CLaSH.Prelude.Synchronizer (dualFlipFlopSynchronizer, - asyncFIFOSynchronizer) -import CLaSH.Promoted.Nat (SNat(..)) -import CLaSH.Sized.Index (Index) -import CLaSH.Signal.Bundle (Bundle(..), Unbundled') -import CLaSH.Signal.Explicit -import CLaSH.Sized.Unsigned - - -{- $setup ->>> :set -XDataKinds ->>> import CLaSH.Prelude ->>> type ClkA = Clk "A" 100 ->>> let clkA = sclock :: SClock ClkA ->>> let rP = registerB' clkA (8::Int,8::Int) --} - -{-# INLINE registerB' #-} --- | Create a 'register' function for product-type like signals (e.g. --- @('Signal' a, 'Signal' b)@) --- --- @ --- type ClkA = 'Clk' \"A\" 100 --- --- clkA :: 'SClock' ClkA --- clkA = 'sclock' --- --- rP :: ('Signal'' ClkA Int, 'Signal'' ClkA Int) -> ('Signal'' ClkA Int, 'Signal'' ClkA Int) --- rP = 'registerB'' clkA (8,8) --- @ --- --- >>> simulateB rP [(1,1),(2,2),(3,3)] :: [(Int,Int)] --- [(8,8),(1,1),(2,2),(3,3)... --- ... -registerB' :: Bundle a => SClock clk -> a -> Unbundled' clk a -> Unbundled' clk a -registerB' clk i = unbundle Prelude.. register' clk i Prelude.. bundle - -{-# INLINABLE isRising' #-} --- | Give a pulse when the 'Signal'' goes from 'minBound' to 'maxBound' -isRising' :: (Bounded a, Eq a) - => SClock clk - -> a -- ^ Starting value - -> Signal' clk a - -> Signal' clk Bool -isRising' clk is s = liftA2 edgeDetect prev s - where - prev = register' clk is s - edgeDetect old new = old == minBound && new == maxBound - -{-# INLINABLE isFalling' #-} --- | Give a pulse when the 'Signal'' goes from 'maxBound' to 'minBound' -isFalling' :: (Bounded a, Eq a) - => SClock clk - -> a -- ^ Starting value - -> Signal' clk a - -> Signal' clk Bool -isFalling' clk is s = liftA2 edgeDetect prev s - where - prev = register' clk is s - edgeDetect old new = old == maxBound && new == minBound - -{-# INLINEABLE riseEvery' #-} --- | Give a pulse every @n@ clock cycles. This is a useful helper function when --- combined with functions like @'CLaSH.Signal.regEn'@ or @'CLaSH.Signal.mux'@, --- in order to delay a register by a known amount. -riseEvery' :: forall clk n. KnownNat n => SClock clk -> SNat n -> Signal' clk Bool -riseEvery' clk SNat = moore' clk transfer output 0 (pure ()) - where - output :: Index n -> Bool - output = (== maxBound) - - transfer :: Index n -> () -> Index n - transfer s _ = if (s == maxBound) then 0 else s+1 - -{-# INLINEABLE oscillate' #-} --- | Oscillate a @'Bool'@ for a given number of cycles, given the starting state. -oscillate' :: forall clk n. KnownNat n => SClock clk -> Bool -> SNat n -> Signal' clk Bool -oscillate' clk begin SNat = moore' clk transfer snd (0, begin) (pure ()) - where - transfer :: (Index n, Bool) -> () -> (Index n, Bool) - transfer (s, i) _ = - if s == maxBound - then (0, not i) -- reset state and oscillate output - else (s+1, i) -- hold current output diff --git a/src/CLaSH/Prelude/Mealy.hs b/src/CLaSH/Prelude/Mealy.hs deleted file mode 100644 --- a/src/CLaSH/Prelude/Mealy.hs +++ /dev/null @@ -1,222 +0,0 @@ -{-| - Copyright : (C) 2013-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Whereas the output of a Moore machine depends on the /previous state/, the - outputof a Mealy machine depends on /current transition/. - - Mealy machines are strictly more expressive, but may impose stricter timing - requirements. --} - -{-# LANGUAGE Safe #-} - -module CLaSH.Prelude.Mealy - ( -- * Mealy machine synchronised to the system clock - mealy - , mealyB - , (<^>) - -- * Mealy machine synchronised to an arbitrary clock - , mealy' - , mealyB' - ) -where - -import CLaSH.Signal (Signal, Unbundled) -import CLaSH.Signal.Explicit (Signal', SClock, register', systemClock) -import CLaSH.Signal.Bundle (Bundle (..), Unbundled') - -{- $setup ->>> :set -XDataKinds ->>> import CLaSH.Prelude ->>> :{ -let mac s (x,y) = (s',s) - where - s' = x * y + s - topEntity = mealy mac 0 -:} - ->>> import CLaSH.Prelude.Explicit ->>> type ClkA = Clk "A" 100 ->>> let clkA = sclock :: SClock ClkA ->>> :{ -let mac s (x,y) = (s',s) - where - s' = x * y + s -:} - ->>> let topEntity = mealy' clkA mac 0 --} - -{-# INLINE mealy #-} --- | Create a synchronous function from a combinational function describing --- a mealy machine --- --- @ --- mac :: Int -- Current state --- -> (Int,Int) -- Input --- -> (Int,Int) -- (Updated state, output) --- mac s (x,y) = (s',s) --- where --- s' = x * y + s --- --- topEntity :: 'Signal' (Int, Int) -> 'Signal' Int --- topEntity = 'mealy' mac 0 --- @ --- --- >>> simulate topEntity [(1,1),(2,2),(3,3),(4,4)] --- [0,1,5,14... --- ... --- --- Synchronous sequential functions can be composed just like their --- combinational counterpart: --- --- @ --- dualMac :: ('Signal' Int, 'Signal' Int) --- -> ('Signal' Int, 'Signal' Int) --- -> 'Signal' Int --- dualMac (a,b) (x,y) = s1 + s2 --- where --- s1 = 'mealy' mac 0 ('CLaSH.Signal.bundle' (a,x)) --- s2 = 'mealy' mac 0 ('CLaSH.Signal.bundle' (b,y)) --- @ -mealy :: (s -> i -> (s,o)) -- ^ Transfer function in mealy machine form: - -- @state -> input -> (newstate,output)@ - -> s -- ^ Initial state - -> (Signal i -> Signal o) - -- ^ Synchronous sequential function with input and output matching that - -- of the mealy machine -mealy = mealy' systemClock - -{-# INLINE mealyB #-} --- | A version of 'mealy' that does automatic 'Bundle'ing --- --- Given a function @f@ of type: --- --- @ --- __f__ :: Int -> (Bool, Int) -> (Int, (Int, Bool)) --- @ --- --- When we want to make compositions of @f@ in @g@ using 'mealy', we have to --- write: --- --- @ --- g a b c = (b1,b2,i2) --- where --- (i1,b1) = 'CLaSH.Signal.unbundle' ('mealy' f 0 ('CLaSH.Signal.bundle' (a,b))) --- (i2,b2) = 'CLaSH.Signal.unbundle' ('mealy' f 3 ('CLaSH.Signal.bundle' (i1,c))) --- @ --- --- Using 'mealyB' however we can write: --- --- @ --- g a b c = (b1,b2,i2) --- where --- (i1,b1) = 'mealyB' f 0 (a,b) --- (i2,b2) = 'mealyB' f 3 (i1,c) --- @ -mealyB :: (Bundle i, Bundle o) - => (s -> i -> (s,o)) -- ^ Transfer function in mealy machine form: - -- @state -> input -> (newstate,output)@ - -> s -- ^ Initial state - -> (Unbundled i -> Unbundled o) - -- ^ Synchronous sequential function with input and output matching that - -- of the mealy machine -mealyB = mealyB' systemClock - -{-# INLINE (<^>) #-} --- | Infix version of 'mealyB' -(<^>) :: (Bundle i, Bundle o) - => (s -> i -> (s,o)) -- ^ Transfer function in mealy machine form: - -- @state -> input -> (newstate,output)@ - -> s -- ^ Initial state - -> (Unbundled i -> Unbundled o) - -- ^ Synchronous sequential function with input and output matching that - -- of the mealy machine -(<^>) = mealyB - -{-# INLINABLE mealy' #-} --- | Create a synchronous function from a combinational function describing --- a mealy machine --- --- @ --- mac :: Int -- Current state --- -> (Int,Int) -- Input --- -> (Int,Int) -- (Updated state, output) --- mac s (x,y) = (s',s) --- where --- s' = x * y + s --- --- type ClkA = 'CLaSH.Signal.Explicit.Clk' \"A\" 100 --- --- clkA :: 'SClock' ClkA --- clkA = 'CLaSH.Signal.Explicit.sclock' --- --- topEntity :: 'Signal'' ClkA (Int, Int) -> 'Signal'' ClkA Int --- topEntity = 'mealy'' clkA mac 0 --- @ --- --- >>> simulate topEntity [(1,1),(2,2),(3,3),(4,4)] --- [0,1,5,14... --- ... --- --- Synchronous sequential functions can be composed just like their --- combinational counterpart: --- --- @ --- dualMac :: ('Signal'' clkA100 Int, 'Signal'' clkA100 Int) --- -> ('Signal'' clkA100 Int, 'Signal'' clkA100 Int) --- -> 'Signal'' clkA100 Int --- dualMac (a,b) (x,y) = s1 + s2 --- where --- s1 = 'mealy'' clkA100 mac 0 ('CLaSH.Signal.Explicit.bundle'' clkA100 (a,x)) --- s2 = 'mealy'' clkA100 mac 0 ('CLaSH.Signal.Explicit.bundle'' clkA100 (b,y)) --- @ -mealy' :: SClock clk -- ^ 'Clock' to synchronize to - -> (s -> i -> (s,o)) -- ^ Transfer function in mealy machine form: - -- @state -> input -> (newstate,output)@ - -> s -- ^ Initial state - -> (Signal' clk i -> Signal' clk o) - -- ^ Synchronous sequential function with input and output matching that - -- of the mealy machine -mealy' clk f iS = \i -> let (s',o) = unbundle $ f <$> s <*> i - s = register' clk iS s' - in o - -{-# INLINE mealyB' #-} --- | A version of 'mealy'' that does automatic 'Bundle'ing --- --- Given a function @f@ of type: --- --- @ --- __f__ :: Int -> (Bool,Int) -> (Int,(Int,Bool)) --- @ --- --- When we want to make compositions of @f@ in @g@ using 'mealy'', we have to --- write: --- --- @ --- g clk a b c = (b1,b2,i2) --- where --- (i1,b1) = 'CLaSH.Signal.Explicit.unbundle'' clk (mealy' clk f 0 ('CLaSH.Signal.Explicit.bundle'' clk (a,b))) --- (i2,b2) = 'CLaSH.Signal.Explicit.unbundle'' clk (mealy' clk f 3 ('CLaSH.Signal.Explicit.bundle'' clk (i1,c))) --- @ --- --- Using 'mealyB'' however we can write: --- --- @ --- g clk a b c = (b1,b2,i2) --- where --- (i1,b1) = 'mealyB'' clk f 0 (a,b) --- (i2,b2) = 'mealyB'' clk f 3 (i1,c) --- @ -mealyB' :: (Bundle i, Bundle o) - => SClock clk - -> (s -> i -> (s,o)) -- ^ Transfer function in mealy machine form: - -- @state -> input -> (newstate,output)@ - -> s -- ^ Initial state - -> (Unbundled' clk i -> Unbundled' clk o) - -- ^ Synchronous sequential function with input and output matching that - -- of the mealy machine -mealyB' clk f iS i = unbundle (mealy' clk f iS (bundle i)) diff --git a/src/CLaSH/Prelude/Moore.hs b/src/CLaSH/Prelude/Moore.hs deleted file mode 100644 --- a/src/CLaSH/Prelude/Moore.hs +++ /dev/null @@ -1,236 +0,0 @@ -{-| - Copyright : (C) 2013-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - Whereas the output of a Mealy machine depends on /current transition/, the - output of a Moore machine depends on the /previous state/. - - Moore machines are strictly less expressive, but may impose laxer timing - requirements. --} - -{-# LANGUAGE Safe #-} - -module CLaSH.Prelude.Moore - ( -- * Moore machine synchronised to the system clock - moore - , mooreB - , medvedev - , medvedevB - -- * Moore machine synchronised to an arbitrary clock - , moore' - , mooreB' - , medvedev' - , medvedevB' - ) -where - -import CLaSH.Signal (Signal, Unbundled) -import CLaSH.Signal.Explicit (Signal', SClock, register', systemClock) -import CLaSH.Signal.Bundle (Bundle (..), Unbundled') - -{- $setup ->>> :set -XDataKinds ->>> import CLaSH.Prelude ->>> :{ -let mac s (x,y) = x * y + s - topEntity = moore mac id 0 -:} - ->>> import CLaSH.Prelude.Explicit ->>> type ClkA = Clk "A" 100 ->>> let clkA = sclock :: SClock ClkA ->>> let mac s (x,y) = x * y + s - ->>> let topEntity = moore' clkA mac id 0 --} - -{-# INLINE moore #-} --- | Create a synchronous function from a combinational function describing --- a moore machine --- --- @ --- mac :: Int -- Current state --- -> (Int,Int) -- Input --- -> Int -- Updated state --- mac s (x,y) = x * y + s --- --- topEntity :: 'Signal' (Int, Int) -> 'Signal' Int --- topEntity = 'moore' mac id 0 --- @ --- --- >>> simulate topEntity [(1,1),(2,2),(3,3),(4,4)] --- [0,1,5,14... --- ... --- --- Synchronous sequential functions can be composed just like their --- combinational counterpart: --- --- @ --- dualMac :: ('Signal' Int, 'Signal' Int) --- -> ('Signal' Int, 'Signal' Int) --- -> 'Signal' Int --- dualMac (a,b) (x,y) = s1 + s2 --- where --- s1 = 'moore' mac id 0 ('CLaSH.Signal.bundle' (a,x)) --- s2 = 'moore' mac id 0 ('CLaSH.Signal.bundle' (b,y)) --- @ -moore :: (s -> i -> s) -- ^ Transfer function in moore machine form: - -- @state -> input -> newstate@ - -> (s -> o) -- ^ Output function in moore machine form: - -- @state -> output@ - -> s -- ^ Initial state - -> (Signal i -> Signal o) - -- ^ Synchronous sequential function with input and output matching that - -- of the moore machine -moore = moore' systemClock - -{-# INLINE medvedev #-} --- | Create a synchronous function from a combinational function describing --- a moore machine without any output logic -medvedev :: (s -> i -> s) -> s -> Signal i -> Signal s -medvedev tr st = moore tr id st - -{-# INLINE mooreB #-} --- | A version of 'moore' that does automatic 'Bundle'ing --- --- Given a functions @t@ and @o@ of types: --- --- @ --- __t__ :: Int -> (Bool, Int) -> Int --- __o__ :: Int -> (Int, Bool) --- @ --- --- When we want to make compositions of @t@ and @o@ in @g@ using 'moore', we have to --- write: --- --- @ --- g a b c = (b1,b2,i2) --- where --- (i1,b1) = 'CLaSH.Signal.unbundle' ('moore' t o 0 ('CLaSH.Signal.bundle' (a,b))) --- (i2,b2) = 'CLaSH.Signal.unbundle' ('moore' t o 3 ('CLaSH.Signal.bundle' (i1,c))) --- @ --- --- Using 'mooreB' however we can write: --- --- @ --- g a b c = (b1,b2,i2) --- where --- (i1,b1) = 'mooreB' t o 0 (a,b) --- (i2,b2) = 'mooreB' t o 3 (i1,c) --- @ -mooreB :: (Bundle i, Bundle o) - => (s -> i -> s) -- ^ Transfer function in moore machine form: - -- @state -> input -> newstate@ - -> (s -> o) -- ^ Output function in moore machine form: - -- @state -> output@ - -> s -- ^ Initial state - -> (Unbundled i -> Unbundled o) - -- ^ Synchronous sequential function with input and output matching that - -- of the moore machine -mooreB = mooreB' systemClock - -{-# INLINE medvedevB #-} --- | A version of 'medvedev' that does automatic 'Bundle'ing -medvedevB :: (Bundle i, Bundle s) => (s -> i -> s) -> s -> Unbundled i -> Unbundled s -medvedevB tr st = mooreB tr id st - -{-# INLINABLE moore' #-} --- | Create a synchronous function from a combinational function describing --- a moore machine --- --- @ --- mac :: Int -- Current state --- -> (Int,Int) -- Input --- -> (Int,Int) -- Updated state --- mac s (x,y) = x * y + s --- --- type ClkA = 'CLaSH.Signal.Explicit.Clk' \"A\" 100 --- --- clkA :: 'SClock' ClkA --- clkA = 'CLaSH.Signal.Explicit.sclock' --- --- topEntity :: 'Signal'' ClkA (Int, Int) -> 'Signal'' ClkA Int --- topEntity = 'moore'' clkA mac id 0 --- @ --- --- >>> simulate topEntity [(1,1),(2,2),(3,3),(4,4)] --- [0,1,5,14... --- ... --- --- Synchronous sequential functions can be composed just like their --- combinational counterpart: --- --- @ --- dualMac :: ('Signal'' clkA Int, 'Signal'' clkA Int) --- -> ('Signal'' clkA Int, 'Signal'' clkA Int) --- -> 'Signal'' clkA Int --- dualMac (a,b) (x,y) = s1 + s2 --- where --- s1 = 'moore'' clkA mac id 0 ('CLaSH.Signal.Explicit.bundle'' clkA (a,x)) --- s2 = 'moore'' clkA mac id 0 ('CLaSH.Signal.Explicit.bundle'' clkA (b,y)) --- @ -moore' :: SClock clk -- ^ 'Clock' to synchronize to - -> (s -> i -> s) -- ^ Transfer function in moore machine form: - -- @state -> input -> newstate@ - -> (s -> o) -- ^ Output function in moore machine form: - -- @state -> output@ - -> s -- ^ Initial state - -> (Signal' clk i -> Signal' clk o) - -- ^ Synchronous sequential function with input and output matching that - -- of the moore machine -moore' clk ft fo iS = \i -> let s' = ft <$> s <*> i - s = register' clk iS s' - in fo <$> s - -{-# INLINE medvedev' #-} --- | Create a synchronous function from a combinational function describing --- a moore machine without any output logic -medvedev' :: SClock clk -> (s -> i -> s) -> s -> (Signal' clk i -> Signal' clk s) -medvedev' clk tr st = moore' clk tr id st - -{-# INLINE mooreB' #-} --- | A version of 'moore'' that does automatic 'Bundle'ing --- --- Given a functions @t@ and @o@ of types: --- --- @ --- __t__ :: Int -> (Bool, Int) -> Int --- __o__ :: Int -> (Int, Bool) --- @ --- --- When we want to make compositions of @t@ and @o@ in @g@ using 'moore'', we have to --- write: --- --- @ --- g clk a b c = (b1,b2,i2) --- where --- (i1,b1) = 'CLaSH.Signal.Explicit.unbundle'' clk (moore' clk t o 0 ('CLaSH.Signal.Explicit.bundle'' clk (a,b))) --- (i2,b2) = 'CLaSH.Signal.Explicit.unbundle'' clk (moore' clk t o 3 ('CLaSH.Signal.Explicit.bundle'' clk (i1,c))) --- @ --- --- Using 'mooreB'' however we can write: --- --- @ --- g clk a b c = (b1,b2,i2) --- where --- (i1,b1) = 'mooreB'' clk t o 0 (a,b) --- (i2,b2) = 'mooreB'' clk to 3 (i1,c) --- @ -mooreB' :: (Bundle i, Bundle o) - => SClock clk - -> (s -> i -> s) -- ^ Transfer function in moore machine form: - -- @state -> input -> newstate@ - -> (s -> o) -- ^ Output function in moore machine form: - -- @state -> output@ - -> s -- ^ Initial state - -> (Unbundled' clk i -> Unbundled' clk o) - -- ^ Synchronous sequential function with input and output matching that - -- of the moore machine -mooreB' clk ft fo iS i = unbundle (moore' clk ft fo iS (bundle i)) - -{-# INLINE medvedevB' #-} --- | A version of 'medvedev'' that does automatic 'Bundle'ing -medvedevB' :: (Bundle i, Bundle s) => SClock clk -> (s -> i -> s) -> s -> Unbundled' clk i -> Unbundled' clk s -medvedevB' clk tr st = mooreB' clk tr id st diff --git a/src/CLaSH/Prelude/RAM.hs b/src/CLaSH/Prelude/RAM.hs deleted file mode 100644 --- a/src/CLaSH/Prelude/RAM.hs +++ /dev/null @@ -1,157 +0,0 @@ -{-| -Copyright : (C) 2015-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij - -RAM primitives with a combinational read port. --} - -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -{-# LANGUAGE Trustworthy #-} - --- See: https://github.com/clash-lang/clash-compiler/commit/721fcfa9198925661cd836668705f817bddaae3c --- as to why we need this. -{-# OPTIONS_GHC -fno-cpr-anal #-} - -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Prelude.RAM - ( -- * RAM synchronised to the system clock - asyncRam - , asyncRamPow2 - -- * RAM synchronised to an arbitrary clock - , asyncRam' - , asyncRamPow2' - -- * Internal - , asyncRam# - ) -where - -import Data.Maybe (fromJust, isJust) -import GHC.TypeLits (KnownNat) -import qualified Data.Vector as V - -import CLaSH.Promoted.Nat (SNat (..), snatToNum, pow2SNat) -import CLaSH.Signal (Signal) -import CLaSH.Signal.Bundle (unbundle) -import CLaSH.Signal.Explicit (SClock, systemClock, unsafeSynchronizer) -import CLaSH.Signal.Internal (Signal' (..)) -import CLaSH.Sized.Unsigned (Unsigned) -import CLaSH.XException (errorX) - -{-# INLINE asyncRam #-} --- | Create a RAM with space for @n@ elements. --- --- * __NB__: Initial content of the RAM is 'undefined' --- --- Additional helpful information: --- --- * See "CLaSH.Prelude.BlockRam#usingrams" for more information on how to use a --- RAM. -asyncRam :: Enum addr - => SNat n -- ^ Size @n@ of the RAM - -> Signal addr -- ^ Read address @r@ - -> Signal (Maybe (addr, a)) - -- ^ (write address @w@, value to write) - -> Signal a -- ^ Value of the @RAM@ at address @r@ -asyncRam = asyncRam' systemClock systemClock - -{-# INLINE asyncRamPow2 #-} --- | Create a RAM with space for 2^@n@ elements --- --- * __NB__: Initial content of the RAM is 'undefined' --- --- Additional helpful information: --- --- * See "CLaSH.Prelude.BlockRam#usingrams" for more information on how to use a --- RAM. -asyncRamPow2 :: KnownNat n - => Signal (Unsigned n) -- ^ Read address @r@ - -> Signal (Maybe (Unsigned n, a)) - -- ^ (write address @w@, value to write) - -> Signal a -- ^ Value of the @RAM@ at address @r@ -asyncRamPow2 = asyncRamPow2' systemClock systemClock - -{-# INLINE asyncRamPow2' #-} --- | Create a RAM with space for 2^@n@ elements --- --- * __NB__: Initial content of the RAM is 'undefined' --- --- Additional helpful information: --- --- * See "CLaSH.Prelude.BlockRam#usingrams" for more information on how to use a --- RAM. -asyncRamPow2' :: forall wclk rclk n a . - KnownNat n - => SClock wclk -- ^ 'Clock' to which to synchronise - -- the write port of the RAM - -> SClock rclk -- ^ 'Clock' to which the read - -- address signal, @r@, is - -- synchronised - -> Signal' rclk (Unsigned n) -- ^ Read address @r@ - -> Signal' wclk (Maybe (Unsigned n, a)) - -- ^ (write address @w@, value to write) - -> Signal' rclk a - -- ^ Value of the @RAM@ at address @r@ -asyncRamPow2' wclk rclk = asyncRam' wclk rclk (pow2SNat (SNat @ n)) - -{-# INLINE asyncRam' #-} --- | Create a RAM with space for @n@ elements --- --- * __NB__: Initial content of the RAM is 'undefined' --- --- Additional helpful information: --- --- * See "CLaSH.Prelude.BlockRam#usingrams" for more information on how to use a --- RAM. -asyncRam' :: Enum addr - => SClock wclk -- ^ 'Clock' to which to synchronise the write - -- port of the RAM - -> SClock rclk -- ^ 'Clock' to which the read address signal, - -- @r@, is synchronised - -> SNat n -- ^ Size @n@ of the RAM - -> Signal' rclk addr -- ^ Read address @r@ - -> Signal' wclk (Maybe (addr, a)) - -- ^ (write address @w@, value to write) - -> Signal' rclk a -- ^ Value of the @RAM@ at address @r@ -asyncRam' wclk rclk sz rd wrM = - let en = isJust <$> wrM - (wr,din) = unbundle (fromJust <$> wrM) - in asyncRam# wclk rclk sz (fromEnum <$> rd) en (fromEnum <$> wr) din - --- | RAM primitive -asyncRam# :: SClock wclk -- ^ 'Clock' to which to synchronise the write - -- port of the RAM - -> SClock rclk -- ^ 'Clock' to which the read address signal, - -- @r@, is synchronised - -> SNat n -- ^ Size @n@ of the RAM - -> Signal' rclk Int -- ^ Read address @r@ - -> Signal' wclk Bool -- ^ Write enable - -> Signal' wclk Int -- ^ Write address @w@ - -> Signal' wclk a -- ^ Value to write (at address @w@) - -> Signal' rclk a -- ^ Value of the @RAM@ at address @r@ -asyncRam# wclk rclk sz rd en wr din = unsafeSynchronizer wclk rclk dout - where - rd' = unsafeSynchronizer rclk wclk rd - ramI = V.replicate (snatToNum sz) (errorX "asyncRam#: initial value undefined") - dout = go ramI rd' en wr din - - go :: V.Vector a -> Signal' wclk Int -> Signal' wclk Bool - -> Signal' wclk Int -> Signal' wclk a -> Signal' wclk a - go !ram (r :- rs) (e :- es) (w :- ws) (d :- ds) = - let ram' = upd ram e w d - o = ram V.! r - in o :- go ram' rs es ws ds - - upd ram True addr d = ram V.// [(addr,d)] - upd ram False _ _ = ram -{-# NOINLINE asyncRam# #-} diff --git a/src/CLaSH/Prelude/ROM.hs b/src/CLaSH/Prelude/ROM.hs deleted file mode 100644 --- a/src/CLaSH/Prelude/ROM.hs +++ /dev/null @@ -1,176 +0,0 @@ -{-| -Copyright : (C) 2015-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij - -ROMs --} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TypeOperators #-} - -{-# LANGUAGE Safe #-} - -{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Prelude.ROM - ( -- * Asynchronous ROM - asyncRom - , asyncRomPow2 - -- * Synchronous ROM synchronised to the system clock - , rom - , romPow2 - -- * Synchronous ROM synchronised to an arbitrary clock - , rom' - , romPow2' - -- * Internal - , asyncRom# - , rom# - ) -where - -import Data.Array ((!),listArray) -import GHC.TypeLits (KnownNat, type (^)) -import Prelude hiding (length) - -import CLaSH.Signal (Signal) -import CLaSH.Signal.Explicit (Signal', SClock, systemClock) -import CLaSH.Sized.Unsigned (Unsigned) -import CLaSH.Signal.Explicit (register') -import CLaSH.Sized.Vector (Vec, length, toList) -import CLaSH.XException (errorX) - -{-# INLINE asyncRom #-} --- | An asynchronous/combinational ROM with space for @n@ elements --- --- Additional helpful information: --- --- * See "CLaSH.Sized.Fixed#creatingdatafiles" and "CLaSH.Prelude.BlockRam#usingrams" --- for ideas on how to use ROMs and RAMs -asyncRom :: (KnownNat n, Enum addr) - => Vec n a -- ^ ROM content - -- - -- __NB:__ must be a constant - -> addr -- ^ Read address @rd@ - -> a -- ^ The value of the ROM at address @rd@ -asyncRom content rd = asyncRom# content (fromEnum rd) - -{-# INLINE asyncRomPow2 #-} --- | An asynchronous/combinational ROM with space for 2^@n@ elements --- --- Additional helpful information: --- --- * See "CLaSH.Sized.Fixed#creatingdatafiles" and "CLaSH.Prelude.BlockRam#usingrams" --- for ideas on how to use ROMs and RAMs -asyncRomPow2 :: KnownNat n - => Vec (2^n) a -- ^ ROM content - -- - -- __NB:__ must be a constant - -> Unsigned n -- ^ Read address @rd@ - -> a -- ^ The value of the ROM at address @rd@ -asyncRomPow2 = asyncRom - -{-# NOINLINE asyncRom# #-} --- | asyncROM primitive -asyncRom# :: KnownNat n - => Vec n a -- ^ ROM content - -- - -- __NB:__ must be a constant - -> Int -- ^ Read address @rd@ - -> a -- ^ The value of the ROM at address @rd@ -asyncRom# content rd = arr ! rd - where - szI = length content - arr = listArray (0,szI-1) (toList content) - -{-# INLINE rom #-} --- | A ROM with a synchronous read port, with space for @n@ elements --- --- * __NB__: Read value is delayed by 1 cycle --- * __NB__: Initial output value is 'undefined' --- --- Additional helpful information: --- --- * See "CLaSH.Sized.Fixed#creatingdatafiles" and "CLaSH.Prelude.BlockRam#usingrams" --- for ideas on how to use ROMs and RAMs -rom :: (KnownNat n, KnownNat m) - => Vec n a -- ^ ROM content - -- - -- __NB:__ must be a constant - -> Signal (Unsigned m) -- ^ Read address @rd@ - -> Signal a -- ^ The value of the ROM at address @rd@ -rom = rom' systemClock - -{-# INLINE romPow2 #-} --- | A ROM with a synchronous read port, with space for 2^@n@ elements --- --- * __NB__: Read value is delayed by 1 cycle --- * __NB__: Initial output value is 'undefined' --- --- Additional helpful information: --- --- * See "CLaSH.Sized.Fixed#creatingdatafiles" and "CLaSH.Prelude.BlockRam#usingrams" --- for ideas on how to use ROMs and RAMs -romPow2 :: KnownNat n - => Vec (2^n) a -- ^ ROM content - -- - -- __NB:__ must be a constant - -> Signal (Unsigned n) -- ^ Read address @rd@ - -> Signal a -- ^ The value of the ROM at address @rd@ -romPow2 = romPow2' systemClock - -{-# INLINE romPow2' #-} --- | A ROM with a synchronous read port, with space for 2^@n@ elements --- --- * __NB__: Read value is delayed by 1 cycle --- * __NB__: Initial output value is 'undefined' --- --- Additional helpful information: --- --- * See "CLaSH.Sized.Fixed#creatingdatafiles" and "CLaSH.Prelude.BlockRam#usingrams" --- for ideas on how to use ROMs and RAMs -romPow2' :: KnownNat n - => SClock clk -- ^ 'Clock' to synchronize to - -> Vec (2^n) a -- ^ ROM content - -- - -- __NB:__ must be a constant - -> Signal' clk (Unsigned n) -- ^ Read address @rd@ - -> Signal' clk a -- ^ The value of the ROM at address @rd@ -romPow2' = rom' - -{-# INLINE rom' #-} --- | A ROM with a synchronous read port, with space for @n@ elements --- --- * __NB__: Read value is delayed by 1 cycle --- * __NB__: Initial output value is 'undefined' --- --- Additional helpful information: --- --- * See "CLaSH.Sized.Fixed#creatingdatafiles" and "CLaSH.Prelude.BlockRam#usingrams" --- for ideas on how to use ROMs and RAMs -rom' :: (KnownNat n, Enum addr) - => SClock clk -- ^ 'Clock' to synchronize to - -> Vec n a -- ^ ROM content - -- - -- __NB:__ must be a constant - -> Signal' clk addr -- ^ Read address @rd@ - -> Signal' clk a - -- ^ The value of the ROM at address @rd@ from the previous clock cycle -rom' clk content rd = rom# clk content (fromEnum <$> rd) - -{-# NOINLINE rom# #-} --- | ROM primitive -rom# :: KnownNat n - => SClock clk -- ^ 'Clock' to synchronize to - -> Vec n a -- ^ ROM content - -- - -- __NB:__ must be a constant - -> Signal' clk Int -- ^ Read address @rd@ - -> Signal' clk a - -- ^ The value of the ROM at address @rd@ from the previous clock cycle -rom# clk content rd = register' clk (errorX "rom#: initial value undefined") ((arr !) <$> rd) - where - szI = length content - arr = listArray (0,szI-1) (toList content) diff --git a/src/CLaSH/Prelude/ROM/File.hs b/src/CLaSH/Prelude/ROM/File.hs deleted file mode 100644 --- a/src/CLaSH/Prelude/ROM/File.hs +++ /dev/null @@ -1,382 +0,0 @@ -{-| -Copyright : (C) 2015-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij - -= Initialising a ROM with a data file #usingromfiles# - -ROMs initialised with a data file. The BNF grammar for this data file is simple: - -@ -FILE = LINE+ -LINE = BIT+ -BIT = '0' - | '1' -@ - -Consecutive @LINE@s correspond to consecutive memory addresses starting at @0@. -For example, a data file @memory.bin@ containing the 9-bit unsigned number -@7@ to @13@ looks like: - -@ -000000111 -000001000 -000001001 -000001010 -000001011 -000001100 -000001101 -@ - -We can instantiate a synchronous ROM using the content of the above file like -so: - -@ -topEntity :: Signal (Unsigned 3) -> Signal (Unsigned 9) -topEntity rd = 'CLaSH.Class.BitPack.unpack' '<$>' 'romFile' d7 \"memory.bin\" rd -@ - -And see that it works as expected: - -@ -__>>> import qualified Data.List as L__ -__>>> L.tail $ sampleN 4 $ topEntity (fromList [3..5])__ -[10,11,12] -@ - -However, we can also interpret the same data as a tuple of a 6-bit unsigned -number, and a 3-bit signed number: - -@ -topEntity2 :: Signal (Unsigned 3) -> Signal (Unsigned 6,Signed 3) -topEntity2 rd = 'CLaSH.Class.BitPack.unpack' '<$>' 'romFile' d7 \"memory.bin\" rd -@ - -And then we would see: - -@ -__>>> import qualified Data.List as L__ -__>>> L.tail $ sampleN 4 $ topEntity2 (fromList [3..5])__ -[(1,2),(1,3)(1,-4)] -@ --} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - -{-# LANGUAGE Unsafe #-} - -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Prelude.ROM.File - ( -- * Asynchronous ROM - asyncRomFile - , asyncRomFilePow2 - -- * Synchronous ROM synchronised to the system clock - , romFile - , romFilePow2 - -- * Synchronous ROM synchronised to an arbitrary clock - , romFile' - , romFilePow2' - -- * Internal - , asyncRomFile# - , romFile# - ) -where - -import Data.Array (listArray,(!)) -import GHC.TypeLits (KnownNat) -import System.IO.Unsafe (unsafePerformIO) - -import CLaSH.Prelude.BlockRam.File (initMem) -import CLaSH.Promoted.Nat (SNat (..), pow2SNat, snatToNum) -import CLaSH.Sized.BitVector (BitVector) -import CLaSH.Signal (Signal) -import CLaSH.Signal.Explicit (Signal', SClock, register', systemClock) -import CLaSH.Sized.Unsigned (Unsigned) -import CLaSH.XException (errorX) - -{-# INLINE asyncRomFile #-} --- | An asynchronous/combinational ROM with space for @n@ elements --- --- * __NB__: This function might not work for specific combinations of --- code-generation backends and hardware targets. Please check the support table --- below: --- --- @ --- | VHDL | Verilog | SystemVerilog | --- ===============+==========+==========+===============+ --- Altera/Quartus | Broken | Works | Works | --- Xilinx/ISE | Works | Works | Works | --- ASIC | Untested | Untested | Untested | --- ===============+==========+==========+===============+ --- @ --- --- Additional helpful information: --- --- * See "CLaSH.Prelude.ROM.File#usingromfiles" for more information on how --- to instantiate a ROM with the contents of a data file. --- * See "CLaSH.Sized.Fixed#creatingdatafiles" for ideas on how to create your --- own data files. --- * When you notice that 'asyncRomFile' is significantly slowing down your --- simulation, give it a /monomorphic/ type signature. So instead of leaving --- the type to be inferred: --- --- @ --- myRomData = asyncRomFile d512 "memory.bin" --- @ --- --- or giving it a /polymorphic/ type signature: --- --- @ --- myRomData :: Enum addr => addr -> BitVector 16 --- myRomData = asyncRomFile d512 "memory.bin" --- @ --- --- you __should__ give it a /monomorphic/ type signature: --- --- @ --- myRomData :: Unsigned 9 -> BitVector 16 --- myRomData = asyncRomFile d512 "memory.bin" --- @ -asyncRomFile :: (KnownNat m, Enum addr) - => SNat n -- ^ Size of the ROM - -> FilePath -- ^ File describing the content of the ROM - -> addr -- ^ Read address @rd@ - -> BitVector m -- ^ The value of the ROM at address @rd@ -asyncRomFile sz file = asyncRomFile# sz file . fromEnum --- Leave 'asyncRom' eta-reduced, see Note [Eta-reduction and unsafePerformIO initMem] - --- Note [Eta-reduction and unsafePerformIO initMem] --- --- The 'initMem' function initializes a @[BitVector n]@ from file. Ideally, --- we want this IO action to happen only once. When we call 'unsafePerformIO' --- on @initMem file@, it becomes a thunk in that function, so is hence evaluated --- only once. However, me must ensure that any code calling using of the --- @unsafePerformIO (initMem file)@ thunk also becomes a thunk. We do this by --- eta-reducing function where needed so that a thunk is returned. --- --- For example, instead of writing: --- --- > asyncRomFile# sz file rd = (content ! rd) --- > where --- > mem = unsafePerformIO (initMem file) --- > content = listArray (0,szI-1) mem --- > szI = snatToNum sz --- --- We write: --- --- > asyncRomFile# sz file = (content !) --- > where --- > mem = unsafePerformIO (initMem file) --- > content = listArray (0,szI-1) mem --- > szI = snatToNum sz --- --- Where instead of returning the BitVector defined by @(content ! rd)@, we --- return the function (thunk) @(content !)@. - -{-# INLINE asyncRomFilePow2 #-} --- | An asynchronous/combinational ROM with space for 2^@n@ elements --- --- * __NB__: This function might not work for specific combinations of --- code-generation backends and hardware targets. Please check the support table --- below: --- --- @ --- | VHDL | Verilog | SystemVerilog | --- ===============+==========+==========+===============+ --- Altera/Quartus | Broken | Works | Works | --- Xilinx/ISE | Works | Works | Works | --- ASIC | Untested | Untested | Untested | --- ===============+==========+==========+===============+ --- @ --- --- Additional helpful information: --- --- * See "CLaSH.Prelude.ROM.File#usingromfiles" for more information on how --- to instantiate a ROM with the contents of a data file. --- * See "CLaSH.Sized.Fixed#creatingdatafiles" for ideas on how to create your --- own data files. --- * When you notice that 'asyncRomFilePow2' is significantly slowing down your --- simulation, give it a /monomorphic/ type signature. So instead of leaving the --- type to be inferred: --- --- @ --- myRomData = asyncRomFilePow2 "memory.bin" --- @ --- --- you __should__ give it a /monomorphic/ type signature: --- --- @ --- myRomData :: Unsigned 9 -> BitVector 16 --- myRomData = asyncRomFilePow2 "memory.bin" --- @ -asyncRomFilePow2 :: forall n m . (KnownNat m, KnownNat n) - => FilePath -- ^ File describing the content of the ROM - -> Unsigned n -- ^ Read address @rd@ - -> BitVector m -- ^ The value of the ROM at address @rd@ -asyncRomFilePow2 = asyncRomFile (pow2SNat (SNat @ n)) - -{-# NOINLINE asyncRomFile# #-} --- | asyncROMFile primitive -asyncRomFile# :: KnownNat m - => SNat n -- ^ Size of the ROM - -> FilePath -- ^ File describing the content of the ROM - -> Int -- ^ Read address @rd@ - -> BitVector m -- ^ The value of the ROM at address @rd@ -asyncRomFile# sz file = (content !) -- Leave "(content !)" eta-reduced, see - where -- Note [Eta-reduction and unsafePerformIO initMem] - mem = unsafePerformIO (initMem file) - content = listArray (0,szI-1) mem - szI = snatToNum sz - -{-# INLINE romFile #-} --- | A ROM with a synchronous read port, with space for @n@ elements --- --- * __NB__: Read value is delayed by 1 cycle --- * __NB__: Initial output value is 'undefined' --- * __NB__: This function might not work for specific combinations of --- code-generation backends and hardware targets. Please check the support table --- below: --- --- @ --- | VHDL | Verilog | SystemVerilog | --- ===============+==========+==========+===============+ --- Altera/Quartus | Broken | Works | Works | --- Xilinx/ISE | Works | Works | Works | --- ASIC | Untested | Untested | Untested | --- ===============+==========+==========+===============+ --- @ --- --- Additional helpful information: --- --- * See "CLaSH.Prelude.ROM.File#usingromfiles" for more information on how --- to instantiate a ROM with the contents of a data file. --- * See "CLaSH.Sized.Fixed#creatingdatafiles" for ideas on how to create your --- own data files. -romFile :: (KnownNat m, KnownNat n) - => SNat n -- ^ Size of the ROM - -> FilePath -- ^ File describing the content of the ROM - -> Signal (Unsigned n) -- ^ Read address @rd@ - -> Signal (BitVector m) - -- ^ The value of the ROM at address @rd@ from the previous clock cycle -romFile = romFile' systemClock - -{-# INLINE romFilePow2 #-} --- | A ROM with a synchronous read port, with space for 2^@n@ elements --- --- * __NB__: Read value is delayed by 1 cycle --- * __NB__: Initial output value is 'undefined' --- * __NB__: This function might not work for specific combinations of --- code-generation backends and hardware targets. Please check the support table --- below: --- --- @ --- | VHDL | Verilog | SystemVerilog | --- ===============+==========+==========+===============+ --- Altera/Quartus | Broken | Works | Works | --- Xilinx/ISE | Works | Works | Works | --- ASIC | Untested | Untested | Untested | --- ===============+==========+==========+===============+ --- @ --- --- Additional helpful information: --- --- * See "CLaSH.Prelude.ROM.File#usingromfiles" for more information on how --- to instantiate a ROM with the contents of a data file. --- * See "CLaSH.Sized.Fixed#creatingdatafiles" for ideas on how to create your --- own data files. -romFilePow2 :: forall n m . (KnownNat m, KnownNat n) - => FilePath -- ^ File describing the content of the ROM - -> Signal (Unsigned n) -- ^ Read address @rd@ - -> Signal (BitVector m) - -- ^ The value of the ROM at address @rd@ from the previous clock cycle -romFilePow2 = romFilePow2' systemClock - -{-# INLINE romFilePow2' #-} --- | A ROM with a synchronous read port, with space for 2^@n@ elements --- --- * __NB__: Read value is delayed by 1 cycle --- * __NB__: Initial output value is 'undefined' --- * __NB__: This function might not work for specific combinations of --- code-generation backends and hardware targets. Please check the support table --- below: --- --- @ --- | VHDL | Verilog | SystemVerilog | --- ===============+==========+==========+===============+ --- Altera/Quartus | Broken | Works | Works | --- Xilinx/ISE | Works | Works | Works | --- ASIC | Untested | Untested | Untested | --- ===============+==========+==========+===============+ --- @ --- --- Additional helpful information: --- --- * See "CLaSH.Prelude.ROM.File#usingromfiles" for more information on how --- to instantiate a ROM with the contents of a data file. --- * See "CLaSH.Sized.Fixed#creatingdatafiles" for ideas on how to create your --- own data files. -romFilePow2' :: forall clk n m . (KnownNat m, KnownNat n) - => SClock clk -- ^ 'Clock' to synchronize to - -> FilePath -- ^ File describing the content of - -- the ROM - -> Signal' clk (Unsigned n) -- ^ Read address @rd@ - -> Signal' clk (BitVector m) - -- ^ The value of the ROM at address @rd@ from the previous clock - -- cycle -romFilePow2' clk = romFile' clk (pow2SNat (SNat @ n)) - -{-# INLINE romFile' #-} --- | A ROM with a synchronous read port, with space for @n@ elements --- --- * __NB__: Read value is delayed by 1 cycle --- * __NB__: Initial output value is 'undefined' --- * __NB__: This function might not work for specific combinations of --- code-generation backends and hardware targets. Please check the support table --- below: --- --- @ --- | VHDL | Verilog | SystemVerilog | --- ===============+==========+==========+===============+ --- Altera/Quartus | Broken | Works | Works | --- Xilinx/ISE | Works | Works | Works | --- ASIC | Untested | Untested | Untested | --- ===============+==========+==========+===============+ --- @ --- --- Additional helpful information: --- --- * See "CLaSH.Prelude.ROM.File#usingromfiles" for more information on how --- to instantiate a ROM with the contents of a data file. --- * See "CLaSH.Sized.Fixed#creatingdatafiles" for ideas on how to create your --- own data files. -romFile' :: (KnownNat m, Enum addr) - => SClock clk -- ^ 'Clock' to synchronize to - -> SNat n -- ^ Size of the ROM - -> FilePath -- ^ File describing the content of the - -- ROM - -> Signal' clk addr -- ^ Read address @rd@ - -> Signal' clk (BitVector m) - -- ^ The value of the ROM at address @rd@ from the previous clock cycle -romFile' clk sz file rd = romFile# clk sz file (fromEnum <$> rd) - -{-# NOINLINE romFile# #-} --- | romFile primitive -romFile# :: KnownNat m - => SClock clk -- ^ 'Clock' to synchronize to - -> SNat n -- ^ Size of the ROM - -> FilePath -- ^ File describing the content of the - -- ROM - -> Signal' clk Int -- ^ Read address @rd@ - -> Signal' clk (BitVector m) - -- ^ The value of the ROM at address @rd@ from the previous clock cycle -romFile# clk sz file rd = register' clk (errorX "romFile#: initial value undefined") ((content !) <$> rd) - where - mem = unsafePerformIO (initMem file) - content = listArray (0,szI-1) mem - szI = snatToNum sz diff --git a/src/CLaSH/Prelude/Safe.hs b/src/CLaSH/Prelude/Safe.hs deleted file mode 100644 --- a/src/CLaSH/Prelude/Safe.hs +++ /dev/null @@ -1,246 +0,0 @@ -{-| - Copyright : (C) 2013-2016, University of Twente - License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij - - __This is the API only of "CLaSH.Prelude"__ - - CλaSH (pronounced ‘clash’) is a functional hardware description language that - borrows both its syntax and semantics from the functional programming language - Haskell. The merits of using a functional language to describe hardware comes - from the fact that combinational circuits can be directly modeled as - mathematical functions and that functional languages lend themselves very well - at describing and (de-)composing mathematical functions. - - This package provides: - - * Prelude library containing datatypes and functions for circuit design - - To use the library: - - * Import "CLaSH.Prelude" - * Additionally import "CLaSH.Prelude.Explicit" if you want to design - explicitly clocked circuits in a multi-clock setting - - For now, "CLaSH.Prelude" is also the best starting point for exploring the - library. A preliminary version of a tutorial can be found in "CLaSH.Tutorial". - Some circuit examples can be found in "CLaSH.Examples". --} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeOperators #-} - -{-# LANGUAGE Safe #-} - -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Prelude.Safe - ( -- * Creating synchronous sequential circuits - mealy - , mealyB - , (<^>) - , moore - , mooreB - , registerB - -- * ROMs - , asyncRom - , asyncRomPow2 - , rom - , romPow2 - -- * RAM primitives with a combinational read port - , asyncRam - , asyncRamPow2 - -- * BlockRAM primitives - , blockRam - , blockRamPow2 - -- * BlockRAM read/write conflict resolution - , readNew - , readNew' - -- * Utility functions - , isRising - , isFalling - , riseEvery - , oscillate - -- * Exported modules - -- ** Synchronous signals - , module CLaSH.Signal - , module CLaSH.Signal.Delayed - -- ** DataFlow interface - , module CLaSH.Prelude.DataFlow - -- ** Datatypes - -- *** Bit vectors - , module CLaSH.Sized.BitVector - , module CLaSH.Prelude.BitIndex - , module CLaSH.Prelude.BitReduction - -- *** Arbitrary-width numbers - , module CLaSH.Sized.Signed - , module CLaSH.Sized.Unsigned - , module CLaSH.Sized.Index - -- *** Fixed point numbers - , module CLaSH.Sized.Fixed - -- *** Fixed size vectors - , module CLaSH.Sized.Vector - -- *** Perfect depth trees - , module CLaSH.Sized.RTree - -- ** Annotations - , module CLaSH.Annotations.TopEntity - -- ** Type-level natural numbers - , module GHC.TypeLits - , module GHC.TypeLits.Extra - , module CLaSH.Promoted.Nat - , module CLaSH.Promoted.Nat.Literals - , module CLaSH.Promoted.Nat.TH - -- ** Type classes - -- *** CLaSH - , module CLaSH.Class.BitPack - , module CLaSH.Class.Num - , module CLaSH.Class.Resize - -- *** Other - , module Control.Applicative - , module Data.Bits - -- ** Exceptions - , module CLaSH.XException - , undefined - -- ** Named types - , module CLaSH.NamedTypes - -- ** Haskell Prelude - -- $hiding - , module Prelude - ) -where - -import Control.Applicative -import Data.Bits -import GHC.Stack -import GHC.TypeLits -import GHC.TypeLits.Extra -import Prelude hiding ((++), (!!), concat, drop, foldl, - foldl1, foldr, foldr1, head, init, - iterate, last, length, map, repeat, - replicate, reverse, scanl, scanr, - splitAt, tail, take, unzip, unzip3, - zip, zip3, zipWith, zipWith3, - undefined) - -import CLaSH.Annotations.TopEntity -import CLaSH.Class.BitPack -import CLaSH.Class.Num -import CLaSH.Class.Resize -import CLaSH.NamedTypes -import CLaSH.Prelude.BitIndex -import CLaSH.Prelude.BitReduction -import CLaSH.Prelude.BlockRam (blockRam, blockRamPow2, readNew, readNew') -import CLaSH.Prelude.Explicit.Safe (registerB', isRising', isFalling', - oscillate', riseEvery') -import CLaSH.Prelude.Mealy (mealy, mealyB, (<^>)) -import CLaSH.Prelude.Moore (moore, mooreB) -import CLaSH.Prelude.RAM (asyncRam,asyncRamPow2) -import CLaSH.Prelude.ROM (asyncRom,asyncRomPow2,rom,romPow2) -import CLaSH.Prelude.DataFlow -import CLaSH.Promoted.Nat -import CLaSH.Promoted.Nat.TH -import CLaSH.Promoted.Nat.Literals -import CLaSH.Sized.BitVector -import CLaSH.Sized.Fixed -import CLaSH.Sized.Index -import CLaSH.Sized.RTree -import CLaSH.Sized.Signed -import CLaSH.Sized.Unsigned -import CLaSH.Sized.Vector -import CLaSH.Signal -import CLaSH.Signal.Delayed -import CLaSH.Signal.Explicit (systemClock) -import CLaSH.XException - -{- $setup ->>> let rP = registerB (8,8) --} - -{- $hiding -"CLaSH.Prelude" re-exports most of the Haskell "Prelude" with the exception of -the following: (++), (!!), concat, drop, foldl, foldl1, foldr, foldr1, head, -init, iterate, last, length, map, repeat, replicate, reverse, scanl, scanr, -splitAt, tail, take, unzip, unzip3, zip, zip3, zipWith, zipWith3. - -It instead exports the identically named functions defined in terms of -'CLaSH.Sized.Vector.Vec' at "CLaSH.Sized.Vector". --} - -{-# INLINE registerB #-} --- | Create a 'register' function for product-type like signals (e.g. '(Signal a, Signal b)') --- --- > rP :: (Signal Int,Signal Int) -> (Signal Int, Signal Int) --- > rP = registerB (8,8) --- --- >>> simulateB rP [(1,1),(2,2),(3,3)] :: [(Int,Int)] --- [(8,8),(1,1),(2,2),(3,3)... --- ... -registerB :: Bundle a => a -> Unbundled a -> Unbundled a -registerB = registerB' systemClock -infixr 3 `registerB` - -{-# INLINE isRising #-} --- | Give a pulse when the 'Signal' goes from 'minBound' to 'maxBound' -isRising :: (Bounded a, Eq a) - => a -- ^ Starting value - -> Signal a - -> Signal Bool -isRising = isRising' systemClock - -{-# INLINE isFalling #-} --- | Give a pulse when the 'Signal' goes from 'maxBound' to 'minBound' -isFalling :: (Bounded a, Eq a) - => a -- ^ Starting value - -> Signal a - -> Signal Bool -isFalling = isFalling' systemClock - -{-# INLINE riseEvery #-} --- | Give a pulse every @n@ clock cycles. This is a useful helper function when --- combined with functions like @'CLaSH.Signal.regEn'@ or @'CLaSH.Signal.mux'@, --- in order to delay a register by a known amount. --- --- To be precise: the given signal will be @'False'@ for the next @n-1@ cycles, --- followed by a single @'True'@ value: --- --- >>> Prelude.last (sampleN 1024 (riseEvery d1024)) == True --- True --- >>> Prelude.or (sampleN 1023 (riseEvery d1024)) == False --- True --- --- For example, to update a counter once every 10 million cycles: --- --- @ --- counter = 'CLaSH.Signal.regEn' 0 ('riseEvery' ('SNat' :: 'SNat' 10000000)) (counter + 1) --- @ -riseEvery :: KnownNat n => SNat n -> Signal Bool -riseEvery = riseEvery' systemClock - -{-# INLINE oscillate #-} --- | Oscillate a @'Bool'@ for a given number of cycles. This is a convenient --- function when combined with something like @'regEn'@, as it allows you to --- easily hold a register value for a given number of cycles. The input @'Bool'@ --- determines what the initial value is. --- --- To oscillate on an interval of 5 cycles: --- --- >>> sampleN 10 (oscillate False d5) --- [False,False,False,False,False,True,True,True,True,True] --- --- To oscillate between @'True'@ and @'False'@: --- --- >>> sampleN 10 (oscillate False d1) --- [False,True,False,True,False,True,False,True,False,True] --- --- An alternative definition for the above could be: --- --- >>> let osc' = register False (not <$> osc') --- >>> let sample' = sampleN 200 --- >>> sample' (oscillate False d1) == sample' osc' --- True -oscillate :: KnownNat n => Bool -> SNat n -> Signal Bool -oscillate = oscillate' systemClock - -undefined :: HasCallStack => a -undefined = errorX "undefined" diff --git a/src/CLaSH/Prelude/Synchronizer.hs b/src/CLaSH/Prelude/Synchronizer.hs deleted file mode 100644 --- a/src/CLaSH/Prelude/Synchronizer.hs +++ /dev/null @@ -1,176 +0,0 @@ -{-| -Copyright : (C) 2015-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij - -Synchronizer circuits for safe clock domain crossings --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE AllowAmbiguousTypes #-} - -{-# LANGUAGE Trustworthy #-} - -{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} -{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} - -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Prelude.Synchronizer - ( -- * Bit-synchronizers - dualFlipFlopSynchronizer - -- * Word-synchronizers - , asyncFIFOSynchronizer - ) -where - -import Control.Applicative (liftA2) -import Data.Bits (complement, shiftR, xor) -import Data.Constraint ((:-)(..), Dict (..)) -#if MIN_VERSION_constraints(0,9,0) -import Data.Constraint.Nat (leTrans) -#else -import Unsafe.Coerce -#endif -import Data.Maybe (isJust) -import GHC.TypeLits (type (+), type (-), type (<=)) - -import CLaSH.Class.BitPack (boolToBV) -import CLaSH.Class.Resize (truncateB) -import CLaSH.Prelude.BitIndex (slice) -import CLaSH.Prelude.Mealy (mealyB') -import CLaSH.Prelude.RAM (asyncRam') -import CLaSH.Promoted.Nat (SNat (..), pow2SNat) -import CLaSH.Promoted.Nat.Literals (d0) -import CLaSH.Signal (mux) -import CLaSH.Signal.Explicit (Signal', SClock, register', - unsafeSynchronizer) -import CLaSH.Sized.BitVector (BitVector, (++#)) - --- * Dual flip-flop synchronizer - --- | Synchroniser based on two sequentially connected flip-flops. --- --- * __NB__: This synchroniser can be used for __bit__-synchronization. --- --- * __NB__: Although this synchroniser does reduce metastability, it does --- not guarantee the proper synchronisation of a whole __word__. For --- example, given that the output is sampled twice as fast as the input is --- running, and we have two samples in the input stream that look like: --- --- @[0111,1000]@ --- --- But the circuit driving the input stream has a longer propagation delay --- on __msb__ compared to the __lsb__s. What can happen is an output stream --- that looks like this: --- --- @[0111,0111,0000,1000]@ --- --- Where the level-change of the __msb__ was not captured, but the level --- change of the __lsb__s were. --- --- If you want to have /safe/ __word__-synchronisation use --- 'asyncFIFOSynchronizer'. -dualFlipFlopSynchronizer :: SClock clk1 -- ^ 'Clock' to which the incoming - -- data is synchronised - -> SClock clk2 -- ^ 'Clock' to which the outgoing - -- data is synchronised - -> a -- ^ Initial value of the two - -- synchronisation registers - -> Signal' clk1 a -- ^ Incoming data - -> Signal' clk2 a -- ^ Outgoing, synchronised, data -dualFlipFlopSynchronizer clk1 clk2 i = register' clk2 i - . register' clk2 i - . unsafeSynchronizer clk1 clk2 - --- * Asynchronous FIFO synchronizer - -fifoMem :: - SClock wclk - -> SClock rclk - -> SNat addrSize - -> Signal' wclk Bool - -> Signal' rclk (BitVector addrSize) - -> Signal' wclk (Maybe (BitVector addrSize, a)) - -> Signal' rclk a -fifoMem wclk rclk addrSize@SNat full raddr writeM = - asyncRam' wclk rclk - (pow2SNat addrSize) - raddr - (mux full (pure Nothing) writeM) - -ptrCompareT :: SNat addrSize - -> (BitVector (addrSize + 1) -> BitVector (addrSize + 1) -> Bool) - -> (BitVector (addrSize + 1), BitVector (addrSize + 1), Bool) - -> (BitVector (addrSize + 1), Bool) - -> ((BitVector (addrSize + 1), BitVector (addrSize + 1), Bool) - ,(Bool, BitVector addrSize, BitVector (addrSize + 1))) -ptrCompareT SNat flagGen (bin,ptr,flag) (s_ptr,inc) = ((bin',ptr',flag') - ,(flag,addr,ptr)) - where - -- GRAYSTYLE2 pointer - bin' = bin + boolToBV (inc && not flag) - ptr' = (bin' `shiftR` 1) `xor` bin' - addr = truncateB bin - - flag' = flagGen ptr' s_ptr - --- FIFO full: when next pntr == synchonized {~wptr[addrSize:addrSize-1],wptr[addrSize-1:0]} -isFull :: forall addrSize . - (2 <= addrSize) - => SNat addrSize - -> BitVector (addrSize + 1) - -> BitVector (addrSize + 1) - -> Bool -isFull addrSize@SNat ptr s_ptr = case leTrans @1 @2 @addrSize of - Sub Dict -> - let a1 = SNat @(addrSize - 1) - a2 = SNat @(addrSize - 2) - in ptr == (complement (slice addrSize a1 s_ptr) ++# slice a2 d0 s_ptr) - --- | Synchroniser implemented as a FIFO around an asynchronous RAM. Based on the --- design described in "CLaSH.Tutorial#multiclock", which is itself based on the --- design described in . --- --- __NB__: This synchroniser can be used for __word__-synchronization. -asyncFIFOSynchronizer - :: (2 <= addrSize) - => SNat addrSize -- ^ Size of the internally used addresses, the - -- FIFO contains @2^addrSize@ elements. - -> SClock wclk -- ^ 'Clock' to which the write port is synchronised - -> SClock rclk -- ^ 'Clock' to which the read port is synchronised - -> Signal' rclk Bool -- ^ Read request - -> Signal' wclk (Maybe a) -- ^ Element to insert - -> (Signal' rclk a, Signal' rclk Bool, Signal' wclk Bool) - -- ^ (Oldest element in the FIFO, @empty@ flag, @full@ flag) -asyncFIFOSynchronizer addrSize@SNat wclk rclk rinc wdataM = (rdata,rempty,wfull) - where - s_rptr = dualFlipFlopSynchronizer rclk wclk 0 rptr - s_wptr = dualFlipFlopSynchronizer wclk rclk 0 wptr - - rdata = fifoMem wclk rclk addrSize wfull raddr - (liftA2 (,) <$> (pure <$> waddr) <*> wdataM) - - (rempty,raddr,rptr) = mealyB' rclk (ptrCompareT addrSize (==)) (0,0,True) - (s_wptr,rinc) - - (wfull,waddr,wptr) = mealyB' wclk (ptrCompareT addrSize (isFull addrSize)) - (0,0,False) (s_rptr,isJust <$> wdataM) - -#if !MIN_VERSION_constraints(0,9,0) -axiom :: forall a b . Dict (a ~ b) -axiom = unsafeCoerce (Dict :: Dict (a ~ a)) - -axiomLe :: forall a b. Dict (a <= b) -axiomLe = axiom - -leTrans :: forall a b c. (b <= c, a <= b) :- (a <= c) -leTrans = Sub (axiomLe @a @c) -#endif diff --git a/src/CLaSH/Prelude/Testbench.hs b/src/CLaSH/Prelude/Testbench.hs deleted file mode 100644 --- a/src/CLaSH/Prelude/Testbench.hs +++ /dev/null @@ -1,246 +0,0 @@ -{-| -Copyright : (C) 2013-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij --} - -{-# LANGUAGE ScopedTypeVariables #-} - -{-# LANGUAGE Unsafe #-} - -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Prelude.Testbench - ( -- * Testbench functions for circuits synchronised to the system slock - assert - , stimuliGenerator - , outputVerifier - -- * Testbench functions for circuits synchronised to arbitrary clocks - , assert' - , stimuliGenerator' - , outputVerifier' - ) -where - -import Debug.Trace (trace) -import GHC.TypeLits (KnownNat) -import Prelude hiding ((!!), length) - -import CLaSH.Signal (Signal, fromList) -import CLaSH.Signal.Explicit (Signal', SClock, register', systemClock) -import CLaSH.Signal.Bundle (unbundle) -import CLaSH.Sized.Index (Index) -import CLaSH.Sized.Vector (Vec, (!!), length) - -{- $setup ->>> :set -XTemplateHaskell ->>> :set -XDataKinds ->>> import CLaSH.Prelude ->>> let testInput = stimuliGenerator $(listToVecTH [(1::Int),3..21]) ->>> let expectedOutput = outputVerifier $(listToVecTH ([70,99,2,3,4,5,7,8,9,10]::[Int])) ->>> import CLaSH.Prelude.Explicit ->>> type ClkA = Clk "A" 100 ->>> let clkA = sclock :: SClock ClkA ->>> let testInput' = stimuliGenerator' clkA $(listToVecTH [(1::Int),3..21]) ->>> let expectedOutput' = outputVerifier' clkA $(listToVecTH ([70,99,2,3,4,5,7,8,9,10]::[Int])) --} - -{-# INLINE assert #-} --- | Compares the first two 'Signal's for equality and logs a warning when they --- are not equal. The second 'Signal' is considered the expected value. This --- function simply returns the third 'Signal' unaltered as its result. This --- function is used by 'outputVerifier'. --- --- --- __NB__: This function /can/ be used in synthesizable designs. -assert :: (Eq a,Show a) - => String -- ^ Additional message - -> Signal a -- ^ Checked value - -> Signal a -- ^ Expected value - -> Signal b -- ^ Return value - -> Signal b -assert = assert' systemClock - -{-# INLINE stimuliGenerator #-} --- | To be used as one of the functions to create the \"magical\" 'testInput' --- value, which the CλaSH compiler looks for to create the stimulus generator --- for the generated VHDL testbench. --- --- Example: --- --- @ --- testInput :: 'Signal' Int --- testInput = 'stimuliGenerator' $('CLaSH.Sized.Vector.listToVecTH' [(1::Int),3..21]) --- @ --- --- >>> sampleN 13 testInput --- [1,3,5,7,9,11,13,15,17,19,21,21,21] -stimuliGenerator :: forall l a . KnownNat l - => Vec l a -- ^ Samples to generate - -> Signal a -- ^ Signal of given samples -stimuliGenerator = stimuliGenerator' systemClock - -{-# INLINE outputVerifier #-} --- | To be used as one of the functions to generate the \"magical\" 'expectedOutput' --- function, which the CλaSH compiler looks for to create the signal verifier --- for the generated VHDL testbench. --- --- Example: --- --- @ --- expectedOutput :: 'Signal' Int -> 'Signal' Bool --- expectedOutput = 'outputVerifier' $('CLaSH.Sized.Vector.listToVecTH' ([70,99,2,3,4,5,7,8,9,10]::[Int])) --- @ --- --- >>> import qualified Data.List as List --- >>> sampleN 12 (expectedOutput (fromList ([0..10] List.++ [10,10,10]))) --- --- cycle(system1000): 0, outputVerifier --- expected value: 70, not equal to actual value: 0 --- [False --- cycle(system1000): 1, outputVerifier --- expected value: 99, not equal to actual value: 1 --- ,False,False,False,False,False --- cycle(system1000): 6, outputVerifier --- expected value: 7, not equal to actual value: 6 --- ,False --- cycle(system1000): 7, outputVerifier --- expected value: 8, not equal to actual value: 7 --- ,False --- cycle(system1000): 8, outputVerifier --- expected value: 9, not equal to actual value: 8 --- ,False --- cycle(system1000): 9, outputVerifier --- expected value: 10, not equal to actual value: 9 --- ,False,True,True] -outputVerifier :: forall l a . (KnownNat l, Eq a, Show a) - => Vec l a -- ^ Samples to compare with - -> Signal a -- ^ Signal to verify - -> Signal Bool -- ^ Indicator that all samples are verified -outputVerifier = outputVerifier' systemClock - -{-# NOINLINE assert' #-} --- | Compares the first two 'Signal''s for equality and logs a warning when they --- are not equal. The second 'Signal'' is considered the expected value. This --- function simply returns the third 'Signal'' unaltered as its result. This --- function is used by 'outputVerifier''. --- --- --- __NB__: This function /can/ be used in synthesizable designs. -assert' :: (Eq a,Show a) - => SClock t - -> String -- ^ Additional message - -> Signal' t a -- ^ Checked value - -> Signal' t a -- ^ Expected value - -> Signal' t b -- ^ Return value - -> Signal' t b -assert' clk msg checked expected returned = - (\c e cnt r -> - if c == e then r - else trace (concat [ "\ncycle(" ++ show clk ++ "): " - , show cnt - , ", " - , msg - , "\nexpected value: " - , show e - , ", not equal to actual value: " - , show c - ]) r) - <$> checked <*> expected <*> fromList [(0::Integer)..] <*> returned - -{-# INLINABLE stimuliGenerator' #-} --- | To be used as one of the functions to create the \"magical\" 'testInput' --- value, which the CλaSH compiler looks for to create the stimulus generator --- for the generated VHDL testbench. --- --- Example: --- --- @ --- type ClkA = 'CLaSH.Signal.Explicit.Clk' \"A\" 100 --- --- clkA :: 'SClock' ClkA --- clkA = 'CLaSH.Signal.Explicit.sclock' --- --- testInput' :: 'Signal'' clkA Int --- testInput' = 'stimuliGenerator'' clkA $('CLaSH.Sized.Vector.listToVecTH' [(1::Int),3..21]) --- @ --- --- >>> sampleN 13 testInput' --- [1,3,5,7,9,11,13,15,17,19,21,21,21] -stimuliGenerator' :: forall l clk a . KnownNat l - => SClock clk -- ^ Clock to which to synchronize the - -- output signal - -> Vec l a -- ^ Samples to generate - -> Signal' clk a -- ^ Signal of given samples -stimuliGenerator' clk samples = - let (r,o) = unbundle (genT <$> register' clk 0 r) - in o - where - genT :: Index l -> (Index l,a) - genT s = (s',samples !! s) - where - maxI = toEnum (length samples - 1) - - s' = if s < maxI - then s + 1 - else s - -{-# INLINABLE outputVerifier' #-} --- | To be used as one of the functions to generate the \"magical\" 'expectedOutput' --- function, which the CλaSH compiler looks for to create the signal verifier --- for the generated VHDL testbench. --- --- Example: --- --- @ --- type ClkA = 'CLaSH.Signal.Explicit.Clk' \"A\" 100 --- --- clkA :: 'SClock' ClkA --- clkA = 'CLaSH.Signal.Explicit.sclock' --- --- expectedOutput' :: 'Signal'' ClkA Int -> 'Signal'' ClkA Bool --- expectedOutput' = 'outputVerifier'' clkA $('CLaSH.Sized.Vector.listToVecTH' ([70,99,2,3,4,5,7,8,9,10]::[Int])) --- @ --- --- >>> import qualified Data.List as List --- >>> sampleN 12 (expectedOutput' (fromList ([0..10] List.++ [10,10,10]))) --- --- cycle(A100): 0, outputVerifier --- expected value: 70, not equal to actual value: 0 --- [False --- cycle(A100): 1, outputVerifier --- expected value: 99, not equal to actual value: 1 --- ,False,False,False,False,False --- cycle(A100): 6, outputVerifier --- expected value: 7, not equal to actual value: 6 --- ,False --- cycle(A100): 7, outputVerifier --- expected value: 8, not equal to actual value: 7 --- ,False --- cycle(A100): 8, outputVerifier --- expected value: 9, not equal to actual value: 8 --- ,False --- cycle(A100): 9, outputVerifier --- expected value: 10, not equal to actual value: 9 --- ,False,True,True] -outputVerifier' :: forall l clk a . (KnownNat l, Eq a, Show a) - => SClock clk -- ^ Clock to which the input signal is - -- synchronized to - -> Vec l a -- ^ Samples to compare with - -> Signal' clk a -- ^ Signal to verify - -> Signal' clk Bool -- ^ Indicator that all samples are verified -outputVerifier' clk samples i = - let (s,o) = unbundle (genT <$> register' clk 0 s) - (e,f) = unbundle o - in assert' clk "outputVerifier" i e (register' clk False f) - where - genT :: Index l -> (Index l,(a,Bool)) - genT s = (s',(samples !! s,finished)) - where - maxI = toEnum (length samples - 1) - - s' = if s < maxI - then s + 1 - else s - - finished = s == maxI diff --git a/src/CLaSH/Promoted/Nat.hs b/src/CLaSH/Promoted/Nat.hs deleted file mode 100644 --- a/src/CLaSH/Promoted/Nat.hs +++ /dev/null @@ -1,422 +0,0 @@ -{-| -Copyright : (C) 2013-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij --} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} - -{-# LANGUAGE Trustworthy #-} - -{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise -fplugin GHC.TypeLits.KnownNat.Solver #-} -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Promoted.Nat - ( -- * Singleton natural numbers - -- ** Data type - SNat (..) - -- ** Construction - , snatProxy - , withSNat - , snat - -- ** Conversion - , snatToInteger, snatToNum - -- ** Arithmetic - , addSNat, mulSNat, powSNat - -- *** Partial - , subSNat, divSNat, modSNat, flogBaseSNat, clogBaseSNat, logBaseSNat - -- *** Specialised - , pow2SNat - -- * Unary/Peano-encoded natural numbers - -- ** Data type - , UNat (..) - -- ** Construction - , toUNat - -- ** Conversion - , fromUNat - -- ** Arithmetic - , addUNat, mulUNat, powUNat - -- *** Partial - , predUNat, subUNat - -- * Base-2 encoded natural numbers - -- ** Data type - , BNat (..) - -- ** Construction - , toBNat - -- ** Conversion - , fromBNat - -- ** Pretty printing base-2 encoded natural numbers - , showBNat - -- ** Arithmetic - , succBNat, addBNat, mulBNat, powBNat - -- *** Partial - , predBNat, div2BNat, div2Sub1BNat, log2BNat - -- ** Normalisation - , stripZeros - ) -where - -import GHC.TypeLits (KnownNat, Nat, type (+), type (-), type (*), - type (^), type (<=), natVal) -import GHC.TypeLits.Extra (CLog, FLog, Div, Log, Mod) -import Language.Haskell.TH (appT, conT, litT, numTyLit, sigE) -import Language.Haskell.TH.Syntax (Lift (..)) -import Unsafe.Coerce (unsafeCoerce) -import CLaSH.XException (ShowX (..), showsPrecXWith) - -{- $setup ->>> :set -XBinaryLiterals ->>> import CLaSH.Promoted.Nat.Literals (d789) --} - --- | Singleton value for a type-level natural number 'n' --- --- * "CLaSH.Promoted.Nat.Literals" contains a list of predefined 'SNat' literals --- * "CLaSH.Promoted.Nat.TH" has functions to easily create large ranges of new --- 'SNat' literals -data SNat (n :: Nat) where - SNat :: KnownNat n => SNat n - -instance Lift (SNat n) where - lift s = sigE [| SNat |] - (appT (conT ''SNat) (litT $ numTyLit (snatToInteger s))) - --- | Create a singleton literal for a type-level natural number -snat :: KnownNat n => SNat n -snat = SNat -{-# DEPRECATED snat "Use 'SNat' instead of 'snat'" #-} - --- | Create an @`SNat` n@ from a proxy for /n/ -snatProxy :: KnownNat n => proxy n -> SNat n -snatProxy _ = SNat - -instance Show (SNat n) where - show p@SNat = 'd' : show (natVal p) - -instance ShowX (SNat n) where - showsPrecX = showsPrecXWith showsPrec - -{-# INLINE withSNat #-} --- | Supply a function with a singleton natural 'n' according to the context -withSNat :: KnownNat n => (SNat n -> a) -> a -withSNat f = f SNat - -{-# INLINE snatToInteger #-} --- | Reify the type-level 'Nat' @n@ to it's term-level 'Integer' representation. -snatToInteger :: SNat n -> Integer -snatToInteger p@SNat = natVal p - --- | Reify the type-level 'Nat' @n@ to it's term-level 'Num'ber. -snatToNum :: Num a => SNat n -> a -snatToNum p@SNat = fromInteger (natVal p) -{-# INLINE snatToNum #-} - --- | Unary representation of a type-level natural --- --- __NB__: Not synthesisable -data UNat :: Nat -> * where - UZero :: UNat 0 - USucc :: UNat n -> UNat (n + 1) - -instance KnownNat n => Show (UNat n) where - show x = 'u':show (natVal x) - -instance KnownNat n => ShowX (UNat n) where - showsPrecX = showsPrecXWith showsPrec - --- | Convert a singleton natural number to its unary representation --- --- __NB__: Not synthesisable -toUNat :: SNat n -> UNat n -toUNat p@SNat = fromI (natVal p) - where - fromI :: Integer -> UNat m - fromI 0 = unsafeCoerce UZero - fromI n = unsafeCoerce (USucc (fromI (n - 1))) - --- | Convert a unary-encoded natural number to its singleton representation --- --- __NB__: Not synthesisable -fromUNat :: UNat n -> SNat n -fromUNat UZero = SNat :: SNat 0 -fromUNat (USucc x) = addSNat (fromUNat x) (SNat :: SNat 1) - --- | Add two unary-encoded natural numbers --- --- __NB__: Not synthesisable -addUNat :: UNat n -> UNat m -> UNat (n + m) -addUNat UZero y = y -addUNat x UZero = x -addUNat (USucc x) y = USucc (addUNat x y) - --- | Multiply two unary-encoded natural numbers --- --- __NB__: Not synthesisable -mulUNat :: UNat n -> UNat m -> UNat (n * m) -mulUNat UZero _ = UZero -mulUNat _ UZero = UZero -mulUNat (USucc x) y = addUNat y (mulUNat x y) - --- | Power of two unary-encoded natural numbers --- --- __NB__: Not synthesisable -powUNat :: UNat n -> UNat m -> UNat (n ^ m) -powUNat _ UZero = USucc UZero -powUNat x (USucc y) = mulUNat x (powUNat x y) - --- | Predecessor of a unary-encoded natural number --- --- __NB__: Not synthesisable -predUNat :: UNat (n+1) -> UNat n -predUNat (USucc x) = x - --- | Subtract two unary-encoded natural numbers --- --- __NB__: Not synthesisable -subUNat :: UNat (m+n) -> UNat n -> UNat m -subUNat x UZero = x -subUNat (USucc x) (USucc y) = subUNat x y -subUNat UZero _ = error "impossible: 0 + (n + 1) ~ 0" - --- | Add two singleton natural numbers -addSNat :: SNat a -> SNat b -> SNat (a+b) -addSNat SNat SNat = SNat -{-# INLINE addSNat #-} - --- | Subtract two singleton natural numbers -subSNat :: SNat (a+b) -> SNat b -> SNat a -subSNat SNat SNat = SNat -{-# INLINE subSNat #-} - --- | Multiply two singleton natural numbers -mulSNat :: SNat a -> SNat b -> SNat (a*b) -mulSNat SNat SNat = SNat -{-# INLINE mulSNat #-} - --- | Power of two singleton natural numbers -powSNat :: SNat a -> SNat b -> SNat (a^b) -powSNat SNat SNat = SNat -{-# NOINLINE powSNat #-} - --- | Division of two singleton natural numbers -divSNat :: (1 <= b) => SNat a -> SNat b -> SNat (Div a b) -divSNat SNat SNat = SNat -{-# INLINE divSNat #-} - --- | Modulo of two singleton natural numbers -modSNat :: (1 <= b) => SNat a -> SNat b -> SNat (Mod a b) -modSNat SNat SNat = SNat -{-# INLINE modSNat #-} - --- | Floor of the logarithm of a natural number -flogBaseSNat :: (2 <= base, 1 <= x) - => SNat base -- ^ Base - -> SNat x - -> SNat (FLog base x) -flogBaseSNat SNat SNat = SNat -{-# NOINLINE flogBaseSNat #-} - --- | Ceiling of the logarithm of a natural number -clogBaseSNat :: (2 <= base, 1 <= x) - => SNat base -- ^ Base - -> SNat x - -> SNat (CLog base x) -clogBaseSNat SNat SNat = SNat -{-# NOINLINE clogBaseSNat #-} - --- | Exact integer logarithm of a natural number --- --- __NB__: Only works when the argument is a power of the base -logBaseSNat :: (FLog base x ~ CLog base x) - => SNat base -- ^ Base - -> SNat x - -> SNat (Log base x) -logBaseSNat SNat SNat = SNat -{-# NOINLINE logBaseSNat #-} - --- | Power of two of a singleton natural number -pow2SNat :: SNat a -> SNat (2^a) -pow2SNat SNat = SNat -{-# INLINE pow2SNat #-} - --- | Base-2 encoded natural number --- --- * __NB__: The LSB is the left/outer-most constructor: --- * __NB__: Not synthesisable --- --- >>> B0 (B1 (B1 BT)) --- b6 --- --- == Constructors --- --- * Starting/Terminating element: --- --- @ --- __BT__ :: 'BNat' 0 --- @ --- --- * Append a zero (/0/): --- --- @ --- __B0__ :: 'BNat' n -> 'BNat' (2 '*' n) --- @ --- --- * Append a one (/1/): --- --- @ --- __B1__ :: 'BNat' n -> 'BNat' ((2 '*' n) '+' 1) --- @ -data BNat :: Nat -> * where - BT :: BNat 0 - B0 :: BNat n -> BNat (2*n) - B1 :: BNat n -> BNat ((2*n) + 1) - -instance KnownNat n => Show (BNat n) where - show x = 'b':show (natVal x) - -instance KnownNat n => ShowX (BNat n) where - showsPrecX = showsPrecXWith showsPrec - --- | Show a base-2 encoded natural as a binary literal --- --- __NB__: The LSB is shown as the right-most bit --- --- >>> d789 --- d789 --- >>> toBNat d789 --- b789 --- >>> showBNat (toBNat d789) --- "0b1100010101" --- >>> 0b1100010101 :: Integer --- 789 -showBNat :: BNat n -> String -showBNat = go [] - where - go :: String -> BNat m -> String - go xs BT = "0b" ++ xs - go xs (B0 x) = go ('0':xs) x - go xs (B1 x) = go ('1':xs) x - --- | Convert a singleton natural number to its base-2 representation --- --- __NB__: Not synthesisable -toBNat :: SNat n -> BNat n -toBNat s@SNat = toBNat' (natVal s) - where - toBNat' :: Integer -> BNat m - toBNat' 0 = unsafeCoerce BT - toBNat' n = case n `divMod` 2 of - (n',1) -> unsafeCoerce (B1 (toBNat' n')) - (n',_) -> unsafeCoerce (B0 (toBNat' n')) - --- | Convert a base-2 encoded natural number to its singleton representation --- --- __NB__: Not synthesisable -fromBNat :: BNat n -> SNat n -fromBNat BT = SNat :: SNat 0 -fromBNat (B0 x) = mulSNat (SNat :: SNat 2) (fromBNat x) -fromBNat (B1 x) = addSNat (mulSNat (SNat :: SNat 2) (fromBNat x)) - (SNat :: SNat 1) - --- | Add two base-2 encoded natural numbers --- --- __NB__: Not synthesisable -addBNat :: BNat n -> BNat m -> BNat (n+m) -addBNat (B0 a) (B0 b) = B0 (addBNat a b) -addBNat (B0 a) (B1 b) = B1 (addBNat a b) -addBNat (B1 a) (B0 b) = B1 (addBNat a b) -addBNat (B1 a) (B1 b) = B0 (succBNat (addBNat a b)) -addBNat BT b = b -addBNat a BT = a - --- | Multiply two base-2 encoded natural numbers --- --- __NB__: Not synthesisable -mulBNat :: BNat n -> BNat m -> BNat (n*m) -mulBNat BT _ = BT -mulBNat _ BT = BT -mulBNat (B0 a) b = B0 (mulBNat a b) -mulBNat (B1 a) b = addBNat (B0 (mulBNat a b)) b - --- | Power of two base-2 encoded natural numbers --- --- __NB__: Not synthesisable -powBNat :: BNat n -> BNat m -> BNat (n^m) -powBNat _ BT = B1 BT -powBNat a (B0 b) = let z = powBNat a b - in mulBNat z z -powBNat a (B1 b) = let z = powBNat a b - in mulBNat a (mulBNat z z) - --- | Successor of a base-2 encoded natural number --- --- __NB__: Not synthesisable -succBNat :: BNat n -> BNat (n+1) -succBNat BT = B1 BT -succBNat (B0 a) = B1 a -succBNat (B1 a) = B0 (succBNat a) - --- | Predecessor of a base-2 encoded natural number --- --- __NB__: Not synthesisable -predBNat :: BNat (n+1) -> (BNat n) -predBNat (B1 a) = case stripZeros a of - BT -> BT - a' -> B0 a' -predBNat (B0 x) = B1 (go x) - where - go :: BNat m -> BNat (m-1) - go (B1 a) = case stripZeros a of - BT -> BT - a' -> B0 a' - go (B0 a) = B1 (go a) - go BT = error "impossible: 0 ~ 0 - 1" - --- | Divide a base-2 encoded natural number by 2 --- --- __NB__: Not synthesisable -div2BNat :: BNat (2*n) -> BNat n -div2BNat BT = BT -div2BNat (B0 x) = x -div2BNat (B1 _) = error "impossible: 2*n ~ 2*n+1" - --- | Subtract 1 and divide a base-2 encoded natural number by 2 --- --- __NB__: Not synthesisable -div2Sub1BNat :: BNat (2*n+1) -> BNat n -div2Sub1BNat (B1 x) = x -div2Sub1BNat _ = error "impossible: 2*n+1 ~ 2*n" - --- | Get the log2 of a base-2 encoded natural number --- --- __NB__: Not synthesisable -log2BNat :: BNat (2^n) -> BNat n -log2BNat (B1 x) = case stripZeros x of - BT -> BT - _ -> error "impossible: 2^n ~ 2x+1" -log2BNat (B0 x) = succBNat (log2BNat x) - --- | Strip non-contributing zero's from a base-2 encoded natural number --- --- >>> B1 (B0 (B0 (B0 BT))) --- b1 --- >>> showBNat (B1 (B0 (B0 (B0 BT)))) --- "0b0001" --- >>> showBNat (stripZeros (B1 (B0 (B0 (B0 BT))))) --- "0b1" --- >>> stripZeros (B1 (B0 (B0 (B0 BT)))) --- b1 --- --- __NB__: Not synthesisable -stripZeros :: BNat n -> BNat n -stripZeros BT = BT -stripZeros (B1 x) = B1 (stripZeros x) -stripZeros (B0 BT) = BT -stripZeros (B0 x) = case stripZeros x of - BT -> BT - k -> B0 k diff --git a/src/CLaSH/Promoted/Nat/Literals.hs b/src/CLaSH/Promoted/Nat/Literals.hs deleted file mode 100644 --- a/src/CLaSH/Promoted/Nat/Literals.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-| -Copyright : (C) 2013-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij - -Predefined 'SNat' singleton literals in the range [0 .. 1024] - -Defines: - -@ -d0 = SNat :: SNat 0 -d1 = SNat :: SNat 1 -d2 = SNat :: SNat 2 -... -d1024 = SNat :: SNat 1024 -@ - -You can generate more 'SNat' literals using 'decLiteralsD' from "CLaSH.Promoted.Nat.TH" --} - -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DataKinds #-} - -{-# LANGUAGE Trustworthy #-} - -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Promoted.Nat.Literals where - -import CLaSH.Promoted.Nat.TH - -$(decLiteralsD 0 1024) diff --git a/src/CLaSH/Promoted/Nat/TH.hs b/src/CLaSH/Promoted/Nat/TH.hs deleted file mode 100644 --- a/src/CLaSH/Promoted/Nat/TH.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-| -Copyright : (C) 2013-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij --} - -{-# LANGUAGE TemplateHaskell #-} - -{-# LANGUAGE Trustworthy #-} - -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Promoted.Nat.TH - ( -- * Declare a single @d\@ literal - decLiteralD - -- * Declare ranges of @d\@ literals - , decLiteralsD - ) -where - -import Language.Haskell.TH -import CLaSH.Promoted.Nat - -{- $setup ->>> :set -XDataKinds ->>> let d1111 = SNat :: SNat 1111 ->>> let d1200 = SNat :: SNat 1200 ->>> let d1201 = SNat :: SNat 1201 ->>> let d1202 = SNat :: SNat 1202 --} - --- | Create an 'SNat' literal --- --- > $(decLiteralD 1111) --- --- >>> :t d1111 --- d1111 :: SNat 1111 --- -decLiteralD :: Integer - -> Q [Dec] -decLiteralD n = do - let suffix = if n < 0 then error ("Can't make negative SNat: " ++ show n) else show n - valName = mkName $ 'd':suffix - sig <- sigD valName (appT (conT ''SNat) (litT (numTyLit n))) - val <- valD (varP valName) (normalB [| SNat |]) [] - return [ sig, val ] - --- | Create a range of 'SNat' literals --- --- > $(decLiteralsD 1200 1202) --- --- >>> :t d1200 --- d1200 :: SNat 1200 --- >>> :t d1201 --- d1201 :: SNat 1201 --- >>> :t d1202 --- d1202 :: SNat 1202 --- -decLiteralsD :: Integer - -> Integer - -> Q [Dec] -decLiteralsD from to = - fmap concat $ sequence $ [ decLiteralD n | n <- [from..to] ] diff --git a/src/CLaSH/Promoted/Nat/Unsafe.hs b/src/CLaSH/Promoted/Nat/Unsafe.hs deleted file mode 100644 --- a/src/CLaSH/Promoted/Nat/Unsafe.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-| -Copyright : (C) 2015-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij --} - -{-# LANGUAGE Unsafe #-} - -module CLaSH.Promoted.Nat.Unsafe - (unsafeSNat) -where - -import Data.Reflection (reifyNat) -import Unsafe.Coerce (unsafeCoerce) - -import CLaSH.Promoted.Nat (SNat, snatProxy) - --- | I hope you know what you're doing -unsafeSNat :: Integer -> SNat k -unsafeSNat i = reifyNat i $ (\p -> unsafeCoerce (snatProxy p)) -{-# NOINLINE unsafeSNat #-} diff --git a/src/CLaSH/Promoted/Symbol.hs b/src/CLaSH/Promoted/Symbol.hs deleted file mode 100644 --- a/src/CLaSH/Promoted/Symbol.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-| -Copyright : (C) 2013-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij --} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} - -{-# LANGUAGE Safe #-} - -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Promoted.Symbol - (SSymbol (..), ssymbolProxy, ssymbolToString) -where - -import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) - --- | Singleton value for a type-level string @s@ -data SSymbol (s :: Symbol) where - SSymbol :: KnownSymbol s => SSymbol s - -instance Show (SSymbol s) where - show s@SSymbol = symbolVal s - -{-# INLINE ssymbolProxy #-} --- | Create a singleton symbol literal @'SSymbol' s@ from a proxy for --- /s/ -ssymbolProxy :: KnownSymbol s => proxy s -> SSymbol s -ssymbolProxy _ = SSymbol - -{-# INLINE ssymbolToString #-} --- | Reify the type-level 'Symbol' @s@ to it's term-level 'String' --- representation. -ssymbolToString :: SSymbol s -> String -ssymbolToString s@SSymbol = symbolVal s diff --git a/src/CLaSH/Signal.hs b/src/CLaSH/Signal.hs deleted file mode 100644 --- a/src/CLaSH/Signal.hs +++ /dev/null @@ -1,158 +0,0 @@ -{-| -Copyright : (C) 2013-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij --} - -{-# LANGUAGE MagicHash #-} - -{-# LANGUAGE Trustworthy #-} - -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Signal - ( -- * Implicitly clocked synchronous signal - Signal - -- * Basic circuit functions - , signal - , register - , registerMaybe - , regEn - , mux - -- * Boolean connectives - , (.&&.), (.||.), not1 - -- * Product/Signal isomorphism - , Bundle(..) - , Unbundled - -- * Simulation functions (not synthesisable) - , simulate - , simulateB - -- ** lazy versions - , simulate_lazy - , simulateB_lazy - -- * List \<-\> Signal conversion (not synthesisable) - , sample - , sampleN - , fromList - -- ** lazy versions - , sample_lazy - , sampleN_lazy - , fromList_lazy - -- * QuickCheck combinators - , testFor - -- * Type classes - -- ** 'Eq'-like - , (.==.), (./=.) - -- ** 'Ord'-like - , compare1, (.<.), (.<=.), (.>=.), (.>.) - -- ** 'Enum'-like - , fromEnum1 - -- ** 'Rational'-like - , toRational1 - -- ** 'Integral'-like - , toInteger1 - -- ** 'Bits'-like - , testBit1 - , popCount1 - , shift1 - , rotate1 - , setBit1 - , clearBit1 - , shiftL1 - , unsafeShiftL1 - , shiftR1 - , unsafeShiftR1 - , rotateL1 - , rotateR1 - ) -where - -import Control.DeepSeq (NFData) -import Data.Bits (Bits) -- Haddock only -import Data.Maybe (isJust, fromJust) - -import CLaSH.Signal.Internal (Signal', register#, regEn#, (.==.), (./=.), - compare1, (.<.), (.<=.), (.>=.), (.>.), fromEnum1, - toRational1, toInteger1, testBit1, popCount1, - shift1, rotate1, setBit1, clearBit1, shiftL1, - unsafeShiftL1, shiftR1, unsafeShiftR1, rotateL1, - rotateR1, (.||.), (.&&.), not1, mux, sample, - sampleN, fromList, simulate, signal, testFor, - sample_lazy, sampleN_lazy, simulate_lazy, - fromList_lazy) -import CLaSH.Signal.Explicit (SystemClock, systemClock) -import CLaSH.Signal.Bundle (Bundle (..), Unbundled') - -{- $setup ->>> let oscillate = register False (not <$> oscillate) ->>> let count = regEn 0 oscillate (count + 1) --} - --- * Implicitly clocked synchronous signal - --- | Signal synchronised to the \"system\" clock, which has a period of 1000. -type Signal a = Signal' SystemClock a - --- * Basic circuit functions - -{-# INLINE register #-} --- | 'register' @i s@ delays the values in 'Signal' @s@ for one cycle, and sets --- the value at time 0 to @i@ --- --- >>> sampleN 3 (register 8 (fromList [1,2,3,4])) --- [8,1,2] -register :: a -> Signal a -> Signal a -register = register# systemClock -infixr 3 `register` - -registerMaybe :: a -> Signal (Maybe a) -> Signal a -registerMaybe initial i = regEn# systemClock initial (fmap isJust i) (fmap fromJust i) -{-# INLINE registerMaybe #-} -infixr 3 `registerMaybe` - -{-# INLINE regEn #-} --- | Version of 'register' that only updates its content when its second argument --- is asserted. So given: --- --- @ --- oscillate = 'register' False ('not1' '<$>' oscillate) --- count = 'regEn' 0 oscillate (count + 1) --- @ --- --- We get: --- --- >>> sampleN 8 oscillate --- [False,True,False,True,False,True,False,True] --- >>> sampleN 8 count --- [0,0,1,1,2,2,3,3] -regEn :: a -> Signal Bool -> Signal a -> Signal a -regEn = regEn# systemClock - --- * Product/Signal isomorphism - --- | Isomorphism between a 'Signal' of a product type (e.g. a tuple) and a --- product type of 'Signal's. -type Unbundled a = Unbundled' SystemClock a - --- | Simulate a (@'Unbundled' a -> 'Unbundled' b@) function given a list of --- samples of type @a@ --- --- >>> simulateB (unbundle . register (8,8) . bundle) [(1,1), (2,2), (3,3)] :: [(Int,Int)] --- [(8,8),(1,1),(2,2),(3,3)... --- ... --- --- __NB__: This function is not synthesisable -simulateB :: (Bundle a, Bundle b, NFData a, NFData b) => (Unbundled' clk1 a -> Unbundled' clk2 b) -> [a] -> [b] -simulateB f = simulate (bundle . f . unbundle) - --- | Simulate a (@'Unbundled' a -> 'Unbundled' b@) function given a list of --- samples of type @a@ --- --- >>> simulateB (unbundle . register (8,8) . bundle) [(1,1), (2,2), (3,3)] :: [(Int,Int)] --- [(8,8),(1,1),(2,2),(3,3)... --- ... --- --- __NB__: This function is not synthesisable -simulateB_lazy :: (Bundle a, Bundle b) => (Unbundled' clk1 a -> Unbundled' clk2 b) -> [a] -> [b] -simulateB_lazy f = simulate_lazy (bundle . f . unbundle) diff --git a/src/CLaSH/Signal/Bundle.hs b/src/CLaSH/Signal/Bundle.hs deleted file mode 100644 --- a/src/CLaSH/Signal/Bundle.hs +++ /dev/null @@ -1,226 +0,0 @@ -{-| -Copyright : (C) 2013-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij - -The Product/Signal isomorphism --} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE TypeOperators #-} - -{-# LANGUAGE Trustworthy #-} - -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Signal.Bundle - ( Bundle (..) - ) -where - -import Control.Applicative (liftA2) -import GHC.TypeLits (KnownNat) -import Prelude hiding (head, map, tail) - -import CLaSH.NamedTypes ((:::)) -import CLaSH.Signal.Internal (Clock, Signal' (..)) -import CLaSH.Sized.BitVector (BitVector) -import CLaSH.Sized.Fixed (Fixed) -import CLaSH.Sized.Index (Index) -import CLaSH.Sized.Signed (Signed) -import CLaSH.Sized.Unsigned (Unsigned) -import CLaSH.Sized.Vector (Vec, traverse#, lazyV) -import CLaSH.Sized.RTree (RTree, lazyT) - --- | Isomorphism between a 'CLaSH.Signal.Signal' of a product type (e.g. a tuple) and a --- product type of 'CLaSH.Signal.Signal''s. --- --- Instances of 'bundle must satisfy the following laws: --- --- @ --- 'bundle' . 'unbundle' = 'id' --- 'unbundle' . 'bundle' = 'id' --- @ --- --- By default, 'bundle' and 'unbundle', are defined as the identity, that is, --- writing: --- --- @ --- data D = A | B --- --- instance 'bundle D --- @ --- --- is the same as: --- --- @ --- data D = A | B --- --- instance 'bundle D where --- type 'Unbundled'' clk D = 'Signal'' clk D --- 'bundle' _ s = s --- 'unbundle' _ s = s --- @ --- -class Bundle a where - type Unbundled' (clk :: Clock) a = res | res -> clk - type Unbundled' clk a = Signal' clk a - -- | Example: - -- - -- @ - -- __bundle__ :: ('Signal'' clk a, 'Signal'' clk b) -> 'Signal'' clk (a,b) - -- @ - -- - -- However: - -- - -- @ - -- __bundle__ :: 'Signal'' clk 'CLaSH.Sized.BitVector.Bit' -> 'Signal'' clk 'CLaSH.Sized.BitVector.Bit' - -- @ - bundle :: Unbundled' clk a -> Signal' clk a - - {-# INLINE bundle #-} - default bundle :: Signal' clk a -> Signal' clk a - bundle s = s - -- | Example: - -- - -- @ - -- __unbundle__ :: 'Signal'' clk (a,b) -> ('Signal'' clk a, 'Signal'' clk b) - -- @ - -- - -- However: - -- - -- @ - -- __unbundle__ :: 'Signal'' clk 'CLaSH.Sized.BitVector.Bit' -> 'Signal'' clk 'CLaSH.Sized.BitVector.Bit' - -- @ - unbundle :: Signal' clk a -> Unbundled' clk a - - {-# INLINE unbundle #-} - default unbundle :: Signal' clk a -> Signal' clk a - unbundle s = s - -instance Bundle Bool -instance Bundle Integer -instance Bundle Int -instance Bundle Float -instance Bundle Double -instance Bundle (Maybe a) -instance Bundle (Either a b) - -instance Bundle (BitVector n) -instance Bundle (Index n) -instance Bundle (Fixed rep int frac) -instance Bundle (Signed n) -instance Bundle (Unsigned n) - --- | Note that: --- --- > bundle :: () -> Signal' clk () --- > unbundle :: Signal' clk () -> () -instance Bundle () where - type Unbundled' t () = t ::: () - -- ^ This is just to satisfy the injectivity annotation - bundle u = pure u - unbundle _ = () - -instance Bundle (a,b) where - type Unbundled' t (a,b) = (Signal' t a, Signal' t b) - bundle = uncurry (liftA2 (,)) - unbundle tup = (fmap fst tup, fmap snd tup) - -instance Bundle (a,b,c) where - type Unbundled' t (a,b,c) = (Signal' t a, Signal' t b, Signal' t c) - bundle (a,b,c) = (,,) <$> a <*> b <*> c - unbundle tup = (fmap (\(x,_,_) -> x) tup - ,fmap (\(_,x,_) -> x) tup - ,fmap (\(_,_,x) -> x) tup - ) - -instance Bundle (a,b,c,d) where - type Unbundled' t (a,b,c,d) = ( Signal' t a, Signal' t b, Signal' t c - , Signal' t d - ) - bundle (a,b,c,d) = (,,,) <$> a <*> b <*> c <*> d - unbundle tup = (fmap (\(x,_,_,_) -> x) tup - ,fmap (\(_,x,_,_) -> x) tup - ,fmap (\(_,_,x,_) -> x) tup - ,fmap (\(_,_,_,x) -> x) tup - ) - -instance Bundle (a,b,c,d,e) where - type Unbundled' t (a,b,c,d,e) = ( Signal' t a, Signal' t b, Signal' t c - , Signal' t d, Signal' t e - ) - bundle (a,b,c,d,e) = (,,,,) <$> a <*> b <*> c <*> d <*> e - unbundle tup = (fmap (\(x,_,_,_,_) -> x) tup - ,fmap (\(_,x,_,_,_) -> x) tup - ,fmap (\(_,_,x,_,_) -> x) tup - ,fmap (\(_,_,_,x,_) -> x) tup - ,fmap (\(_,_,_,_,x) -> x) tup - ) - -instance Bundle (a,b,c,d,e,f) where - type Unbundled' t (a,b,c,d,e,f) = ( Signal' t a, Signal' t b, Signal' t c - , Signal' t d, Signal' t e, Signal' t f - ) - bundle (a,b,c,d,e,f) = (,,,,,) <$> a <*> b <*> c <*> d <*> e <*> f - unbundle tup = (fmap (\(x,_,_,_,_,_) -> x) tup - ,fmap (\(_,x,_,_,_,_) -> x) tup - ,fmap (\(_,_,x,_,_,_) -> x) tup - ,fmap (\(_,_,_,x,_,_) -> x) tup - ,fmap (\(_,_,_,_,x,_) -> x) tup - ,fmap (\(_,_,_,_,_,x) -> x) tup - ) - -instance Bundle (a,b,c,d,e,f,g) where - type Unbundled' t (a,b,c,d,e,f,g) = ( Signal' t a, Signal' t b, Signal' t c - , Signal' t d, Signal' t e, Signal' t f - , Signal' t g - ) - bundle (a,b,c,d,e,f,g) = (,,,,,,) <$> a <*> b <*> c <*> d <*> e <*> f - <*> g - unbundle tup = (fmap (\(x,_,_,_,_,_,_) -> x) tup - ,fmap (\(_,x,_,_,_,_,_) -> x) tup - ,fmap (\(_,_,x,_,_,_,_) -> x) tup - ,fmap (\(_,_,_,x,_,_,_) -> x) tup - ,fmap (\(_,_,_,_,x,_,_) -> x) tup - ,fmap (\(_,_,_,_,_,x,_) -> x) tup - ,fmap (\(_,_,_,_,_,_,x) -> x) tup - ) - -instance Bundle (a,b,c,d,e,f,g,h) where - type Unbundled' t (a,b,c,d,e,f,g,h) = ( Signal' t a, Signal' t b, Signal' t c - , Signal' t d, Signal' t e, Signal' t f - , Signal' t g, Signal' t h - ) - bundle (a,b,c,d,e,f,g,h) = (,,,,,,,) <$> a <*> b <*> c <*> d <*> e <*> f - <*> g <*> h - unbundle tup = (fmap (\(x,_,_,_,_,_,_,_) -> x) tup - ,fmap (\(_,x,_,_,_,_,_,_) -> x) tup - ,fmap (\(_,_,x,_,_,_,_,_) -> x) tup - ,fmap (\(_,_,_,x,_,_,_,_) -> x) tup - ,fmap (\(_,_,_,_,x,_,_,_) -> x) tup - ,fmap (\(_,_,_,_,_,x,_,_) -> x) tup - ,fmap (\(_,_,_,_,_,_,x,_) -> x) tup - ,fmap (\(_,_,_,_,_,_,_,x) -> x) tup - ) - -instance KnownNat n => Bundle (Vec n a) where - type Unbundled' t (Vec n a) = Vec n (Signal' t a) - -- The 'Traversable' instance of 'Vec' is not synthesisable, so we must - -- define 'bundle' as a primitive. - bundle = vecBundle# - unbundle = sequenceA . fmap lazyV - -{-# NOINLINE vecBundle# #-} -vecBundle# :: Vec n (Signal' t a) -> Signal' t (Vec n a) -vecBundle# = traverse# id - -instance KnownNat d => Bundle (RTree d a) where - type Unbundled' t (RTree d a) = RTree d (Signal' t a) - bundle = sequenceA - unbundle = sequenceA . fmap lazyT diff --git a/src/CLaSH/Signal/Delayed.hs b/src/CLaSH/Signal/Delayed.hs deleted file mode 100644 --- a/src/CLaSH/Signal/Delayed.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-| -Copyright : (C) 2013-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} - -{-# LANGUAGE Trustworthy #-} - -{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Signal.Delayed - ( -- * Delay-annotated synchronous signals - DSignal - , delay - , delayI - , feedback - -- * Signal \<-\> DSignal conversion - , fromSignal - , toSignal - -- * List \<-\> DSignal conversion (not synthesisable) - , dfromList - -- ** lazy versions - , dfromList_lazy - -- * Experimental - , unsafeFromSignal - , antiDelay - ) -where - -import Data.Default (Default(..)) -import GHC.TypeLits (KnownNat, Nat, type (+)) -import Prelude hiding (head, length, repeat) - -import CLaSH.Sized.Vector (Vec) -import CLaSH.Signal.Explicit (SystemClock, systemClock) -import CLaSH.Signal.Delayed.Explicit (DSignal', dfromList, dfromList_lazy, - delay', delayI', feedback, fromSignal, - toSignal, unsafeFromSignal, antiDelay) - -{- $setup ->>> :set -XDataKinds ->>> :set -XTypeOperators ->>> import CLaSH.Prelude ->>> let delay3 = delay (0 :> 0 :> 0 :> Nil) ->>> let delay2 = delayI :: DSignal n Int -> DSignal (n + 2) Int ->>> :{ -let mac :: DSignal 0 Int -> DSignal 0 Int -> DSignal 0 Int - mac x y = feedback (mac' x y) - where - mac' :: DSignal 0 Int -> DSignal 0 Int -> DSignal 0 Int - -> (DSignal 0 Int, DSignal 1 Int) - mac' a b acc = let acc' = a * b + acc - in (acc, delay (singleton 0) acc') -:} - --} - --- | A synchronized signal with samples of type @a@, synchronized to \"system\" --- clock (period 1000), that has accumulated @delay@ amount of samples delay --- along its path. -type DSignal (delay :: Nat) a = DSignal' SystemClock delay a - --- | Delay a 'DSignal' for @d@ periods. --- --- @ --- delay3 :: 'DSignal' n Int -> 'DSignal' (n + 3) Int --- delay3 = 'delay' (0 ':>' 0 ':>' 0 ':>' 'Nil') --- @ --- --- >>> sampleN 6 (delay3 (dfromList [1..])) --- [0,0,0,1,2,3] -delay :: forall a n d . KnownNat d - => Vec d a - -> DSignal n a - -> DSignal (n + d) a -delay = delay' systemClock - --- | Delay a 'DSignal' for @m@ periods, where @m@ is derived from the context. --- --- @ --- delay2 :: 'DSignal' n Int -> 'DSignal' (n + 2) Int --- delay2 = 'delayI' --- @ --- --- >>> sampleN 6 (delay2 (dfromList [1..])) --- [0,0,1,2,3,4] -delayI :: (Default a, KnownNat d) - => DSignal n a - -> DSignal (n + d) a -delayI = delayI' systemClock diff --git a/src/CLaSH/Signal/Delayed/Explicit.hs b/src/CLaSH/Signal/Delayed/Explicit.hs deleted file mode 100644 --- a/src/CLaSH/Signal/Delayed/Explicit.hs +++ /dev/null @@ -1,196 +0,0 @@ -{-| -Copyright : (C) 2013-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -{-# LANGUAGE Trustworthy #-} - -{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Signal.Delayed.Explicit - ( -- * Delay-annotated synchronous signals - DSignal' - , delay' - , delayI' - , feedback - -- * Signal \<-\> DSignal conversion - , fromSignal - , toSignal - -- * List \<-\> DSignal conversion (not synthesisable) - , dfromList - -- ** lazy versions - , dfromList_lazy - -- * Experimental - , unsafeFromSignal - , antiDelay - ) -where - -import Control.DeepSeq (NFData) -import Data.Coerce (coerce) -import Data.Default (Default(..)) -import GHC.TypeLits (KnownNat, Nat, type (+)) -import Language.Haskell.TH.Syntax (Lift) -import Prelude hiding (head, length, repeat) -import Test.QuickCheck (Arbitrary, CoArbitrary) - -import CLaSH.Promoted.Nat (SNat) -import CLaSH.Sized.Vector (Vec, head, length, repeat, shiftInAt0, - singleton) -import CLaSH.Signal (fromList, fromList_lazy, bundle, unbundle) -import CLaSH.Signal.Explicit (Signal', Clock, SClock, register') - -{- $setup ->>> :set -XDataKinds ->>> :set -XTypeOperators ->>> import CLaSH.Prelude ->>> import CLaSH.Signal.Explicit (SystemClock, systemClock) ->>> let delay3 = delay' systemClock (0 :> 0 :> 0 :> Nil) ->>> let delay2 = delayI' systemClock :: DSignal' SystemClock n Int -> DSignal' SystemClock (n + 2) Int ->>> :{ -let mac :: DSignal' SystemClock 0 Int -> DSignal' SystemClock 0 Int - -> DSignal' SystemClock 0 Int - mac x y = feedback (mac' x y) - where - mac' :: DSignal' SystemClock 0 Int -> DSignal' SystemClock 0 Int - -> DSignal' SystemClock 0 Int - -> (DSignal' SystemClock 0 Int, DSignal' SystemClock 1 Int) - mac' a b acc = let acc' = a * b + acc - in (acc, delay' systemClock (singleton 0) acc') -:} - --} - --- | A synchronized signal with samples of type @a@, synchronized to clock --- @clk@, that has accumulated @delay@ amount of samples delay along its path. -newtype DSignal' (clk :: Clock) (delay :: Nat) a = - DSignal' { -- | Strip a 'DSignal' from its delay information. - toSignal :: Signal' clk a - } - deriving (Show,Default,Functor,Applicative,Num,Fractional, - Foldable,Traversable,Arbitrary,CoArbitrary,Lift) - --- | Create a 'DSignal'' from a list --- --- Every element in the list will correspond to a value of the signal for one --- clock cycle. --- --- >>> sampleN 2 (dfromList [1,2,3,4,5]) --- [1,2] --- --- __NB__: This function is not synthesisable -dfromList :: NFData a => [a] -> DSignal' clk 0 a -dfromList = coerce . fromList - --- | Create a 'DSignal' from a list --- --- Every element in the list will correspond to a value of the signal for one --- clock cycle. --- --- >>> sampleN 2 (dfromList [1,2,3,4,5]) --- [1,2] --- --- __NB__: This function is not synthesisable -dfromList_lazy :: [a] -> DSignal' clk 0 a -dfromList_lazy = coerce . fromList_lazy - --- | Delay a 'DSignal'' for @d@ periods. --- --- @ --- delay3 :: 'DSignal'' clk n Int -> 'DSignal'' clk (n + 3) Int --- delay3 = 'delay' (0 ':>' 0 ':>' 0 ':>' 'Nil') --- @ --- --- >>> sampleN 6 (delay3 (dfromList [1..])) --- [0,0,0,1,2,3] -delay' :: forall clk a n d . KnownNat d - => SClock clk - -> Vec d a - -> DSignal' clk n a - -> DSignal' clk (n + d) a -delay' clk m ds = coerce (delaySignal (coerce ds)) - where - delaySignal :: Signal' clk a -> Signal' clk a - delaySignal s = case length m of - 0 -> s - _ -> let (r',o) = shiftInAt0 (unbundle r) (singleton s) - r = register' clk m (bundle r') - in head o - --- | Delay a 'DSignal' clk' for @m@ periods, where @m@ is derived from the --- context. --- --- @ --- delay2 :: 'DSignal'' clk n Int -> 'DSignal'' clk (n + 2) Int --- delay2 = 'delayI' --- @ --- --- >>> sampleN 6 (delay2 (dfromList [1..])) --- [0,0,1,2,3,4] -delayI' :: (Default a, KnownNat d) - => SClock clk - -> DSignal' clk n a - -> DSignal' clk (n + d) a -delayI' clk = delay' clk (repeat def) - --- | Feed the delayed result of a function back to its input: --- --- @ --- mac :: 'DSignal'' clk 0 Int -> 'DSignal'' clk 0 Int -> 'DSignal'' clk 0 Int --- mac x y = 'feedback' (mac' x y) --- where --- mac' :: 'DSignal'' clk 0 Int -> 'DSignal'' clk 0 Int -> 'DSignal'' clk 0 Int --- -> ('DSignal'' clk 0 Int, 'DSignal'' clk 1 Int) --- mac' a b acc = let acc' = a * b + acc --- in (acc, 'delay' ('singleton' 0) acc') --- @ --- --- >>> sampleN 6 (mac (dfromList [1..]) (dfromList [1..])) --- [0,1,5,14,30,55] -feedback :: (DSignal' clk n a -> (DSignal' clk n a,DSignal' clk (n + m + 1) a)) - -> DSignal' clk n a -feedback f = let (o,r) = f (coerce r) in o - --- | 'Signal's are not delayed --- --- > sample s == dsample (fromSignal s) -fromSignal :: Signal' clk a -> DSignal' clk 0 a -fromSignal = coerce - --- | __EXPERIMENTAL__ --- --- __Unsafely__ convert a 'Signal' to /any/ 'DSignal' clk'. --- --- __NB__: Should only be used to interface with functions specified in terms of --- 'Signal'. -unsafeFromSignal :: Signal' clk a -> DSignal' clk n a -unsafeFromSignal = DSignal' - --- | __EXPERIMENTAL__ --- --- Access a /delayed/ signal in the present. --- --- @ --- mac :: 'DSignal' clk' 0 Int -> 'DSignal' clk' 0 Int -> 'DSignal' clk' 0 Int --- mac x y = acc' --- where --- acc' = (x * y) + 'antiDelay' d1 acc --- acc = 'delay' ('singleton' 0) acc' --- @ -antiDelay :: SNat d -> DSignal' clk (n + d) a -> DSignal' clk n a -antiDelay _ = coerce diff --git a/src/CLaSH/Signal/Explicit.hs b/src/CLaSH/Signal/Explicit.hs deleted file mode 100644 --- a/src/CLaSH/Signal/Explicit.hs +++ /dev/null @@ -1,328 +0,0 @@ -{-| -Copyright : (C) 2013-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij --} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MagicHash #-} - -{-# LANGUAGE Trustworthy #-} - -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Signal.Explicit - ( -- * Explicitly clocked synchronous signal - -- $relativeclocks - Signal' - -- * Clock domain crossing - -- ** Clock - , Clock (..) - , SClock (..) - , sclock - , withSClock - , SystemClock - , systemClock - , freqCalc - -- ** Synchronisation primitive - , unsafeSynchronizer - -- * Basic circuit functions - , register' - , registerMaybe' - , regEn' - ) -where - -import Data.Maybe (isJust, fromJust) -import GHC.TypeLits (KnownNat, KnownSymbol) - -import CLaSH.Promoted.Nat (SNat (..), snatToNum) -import CLaSH.Promoted.Symbol (SSymbol (..)) -import CLaSH.Signal.Internal (Signal' (..), Clock (..), SClock (..), register#, - regEn#) - -{- $setup ->>> :set -XDataKinds ->>> import CLaSH.Prelude ->>> type Clk2 = Clk "clk2" 2 ->>> type Clk7 = Clk "clk7" 7 ->>> let clk2 = sclock :: SClock Clk2 ->>> let clk7 = sclock :: SClock Clk7 ->>> let oversampling = register' clk2 99 . unsafeSynchronizer clk7 clk2 . register' clk7 50 ->>> let almostId = register' clk7 70 . unsafeSynchronizer clk2 clk7 . register' clk2 99 . unsafeSynchronizer clk7 clk2 . register' clk7 50 ->>> type ClkA = Clk "A" 100 ->>> let clkA = sclock :: SClock ClkA ->>> let oscillate = register' clkA False (CLaSH.Signal.not1 oscillate) ->>> let count = regEn' clkA 0 oscillate (count + 1) --} - -{- $relativeclocks #relativeclocks# -CλaSH supports explicitly clocked 'CLaSH.Signal's in the form of: - -@ -'Signal'' (clk :: 'Clock') a -@ - -Where @a@ is the type of the elements, and @clk@ is the clock to which the -signal is synchronised. The type-parameter, @clk@, is of the kind 'Clock' which -has types of the following shape: - -@ -Clk \{\- name :: \-\} 'GHC.TypeLits.Symbol' \{\- period :: \-\} 'GHC.TypeLits.Nat' -@ - -Where @name@ is a type-level string ('GHC.TypeLits.Symbol') representing the the -name of the clock, and @period@ is a type-level natural number ('GHC.TypeLits.Nat') -representing the clock period. Two concrete instances of a 'Clk' could be: - -> type ClkA500 = Clk "A500" 500 -> type ClkB3250 = Clk "B3250" 3250 - -The periods of these clocks are however dimension-less, they do not refer to any -explicit time-scale (e.g. nano-seconds). The reason for the lack of an explicit -time-scale is that the CλaSH compiler would not be able guarantee that the -circuit can run at the specified frequency. The clock periods are just there to -indicate relative frequency differences between two different clocks. That is, a -signal: - -@ -'Signal'' ClkA500 a -@ - -is synchronized to a clock that runs 6.5 times faster than the clock to which -the signal: - -@ -'Signal'' ClkB3250 a -@ - -is synchronized to. - -* __NB__: \"Bad things\"™ happen when you actually use a clock period of @0@, -so do __not__ do that! -* __NB__: You should be judicious using a clock with period of @1@ as you can -never create a clock that goes any faster! --} - --- * Clock domain crossing - --- ** Clock - -{-# INLINE sclock #-} --- | Create a singleton clock --- --- @ --- type ClkA = 'Clk' \"A\" 100 --- --- clkA :: 'SClock' ClkA --- clkA = 'sclock' --- @ -sclock :: (KnownSymbol name, KnownNat period) - => SClock ('Clk name period) -sclock = SClock SSymbol SNat - -{-# INLINE withSClock #-} --- | Supply a function with a singleton clock @clk@ according to the context -withSClock :: (KnownSymbol name, KnownNat period) - => (SClock ('Clk name period) -> a) - -> a -withSClock f = f (SClock SSymbol SNat) - --- | The standard system clock with a period of 1000 -type SystemClock = 'Clk "system" 1000 - -{-# INLINE systemClock #-} --- | The singleton clock for 'SystemClock' -systemClock :: SClock SystemClock -systemClock = sclock - --- | Calculate relative periods given a list of frequencies. --- --- So for example, you have one part of your design connected to an ADC running --- at 20 MHz, one part of your design connected to a DAC running at 36 MHz, and --- the rest of your system is running at 50 MHz. What are the relative --- (integer) clock periods in CλaSH, such that their ratios correspond to the --- ratios between the actual clock frequencies. --- --- For this we use 'freqCalc': --- --- >>> freqCalc [20,36,50] --- [45,25,18] --- --- So that we create the proper clocks: --- --- @ --- type ADC20 = 'Clk' \"ADC\" 45 --- type DAC36 = 'Clk' \"DAC\" 25 --- type Sys50 = 'Clk' \"Sys\" 18 --- --- sys50 :: SClock Sys50 --- sys50 = 'sclock' --- --- adc20 :: SClock ADC20 --- adc20 = 'sclock' --- --- dac36 :: SClock DAC36 --- dac36 = 'sclock' --- @ --- --- __NB__: This function is /not/ synthesisable -freqCalc :: [Integer] -> [Integer] -freqCalc xs = map (`div` g) ys - where - p = product xs - ys = map (p `div`) xs - g = foldr1 gcd ys - --- ** Synchronisation primitive -{-# NOINLINE unsafeSynchronizer #-} --- | The 'unsafeSynchronizer' function is a primitive that must be used to --- connect one clock domain to the other, and will be synthesised to a (bundle --- of) wire(s) in the eventual circuit. This function should only be used as --- part of a proper synchronisation component, such as the following dual --- flip-flop synchronizer: --- --- @ --- dualFlipFlop :: SClock clkA -> SClock clkB --- -> Signal' clkA Bit -> Signal' clkB Bit --- dualFlipFlop clkA clkB = 'register'' clkB low . 'register'' clkB low --- . 'unsafeSynchronizer' clkA clkB --- @ --- --- The 'unsafeSynchronizer' works in such a way that, given 2 clocks: --- --- @ --- type Clk7 = 'Clk' \"clk7\" 7 --- --- clk7 :: 'SClock' Clk7 --- clk7 = 'sclock' --- @ --- --- and --- --- @ --- type Clk2 = 'Clk' \"clk2\" 2 --- --- clk2 :: 'SClock' Clk2 --- clk2 = 'sclock' --- @ --- --- Oversampling followed by compression is the identity function plus 2 initial --- values: --- --- @ --- 'register'' clk7 i $ --- 'unsafeSynchronizer' clk2 clk7 $ --- 'register'' clk2 j $ --- 'unsafeSynchronizer' clk7 clk2 $ --- 'register'' clk7 k s --- --- == --- --- i :- j :- s --- @ --- --- Something we can easily observe: --- --- @ --- oversampling = 'register'' clk2 99 . 'unsafeSynchronizer' clk7 clk2 --- . 'register'' clk7 50 --- almostId = 'register'' clk7 70 . 'unsafeSynchronizer' clk2 clk7 --- . 'register'' clk2 99 . 'unsafeSynchronizer' clk7 clk2 --- . 'register'' clk7 50 --- @ --- --- >>> sampleN 37 (oversampling (fromList [1..10])) --- [99,50,1,1,1,2,2,2,2,3,3,3,4,4,4,4,5,5,5,6,6,6,6,7,7,7,8,8,8,8,9,9,9,10,10,10,10] --- >>> sampleN 12 (almostId (fromList [1..10])) --- [70,99,1,2,3,4,5,6,7,8,9,10] -unsafeSynchronizer :: SClock clk1 -- ^ 'Clock' of the incoming signal - -> SClock clk2 -- ^ 'Clock' of the outgoing signal - -> Signal' clk1 a - -> Signal' clk2 a -unsafeSynchronizer (SClock _ period1) (SClock _ period2) s = s' - where - t1 = snatToNum period1 - t2 = snatToNum period2 - s' | t1 < t2 = compress t2 t1 s - | t1 > t2 = oversample t1 t2 s - | otherwise = same s - -same :: Signal' clk1 a -> Signal' clk2 a -same (s :- ss) = s :- same ss - -oversample :: Int -> Int -> Signal' clk1 a -> Signal' clk2 a -oversample high low (s :- ss) = s :- oversampleS (reverse (repSchedule high low)) ss - -oversampleS :: [Int] -> Signal' clk1 a -> Signal' clk2 a -oversampleS sched = oversample' sched - where - oversample' [] s = oversampleS sched s - oversample' (d:ds) (s:-ss) = prefixN d s (oversample' ds ss) - - prefixN 0 _ s = s - prefixN n x s = x :- prefixN (n-1) x s - -compress :: Int -> Int -> Signal' clk1 a -> Signal' clk2 a -compress high low s = compressS (repSchedule high low) s - -compressS :: [Int] -> Signal' clk1 a -> Signal' clk2 a -compressS sched = compress' sched - where - compress' [] s = compressS sched s - compress' (d:ds) ss@(s :- _) = s :- compress' ds (dropS d ss) - - dropS 0 s = s - dropS n (_ :- ss) = dropS (n-1) ss - -repSchedule :: Int -> Int -> [Int] -repSchedule high low = take low $ repSchedule' low high 1 - where - repSchedule' cnt th rep - | cnt < th = repSchedule' (cnt+low) th (rep + 1) - | otherwise = rep : repSchedule' (cnt + low) (th + high) 1 - --- * Basic circuit functions - -{-# INLINE register' #-} --- | \"@'register'' i s@\" delays the values in 'Signal'' @s@ for one cycle, --- and sets the value at time 0 to @i@ --- --- @ --- type ClkA = 'Clk' \"A\" 100 --- --- clkA :: 'SClock' ClkA --- clkA = 'sclock' --- @ --- --- >>> sampleN 3 (register' clkA 8 (fromList [1,2,3,4])) --- [8,1,2] -register' :: SClock clk -> a -> Signal' clk a -> Signal' clk a -register' = register# - -registerMaybe' :: SClock clk -> a -> Signal' clk (Maybe a) -> Signal' clk a -registerMaybe' clk initial i = regEn# clk initial (fmap isJust i) (fmap fromJust i) -{-# INLINE registerMaybe' #-} - -{-# INLINE regEn' #-} --- | Version of 'register'' that only updates its content when its third --- argument is asserted. So given: --- --- @ --- type ClkA = 'Clk' \"A\" 100 --- clkA :: 'SClock' ClkA --- clkA = 'sclock' --- --- oscillate = 'register'' clkA False ('CLaSH.Signal.not1' oscillate) --- count = 'regEn'' clkA 0 oscillate (count + 1) --- @ --- --- We get: --- --- >>> sampleN 8 oscillate --- [False,True,False,True,False,True,False,True] --- >>> sampleN 8 count --- [0,0,1,1,2,2,3,3] -regEn' :: SClock clk -> a -> Signal' clk Bool -> Signal' clk a -> Signal' clk a -regEn' = regEn# diff --git a/src/CLaSH/Signal/Internal.hs b/src/CLaSH/Signal/Internal.hs deleted file mode 100644 --- a/src/CLaSH/Signal/Internal.hs +++ /dev/null @@ -1,710 +0,0 @@ -{-| -Copyright : (C) 2013-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -{-# LANGUAGE Unsafe #-} - --- See: https://github.com/clash-lang/clash-compiler/commit/721fcfa9198925661cd836668705f817bddaae3c --- as to why we need this. -{-# OPTIONS_GHC -fno-cpr-anal #-} - -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Signal.Internal - ( -- * Datatypes - Clock (..) - , SClock (..) - , Signal' (..) - -- * Basic circuits - , register# - , regEn# - , mux - , signal - -- * Boolean connectives - , (.&&.), (.||.), not1 - -- * Simulation functions (not synthesisable) - , simulate - -- ** lazy version - , simulate_lazy - -- * List \<-\> Signal conversion (not synthesisable) - , sample - , sampleN - , fromList - -- ** lazy versions - , sample_lazy - , sampleN_lazy - , fromList_lazy - -- * QuickCheck combinators - , testFor - -- * Type classes - -- ** 'Eq'-like - , (.==.), (./=.) - -- ** 'Ord'-like - , compare1, (.<.), (.<=.), (.>=.), (.>.) - -- ** 'Functor' - , mapSignal# - -- ** 'Applicative' - , signal# - , appSignal# - -- ** 'Foldable' - , foldr# - -- ** 'Traversable' - , traverse# - -- ** 'Enum'-like - , fromEnum1 - -- ** 'Rational'-like - , toRational1 - -- ** 'Integral'-like - , toInteger1 - -- ** 'Bits'-like - , testBit1 - , popCount1 - , shift1 - , rotate1 - , setBit1 - , clearBit1 - , shiftL1 - , unsafeShiftL1 - , shiftR1 - , unsafeShiftR1 - , rotateL1 - , rotateR1 - -- * EXTREMELY EXPERIMENTAL - , joinSignal# - ) -where - -import Control.Applicative (liftA2, liftA3) -import Control.DeepSeq (NFData, force) -import Control.Exception (catch, evaluate, throw) -import Data.Bits (Bits (..)) -import Data.Default (Default (..)) -import GHC.TypeLits (Nat, Symbol) -import Language.Haskell.TH.Syntax (Lift (..)) -import System.IO.Unsafe (unsafeDupablePerformIO) -import Test.QuickCheck (Arbitrary (..), CoArbitrary(..), Property, - property) - -import CLaSH.Promoted.Nat (SNat, snatToInteger) -import CLaSH.Promoted.Symbol (SSymbol, ssymbolToString) -import CLaSH.XException (XException, errorX, seqX) - -{- $setup ->>> :set -XDataKinds ->>> :set -XMagicHash ->>> import CLaSH.Promoted.Nat ->>> import CLaSH.Promoted.Symbol ->>> type SystemClock = Clk "System" 1000 ->>> type Signal a = Signal' SystemClock a ->>> let register = register# (SClock SSymbol SNat :: SClock SystemClock) --} - --- | A clock with a name ('Symbol') and period ('Nat') -data Clock = Clk Symbol Nat - --- | Singleton value for a type-level 'Clock' with the given @name@ and @period@ -data SClock (clk :: Clock) - where - SClock :: SSymbol name -> SNat period -> SClock ('Clk name period) - -instance Show (SClock clk) where - show (SClock nm r) = ssymbolToString nm ++ show (snatToInteger r) - -infixr 5 :- --- | A synchronized signal with samples of type @a@, explicitly synchronized to --- a clock @clk@ --- --- __NB__: The constructor, @(':-')@, is __not__ synthesisable. -data Signal' (clk :: Clock) a = a :- Signal' clk a - -instance Show a => Show (Signal' clk a) where - show (x :- xs) = show x ++ " " ++ show xs - -instance Lift a => Lift (Signal' clk a) where - lift ~(x :- _) = [| signal# x |] - -instance Default a => Default (Signal' clk a) where - def = signal# def - -instance Functor (Signal' clk) where - fmap = mapSignal# - -{-# NOINLINE mapSignal# #-} -mapSignal# :: (a -> b) -> Signal' clk a -> Signal' clk b -mapSignal# f (a :- as) = f a :- mapSignal# f as - -instance Applicative (Signal' clk) where - pure = signal# - (<*>) = appSignal# - -{-# NOINLINE signal# #-} -signal# :: a -> Signal' clk a -signal# a = let s = a :- s in s - -{-# NOINLINE appSignal# #-} -appSignal# :: Signal' clk (a -> b) -> Signal' clk a -> Signal' clk b -appSignal# (f :- fs) xs@(~(a :- as)) = f a :- (xs `seq` appSignal# fs as) -- See [NOTE: Lazy ap] - -{- NOTE: Lazy ap -Signal's ap, i.e (Applicative.<*>), must be lazy in it's second argument: - -> appSignal :: Signal' clk (a -> b) -> Signal' clk a -> Signal' clk b -> appSignal (f :- fs) ~(a :- as) = f a :- appSignal fs as - -because some feedback loops, such as the loop described in 'system' in the -example at http://hackage.haskell.org/package/clash-prelude-0.10.10/docs/CLaSH-Prelude-BlockRam.html, -will lead to "Exception <>". - -However, this "naive" lazy version is _too_ lazy and induces spaceleaks. -The current version: - -> appSignal# :: Signal' clk (a -> b) -> Signal' clk a -> Signal' clk b -> appSignal# (f :- fs) xs@(~(a :- as)) = f a :- (xs `seq` appSignal# fs as) - -Is lazy enough to handle the earlier mentioned feedback loops, but doesn't leak -(as much) memory like the "naive" lazy version, because the Signal constructor -of the second argument is evaluated as soon as the tail of the result is evaluated. --} - - -{-# NOINLINE joinSignal# #-} --- | __WARNING: EXTREMELY EXPERIMENTAL__ --- --- The circuit semantics of this operation are unclear and/or non-existent. --- There is a good reason there is no 'Monad' instance for 'Signal''. --- --- Is currently treated as 'id' by the CLaSH compiler. -joinSignal# :: Signal' clk (Signal' clk a) -> Signal' clk a -joinSignal# ~(xs :- xss) = head# xs :- joinSignal# (mapSignal# tail# xss) - where - head# (x' :- _ ) = x' - tail# (_ :- xs') = xs' - -instance Num a => Num (Signal' clk a) where - (+) = liftA2 (+) - (-) = liftA2 (-) - (*) = liftA2 (*) - negate = fmap negate - abs = fmap abs - signum = fmap signum - fromInteger = signal# . fromInteger - --- | __NB__: Not synthesisable --- --- __NB__: In \"@'foldr' f z s@\": --- --- * The function @f@ should be /lazy/ in its second argument. --- * The @z@ element will never be used. -instance Foldable (Signal' clk) where - foldr = foldr# - -{-# NOINLINE foldr# #-} --- | __NB__: Not synthesisable --- --- __NB__: In \"@'foldr#' f z s@\": --- --- * The function @f@ should be /lazy/ in its second argument. --- * The @z@ element will never be used. -foldr# :: (a -> b -> b) -> b -> Signal' clk a -> b -foldr# f z (a :- s) = a `f` (foldr# f z s) - -instance Traversable (Signal' clk) where - traverse = traverse# - -{-# NOINLINE traverse# #-} -traverse# :: Applicative f => (a -> f b) -> Signal' clk a -> f (Signal' clk b) -traverse# f (a :- s) = (:-) <$> f a <*> traverse# f s - -infixr 2 .||. --- | The above type is a generalisation for: --- --- @ --- __(.||.)__ :: 'CLaSH.Signal.Signal' 'Bool' -> 'CLaSH.Signal.Signal' 'Bool' -> 'CLaSH.Signal.Signal' 'Bool' --- @ --- --- It is a version of ('||') that returns a 'CLaSH.Signal.Signal' of 'Bool' -(.||.) :: Applicative f => f Bool -> f Bool -> f Bool -(.||.) = liftA2 (||) - -infixr 3 .&&. --- | The above type is a generalisation for: --- --- @ --- __(.&&.)__ :: 'CLaSH.Signal.Signal' 'Bool' -> 'CLaSH.Signal.Signal' 'Bool' -> 'CLaSH.Signal.Signal' 'Bool' --- @ --- --- It is a version of ('&&') that returns a 'CLaSH.Signal.Signal' of 'Bool' -(.&&.) :: Applicative f => f Bool -> f Bool -> f Bool -(.&&.) = liftA2 (&&) - --- | The above type is a generalisation for: --- --- @ --- __not1__ :: 'CLaSH.Signal.Signal' 'Bool' -> 'CLaSH.Signal.Signal' 'Bool' --- @ --- --- It is a version of 'not' that operates on 'CLaSH.Signal.Signal's of 'Bool' -not1 :: Functor f => f Bool -> f Bool -not1 = fmap not -{-# DEPRECATED not1 "'not1' will be removed in clash-prelude-1.0, use \"fmap not\" instead." #-} - -{-# NOINLINE register# #-} -register# :: SClock clk -> a -> Signal' clk a -> Signal' clk a -register# _ i s = i :- s - -{-# NOINLINE regEn# #-} -regEn# :: SClock clk -> a -> Signal' clk Bool -> Signal' clk a -> Signal' clk a -regEn# _ = go - where - -- In order to produce the first (current) value of the register's output - -- signal, 'o', we don't need to know the shape of either input (enable or - -- value-in). This is important, because both values might be produced from - -- the output in a feedback loop, so we can't know their shape (pattern - -- match) them until we have produced output. - -- - -- Thus, we use lazy pattern matching to delay inspecting the shape of - -- either argument until output has been produced. - -- - -- However, both arguments need to be evaluated to WHNF as soon as possible - -- to avoid a space-leak. Below, we explicitly reduce the value-in signal - -- using 'seq' as the tail of our output signal is produced. On the other - -- hand, because the value of the tail depends on the value of the enable - -- signal 'e', it will be forced by the 'if'/'then' statement and we don't - -- need to 'seq' it explicitly. - go o ~(e :- es) as@(~(x :- xs)) = - o `seqX` o :- (as `seq` if e then go x es xs else go o es xs) - -{-# INLINE mux #-} --- | The above type is a generalisation for: --- --- @ --- __mux__ :: 'CLaSH.Signal.Signal' 'Bool' -> 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' a --- @ --- --- A multiplexer. Given "@'mux' b t f@", output @t@ when @b@ is 'True', and @f@ --- when @b@ is 'False'. -mux :: Applicative f => f Bool -> f a -> f a -> f a -mux = liftA3 (\b t f -> if b then t else f) - -{-# INLINE signal #-} --- | The above type is a generalisation for: --- --- @ --- __signal__ :: a -> 'CLaSH.Signal.Signal' a --- @ --- --- Create a constant 'CLaSH.Signal.Signal' from a combinational value --- --- >>> sampleN 5 (signal 4 :: Signal Int) --- [4,4,4,4,4] -signal :: Applicative f => a -> f a -signal = pure - -infix 4 .==. --- | The above type is a generalisation for: --- --- @ --- __(.==.)__ :: 'Eq' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Bool' --- @ --- --- It is a version of ('==') that returns a 'CLaSH.Signal.Signal' of 'Bool' -(.==.) :: (Eq a, Applicative f) => f a -> f a -> f Bool -(.==.) = liftA2 (==) - -infix 4 ./=. --- | The above type is a generalisation for: --- --- @ --- __(./=.)__ :: 'Eq' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Bool' --- @ --- --- It is a version of ('/=') that returns a 'CLaSH.Signal.Signal' of 'Bool' -(./=.) :: (Eq a, Applicative f) => f a -> f a -> f Bool -(./=.) = liftA2 (/=) - --- | The above type is a generalisation for: --- --- @ --- __compare1__ :: 'Ord' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Ordering' --- @ --- --- It is a version of 'compare' that returns a 'CLaSH.Signal.Signal' of 'Ordering' -compare1 :: (Ord a, Applicative f) => f a -> f a -> f Ordering -compare1 = liftA2 compare -{-# DEPRECATED compare1 "'compare1' will be removed in clash-prelude-1.0, use \"liftA2 compare\" instead." #-} - -infix 4 .<. --- | The above type is a generalisation for: --- --- @ --- __(.<.)__ :: 'Ord' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Bool' --- @ --- --- It is a version of ('<') that returns a 'CLaSH.Signal.Signal' of 'Bool' -(.<.) :: (Ord a, Applicative f) => f a -> f a -> f Bool -(.<.) = liftA2 (<) - -infix 4 .<=. --- | The above type is a generalisation for: --- --- @ --- __(.<=.)__ :: 'Ord' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Bool' --- @ --- --- It is a version of ('<=') that returns a 'CLaSH.Signal.Signal' of 'Bool' -(.<=.) :: (Ord a, Applicative f) => f a -> f a -> f Bool -(.<=.) = liftA2 (<=) - -infix 4 .>. --- | The above type is a generalisation for: --- --- @ --- __(.>.)__ :: 'Ord' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Bool' --- @ --- --- It is a version of ('>') that returns a 'CLaSH.Signal.Signal' of 'Bool' -(.>.) :: (Ord a, Applicative f) => f a -> f a -> f Bool -(.>.) = liftA2 (>) - -infix 4 .>=. --- | The above type is a generalisation for: --- --- @ --- __(.>=.)__ :: 'Ord' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Bool' --- @ --- --- It is a version of ('>=') that returns a 'CLaSH.Signal.Signal' of 'Bool' -(.>=.) :: (Ord a, Applicative f) => f a -> f a -> f Bool -(.>=.) = liftA2 (>=) - --- | The above type is a generalisation for: --- --- @ --- __fromEnum1__ :: 'Enum' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Int' --- @ --- --- It is a version of 'fromEnum' that returns a CLaSH.Signal.Signal' of 'Int' -fromEnum1 :: (Enum a, Functor f) => f a -> f Int -fromEnum1 = fmap fromEnum -{-# DEPRECATED fromEnum1 "'fromEnum1' will be removed in clash-prelude-1.0, use \"fmap fromEnum\" instead." #-} - --- | The above type is a generalisation for: --- --- @ --- __toRational1__ :: 'Real' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Rational' --- @ --- --- It is a version of 'toRational' that returns a 'CLaSH.Signal.Signal' of 'Rational' -toRational1 :: (Real a, Functor f) => f a -> f Rational -toRational1 = fmap toRational -{-# DEPRECATED toRational1 "'toRational1' will be removed in clash-prelude-1.0, use \"fmap toRational\" instead." #-} - --- | The above type is a generalisation for: --- --- @ --- __toInteger1__ :: 'Integral' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Integer' --- @ --- --- It is a version of 'toRational' that returns a 'CLaSH.Signal.Signal' of 'Integer' -toInteger1 :: (Integral a, Functor f) => f a -> f Integer -toInteger1 = fmap toInteger -{-# DEPRECATED toInteger1 "'toInteger1' will be removed in clash-prelude-1.0, use \"fmap toInteger\" instead." #-} - --- | The above type is a generalisation for: --- --- @ --- __testBit1__ :: 'Bits' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Int' -> 'CLaSH.Signal.Signal' 'Bool' --- @ --- --- It is a version of 'testBit' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing --- argument, and a result of 'CLaSH.Signal.Signal' of 'Bool' -testBit1 :: (Bits a, Applicative f) => f a -> f Int -> f Bool -testBit1 = liftA2 testBit -{-# DEPRECATED testBit1 "'testBit1' will be removed in clash-prelude-1.0, use \"liftA2 testBit\" instead." #-} - --- | The above type is a generalisation for: --- --- @ --- __popCount1__ :: 'Bits' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Int' --- @ --- --- It is a version of 'popCount' that returns a 'CLaSH.Signal.Signal' of 'Int' -popCount1 :: (Bits a, Functor f) => f a -> f Int -popCount1 = fmap popCount -{-# DEPRECATED popCount1 "'popCount1' will be removed in clash-prelude-1.0, use \"fmap popCount\" instead." #-} - --- | The above type is a generalisation for: --- --- @ --- __shift1__ :: 'Bits' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Int' -> 'CLaSH.Signal.Signal' 'a' --- @ --- --- It is a version of 'shift' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument -shift1 :: (Bits a, Applicative f) => f a -> f Int -> f a -shift1 = liftA2 shift -{-# DEPRECATED shift1 "'shift1' will be removed in clash-prelude-1.0, use \"liftA2 shift\" instead." #-} - --- | The above type is a generalisation for: --- --- @ --- __rotate1__ :: 'Bits' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Int' -> 'CLaSH.Signal.Signal' 'a' --- @ --- --- It is a version of 'rotate' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument -rotate1 :: (Bits a, Applicative f) => f a -> f Int -> f a -rotate1 = liftA2 rotate -{-# DEPRECATED rotate1 "'rotate1' will be removed in clash-prelude-1.0, use \"liftA2 rotate\" instead." #-} - --- | The above type is a generalisation for: --- --- @ --- __setBit1__ :: 'Bits' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Int' -> 'CLaSH.Signal.Signal' 'a' --- @ --- --- It is a version of 'setBit' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument -setBit1 :: (Bits a, Applicative f) => f a -> f Int -> f a -setBit1 = liftA2 setBit -{-# DEPRECATED setBit1 "'setBit1' will be removed in clash-prelude-1.0, use \"liftA2 setBit\" instead." #-} - --- | The above type is a generalisation for: --- --- @ --- __clearBit1__ :: 'Bits' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Int' -> 'CLaSH.Signal.Signal' 'a' --- @ --- --- It is a version of 'clearBit' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument -clearBit1 :: (Bits a, Applicative f) => f a -> f Int -> f a -clearBit1 = liftA2 clearBit -{-# DEPRECATED clearBit1 "'clearBit1' will be removed in clash-prelude-1.0, use \"liftA2 clearBit\" instead." #-} - --- | The above type is a generalisation for: --- --- @ --- __shiftL1__ :: 'Bits' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Int' -> 'CLaSH.Signal.Signal' 'a' --- @ --- --- It is a version of 'shiftL' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument -shiftL1 :: (Bits a, Applicative f) => f a -> f Int -> f a -shiftL1 = liftA2 shiftL -{-# DEPRECATED shiftL1 "'shiftL1' will be removed in clash-prelude-1.0, use \"liftA2 shiftL\" instead." #-} - --- | The above type is a generalisation for: --- --- @ --- __unsafeShiftL1__ :: 'Bits' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Int' -> 'CLaSH.Signal.Signal' 'a' --- @ --- --- It is a version of 'unsafeShiftL' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument -unsafeShiftL1 :: (Bits a, Applicative f) => f a -> f Int -> f a -unsafeShiftL1 = liftA2 unsafeShiftL -{-# DEPRECATED unsafeShiftL1 "'unsafeShiftL1' will be removed in clash-prelude-1.0, use \"liftA2 unsafeShiftL\" instead." #-} - --- | The above type is a generalisation for: --- --- @ --- __shiftR1__ :: 'Bits' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Int' -> 'CLaSH.Signal.Signal' 'a' --- @ --- --- It is a version of 'shiftR' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument -shiftR1 :: (Bits a, Applicative f) => f a -> f Int -> f a -shiftR1 = liftA2 shiftR -{-# DEPRECATED shiftR1 "'shiftR1' will be removed in clash-prelude-1.0, use \"liftA2 shiftR\" instead." #-} - --- | The above type is a generalisation for: --- --- @ --- __unsafeShiftR1__ :: 'Bits' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Int' -> 'CLaSH.Signal.Signal' 'a' --- @ --- --- It is a version of 'unsafeShiftR' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument -unsafeShiftR1 :: (Bits a, Applicative f) => f a -> f Int -> f a -unsafeShiftR1 = liftA2 unsafeShiftR -{-# DEPRECATED unsafeShiftR1 "'unsafeShiftR1' will be removed in clash-prelude-1.0, use \"liftA2 unsafeShiftR\" instead." #-} - --- | The above type is a generalisation for: --- --- @ --- __rotateL1__ :: 'Bits' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Int' -> 'CLaSH.Signal.Signal' 'a' --- @ --- --- It is a version of 'rotateL' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument -rotateL1 :: (Bits a, Applicative f) => f a -> f Int -> f a -rotateL1 = liftA2 rotateL -{-# DEPRECATED rotateL1 "'rotateL1' will be removed in clash-prelude-1.0, use \"liftA2 rotateL\" instead." #-} - --- | The above type is a generalisation for: --- --- @ --- __rotateR1__ :: 'Bits' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Int' -> 'CLaSH.Signal.Signal' 'a' --- @ --- --- It is a version of 'rotateR' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument -rotateR1 :: (Bits a, Applicative f) => f a -> f Int -> f a -rotateR1 = liftA2 rotateR -{-# DEPRECATED rotateR1 "'rotateR1' will be removed in clash-prelude-1.0, use \"liftA2 rotateR\" instead." #-} - -instance Fractional a => Fractional (Signal' clk a) where - (/) = liftA2 (/) - recip = fmap recip - fromRational = signal# . fromRational - -instance Arbitrary a => Arbitrary (Signal' clk a) where - arbitrary = liftA2 (:-) arbitrary arbitrary - -instance CoArbitrary a => CoArbitrary (Signal' clk a) where - coarbitrary xs gen = do - n <- arbitrary - coarbitrary (take (abs n) (sample_lazy xs)) gen - --- | The above type is a generalisation for: --- --- @ --- __testFor__ :: 'Int' -> 'CLaSH.Signal.Signal' Bool -> 'Property' --- @ --- --- @testFor n s@ tests the signal @s@ for @n@ cycles. -testFor :: Foldable f => Int -> f Bool -> Property -testFor n = property . and . take n . sample - --- * List \<-\> Signal conversion (not synthesisable) - --- | A 'force' that lazily returns exceptions -forceNoException :: NFData a => a -> IO a -forceNoException x = catch (evaluate (force x)) (\(e :: XException) -> return (throw e)) - -headStrictCons :: NFData a => a -> [a] -> [a] -headStrictCons x xs = unsafeDupablePerformIO ((:) <$> forceNoException x <*> pure xs) - -headStrictSignal :: NFData a => a -> Signal' clk a -> Signal' clk a -headStrictSignal x xs = unsafeDupablePerformIO ((:-) <$> forceNoException x <*> pure xs) - --- | The above type is a generalisation for: --- --- @ --- __sample__ :: 'CLaSH.Signal.Signal' a -> [a] --- @ --- --- Get an infinite list of samples from a 'CLaSH.Signal.Signal' --- --- The elements in the list correspond to the values of the 'CLaSH.Signal.Signal' --- at consecutive clock cycles --- --- > sample s == [s0, s1, s2, s3, ... --- --- __NB__: This function is not synthesisable -sample :: (Foldable f, NFData a) => f a -> [a] -sample = foldr headStrictCons [] - --- | The above type is a generalisation for: --- --- @ --- __sampleN__ :: Int -> 'CLaSH.Signal.Signal' a -> [a] --- @ --- --- Get a list of @n@ samples from a 'CLaSH.Signal.Signal' --- --- The elements in the list correspond to the values of the 'CLaSH.Signal.Signal' --- at consecutive clock cycles --- --- > sampleN 3 s == [s0, s1, s2] --- --- __NB__: This function is not synthesisable -sampleN :: (Foldable f, NFData a) => Int -> f a -> [a] -sampleN n = take n . sample - --- | Create a 'CLaSH.Signal.Signal' from a list --- --- Every element in the list will correspond to a value of the signal for one --- clock cycle. --- --- >>> sampleN 2 (fromList [1,2,3,4,5]) --- [1,2] --- --- __NB__: This function is not synthesisable -fromList :: NFData a => [a] -> Signal' clk a -fromList = Prelude.foldr headStrictSignal (errorX "finite list") - --- * Simulation functions (not synthesisable) - --- | Simulate a (@'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' b@) function --- given a list of samples of type @a@ --- --- >>> simulate (register 8) [1, 2, 3] --- [8,1,2,3... --- ... --- --- __NB__: This function is not synthesisable -simulate :: (NFData a, NFData b) => (Signal' clk1 a -> Signal' clk2 b) -> [a] -> [b] -simulate f = sample . f . fromList - --- | The above type is a generalisation for: --- --- @ --- __sample__ :: 'CLaSH.Signal.Signal' a -> [a] --- @ --- --- Get an infinite list of samples from a 'CLaSH.Signal.Signal' --- --- The elements in the list correspond to the values of the 'CLaSH.Signal.Signal' --- at consecutive clock cycles --- --- > sample s == [s0, s1, s2, s3, ... --- --- __NB__: This function is not synthesisable -sample_lazy :: Foldable f => f a -> [a] -sample_lazy = foldr (:) [] - --- | The above type is a generalisation for: --- --- @ --- __sampleN__ :: Int -> 'CLaSH.Signal.Signal' a -> [a] --- @ --- --- Get a list of @n@ samples from a 'CLaSH.Signal.Signal' --- --- The elements in the list correspond to the values of the 'CLaSH.Signal.Signal' --- at consecutive clock cycles --- --- > sampleN 3 s == [s0, s1, s2] --- --- __NB__: This function is not synthesisable -sampleN_lazy :: Foldable f => Int -> f a -> [a] -sampleN_lazy n = take n . sample_lazy - --- | Create a 'CLaSH.Signal.Signal' from a list --- --- Every element in the list will correspond to a value of the signal for one --- clock cycle. --- --- >>> sampleN 2 (fromList [1,2,3,4,5]) --- [1,2] --- --- __NB__: This function is not synthesisable -fromList_lazy :: [a] -> Signal' clk a -fromList_lazy = Prelude.foldr (:-) (error "finite list") - --- * Simulation functions (not synthesisable) - --- | Simulate a (@'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' b@) function --- given a list of samples of type @a@ --- --- >>> simulate (register 8) [1, 2, 3] --- [8,1,2,3... --- ... --- --- __NB__: This function is not synthesisable -simulate_lazy :: (Signal' clk1 a -> Signal' clk2 b) -> [a] -> [b] -simulate_lazy f = sample_lazy . f . fromList_lazy diff --git a/src/CLaSH/Sized/BitVector.hs b/src/CLaSH/Sized/BitVector.hs deleted file mode 100644 --- a/src/CLaSH/Sized/BitVector.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-| -Copyright : (C) 2013-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij --} - -{-# LANGUAGE MagicHash #-} - -{-# LANGUAGE Trustworthy #-} - -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Sized.BitVector - ( -- * Datatypes - BitVector - , Bit - -- * Accessors - -- ** Length information - , size# - , maxIndex# - -- * Construction - -- ** Initialisation - , high - , low - , bLit - -- ** Concatenation - , (++#) - ) -where - -import CLaSH.Sized.Internal.BitVector diff --git a/src/CLaSH/Sized/Fixed.hs b/src/CLaSH/Sized/Fixed.hs deleted file mode 100644 --- a/src/CLaSH/Sized/Fixed.hs +++ /dev/null @@ -1,963 +0,0 @@ -{-| -Copyright : (C) 2013-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij - -Fixed point numbers - -* The 'Num' operators for the given types saturate on overflow, - and use truncation as the rounding method. -* 'Fixed' has an instance for 'Fractional' meaning you use fractional - literals @(3.75 :: 'SFixed' 4 18)@. -* Both integer literals and fractional literals are clipped to 'minBound' and - 'maxBound'. -* There is no 'Floating' instance for 'Fixed', but you can use @$$('fLit' d)@ - to create 'Fixed' point literal from 'Double' constant at compile-time. -* Use <#constraintsynonyms Constraint synonyms> when writing type signatures - for polymorphic functions that use 'Fixed' point numbers. - -BEWARE: rounding by truncation introduces a sign bias! - -* Truncation for positive numbers effectively results in: round towards zero. -* Truncation for negative numbers effectively results in: round towards -infinity. --} - -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# LANGUAGE Trustworthy #-} - -{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Sized.Fixed - ( -- * 'SFixed': 'Signed' 'Fixed' point numbers - SFixed, sf, unSF - -- * 'UFixed': 'Unsigned' 'Fixed' point numbers - , UFixed, uf, unUF - -- * Division - , divide - -- * Compile-time 'Double' conversion - , fLit - -- * Run-time 'Double' conversion (not synthesisable) - , fLitR - -- * 'Fixed' point wrapper - , Fixed (..), resizeF, fracShift - -- * Constraint synonyms - -- $constraintsynonyms - - -- ** Constraint synonyms for 'SFixed' - , NumSFixedC, ENumSFixedC, FracSFixedC, ResizeSFC, DivideSC - -- ** Constraint synonyms for 'UFixed' - , NumUFixedC, ENumUFixedC, FracUFixedC, ResizeUFC, DivideUC - -- ** Constraint synonyms for 'Fixed' wrapper - , NumFixedC, ENumFixedC, FracFixedC, ResizeFC, DivideC - -- * Proxy - , asRepProxy, asIntProxy - ) -where - -import Control.DeepSeq (NFData) -import Control.Arrow ((***), second) -import Data.Bits (Bits (..), FiniteBits) -import Data.Data (Data) -import Data.Default (Default (..)) -import Text.Read (Read(..)) -import Data.List (find) -import Data.Maybe (fromJust) -import Data.Proxy (Proxy (..)) -import Data.Ratio ((%), denominator, numerator) -import Data.Typeable (Typeable, TypeRep, typeRep) -import GHC.TypeLits (KnownNat, Nat, type (+), natVal) -import GHC.TypeLits.Extra (Max) -import Language.Haskell.TH (Q, TExp, TypeQ, appT, conT, litT, mkName, - numTyLit, sigE) -import Language.Haskell.TH.Syntax (Lift(..)) -import Test.QuickCheck (Arbitrary, CoArbitrary) - -import CLaSH.Class.BitPack (BitPack (..)) -import CLaSH.Class.Num (ExtendingNum (..), SaturatingNum (..), - SaturationMode (..), boundedPlus, boundedMin, - boundedMult) -import CLaSH.Class.Resize (Resize (..)) -import CLaSH.Promoted.Nat (SNat) -import CLaSH.Prelude.BitIndex (msb, split) -import CLaSH.Prelude.BitReduction (reduceAnd, reduceOr) -import CLaSH.Sized.BitVector (BitVector, (++#)) -import CLaSH.Sized.Signed (Signed) -import CLaSH.Sized.Unsigned (Unsigned) -import CLaSH.XException (ShowX (..), showsPrecXWith) - -{- $setup ->>> :set -XDataKinds ->>> :set -XTemplateHaskell ->>> import CLaSH.Prelude ->>> let n = $$(fLit pi) :: SFixed 4 4 --} - --- | 'Fixed'-point number --- --- Where: --- --- * @rep@ is the underlying representation --- --- * @int@ is the number of bits used to represent the integer part --- --- * @frac@ is the number of bits used to represent the fractional part --- --- The 'Num' operators for this type saturate to 'maxBound' on overflow and --- 'minBound' on underflow, and use truncation as the rounding method. -newtype Fixed (rep :: Nat -> *) (int :: Nat) (frac :: Nat) = - Fixed { unFixed :: rep (int + frac) } - -deriving instance NFData (rep (int + frac)) => NFData (Fixed rep int frac) -deriving instance (Typeable rep, Typeable int, Typeable frac - , Data (rep (int + frac))) => Data (Fixed rep int frac) -deriving instance Eq (rep (int + frac)) => Eq (Fixed rep int frac) -deriving instance Ord (rep (int + frac)) => Ord (Fixed rep int frac) -deriving instance Enum (rep (int + frac)) => Enum (Fixed rep int frac) -deriving instance Bounded (rep (int + frac)) => Bounded (Fixed rep int frac) -deriving instance Default (rep (int + frac)) => Default (Fixed rep int frac) -deriving instance Arbitrary (rep (int + frac)) => Arbitrary (Fixed rep int frac) -deriving instance CoArbitrary (rep (int + frac)) => CoArbitrary (Fixed rep int frac) -deriving instance FiniteBits (rep (int + frac)) => FiniteBits (Fixed rep int frac) - --- | Instance functions do not saturate. --- Meaning that \"@`'shiftL'` 1 == 'satMult' 'SatWrap' 2'@\"" -deriving instance Bits (rep (int + frac)) => Bits (Fixed rep int frac) - --- | Signed 'Fixed'-point number, with @int@ integer bits (including sign-bit) --- and @frac@ fractional bits. --- --- * The range 'SFixed' @int@ @frac@ numbers is: [-(2^(@int@ -1)) .. --- 2^(@int@-1) - 2^-@frac@ ] --- * The resolution of 'SFixed' @int@ @frac@ numbers is: 2^@frac@ --- * The 'Num' operators for this type saturate on overflow, --- and use truncation as the rounding method. --- --- >>> maxBound :: SFixed 3 4 --- 3.9375 --- >>> minBound :: SFixed 3 4 --- -4.0 --- >>> read (show (maxBound :: SFixed 3 4)) :: SFixed 3 4 --- 3.9375 --- >>> 1 + 2 :: SFixed 3 4 --- 3.0 --- >>> 2 + 3 :: SFixed 3 4 --- 3.9375 --- >>> (-2) + (-3) :: SFixed 3 4 --- -4.0 --- >>> 1.375 * (-0.8125) :: SFixed 3 4 --- -1.125 --- >>> (1.375 :: SFixed 3 4) `times` (-0.8125 :: SFixed 3 4) :: SFixed 6 8 --- -1.1171875 --- >>> (2 :: SFixed 3 4) `plus` (3 :: SFixed 3 4) :: SFixed 4 4 --- 5.0 --- >>> (-2 :: SFixed 3 4) `plus` (-3 :: SFixed 3 4) :: SFixed 4 4 --- -5.0 -type SFixed = Fixed Signed - --- | Unsigned 'Fixed'-point number, with @int@ integer bits and @frac@ --- fractional bits --- --- * The range 'UFixed' @int@ @frac@ numbers is: [0 .. 2^@int@ - 2^-@frac@ ] --- * The resolution of 'UFixed' @int@ @frac@ numbers is: 2^@frac@ --- * The 'Num' operators for this type saturate on overflow, --- and use truncation as the rounding method. --- --- >>> maxBound :: UFixed 3 4 --- 7.9375 --- >>> minBound :: UFixed 3 4 --- 0.0 --- >>> 1 + 2 :: UFixed 3 4 --- 3.0 --- >>> 2 + 6 :: UFixed 3 4 --- 7.9375 --- >>> 1 - 3 :: UFixed 3 4 --- 0.0 --- >>> 1.375 * 0.8125 :: UFixed 3 4 --- 1.0625 --- >>> (1.375 :: UFixed 3 4) `times` (0.8125 :: UFixed 3 4) :: UFixed 6 8 --- 1.1171875 --- >>> (2 :: UFixed 3 4) `plus` (6 :: UFixed 3 4) :: UFixed 4 4 --- 8.0 --- --- However, 'minus' does not saturate to 'minBound' on underflow: --- --- >>> (1 :: UFixed 3 4) `minus` (3 :: UFixed 3 4) :: UFixed 4 4 --- 14.0 -type UFixed = Fixed Unsigned - -{-# INLINE sf #-} --- | Treat a 'Signed' integer as a @Signed@ 'Fixed'-@point@ integer --- --- >>> sf d4 (-22 :: Signed 7) --- -1.375 -sf :: SNat frac -- ^ Position of the virtual @point@ - -> Signed (int + frac) -- ^ The 'Signed' integer - -> SFixed int frac -sf _ fRep = Fixed fRep - -{-# INLINE unSF #-} --- | See the underlying representation of a Signed Fixed-point integer -unSF :: SFixed int frac - -> Signed (int + frac) -unSF (Fixed fRep) = fRep - -{-# INLINE uf #-} --- | Treat an 'Unsigned' integer as a @Unsigned@ 'Fixed'-@point@ number --- --- >>> uf d4 (92 :: Unsigned 7) --- 5.75 -uf :: SNat frac -- ^ Position of the virtual @point@ - -> Unsigned (int + frac) -- ^ The 'Unsigned' integer - -> UFixed int frac -uf _ fRep = Fixed fRep - -{-# INLINE unUF #-} --- | See the underlying representation of an Unsigned Fixed-point integer -unUF :: UFixed int frac - -> Unsigned (int + frac) -unUF (Fixed fRep) = fRep - -{-# INLINE asRepProxy #-} --- | 'Fixed' as a 'Proxy' for it's representation type @rep@ -asRepProxy :: Fixed rep int frac -> Proxy rep -asRepProxy _ = Proxy - -{-# INLINE asIntProxy #-} --- | 'Fixed' as a 'Proxy' for the number of integer bits @int@ -asIntProxy :: Fixed rep int frac -> Proxy int -asIntProxy _ = Proxy - --- | Get the position of the virtual @point@ of a 'Fixed'-@point@ number -fracShift :: KnownNat frac => Fixed rep int frac -> Int -fracShift fx = fromInteger (natVal fx) - -instance ( size ~ (int + frac), KnownNat frac, Integral (rep size) - ) => Show (Fixed rep int frac) where - show f@(Fixed fRep) = - i ++ "." ++ (uncurry pad . second (show . numerator) . - fromJust . find ((==1) . denominator . snd) . - iterate (succ *** (*10)) . (,) 0 $ (nom % denom)) - where - pad n str = replicate (n - length str) '0' ++ str - - nF = fracShift f - fRepI = toInteger fRep - fRepI_abs = abs fRepI - i = if fRepI < 0 then '-' : show (fRepI_abs `shiftR` nF) - else show (fRepI `shiftR` nF) - nom = if fRepI < 0 then fRepI_abs .&. ((2 ^ nF) - 1) - else fRepI .&. ((2 ^ nF) - 1) - denom = 2 ^ nF - -instance ( size ~ (int + frac), KnownNat frac, Integral (rep size) - ) => ShowX (Fixed rep int frac) where - showsPrecX = showsPrecXWith showsPrec - --- | None of the 'Read' class' methods are synthesisable. -instance (size ~ (int + frac), KnownNat frac, Bounded (rep size), Integral (rep size)) - => Read (Fixed rep int frac) where - readPrec = fLitR <$> readPrec - -{- $constraintsynonyms #constraintsynonyms# -Writing polymorphic functions over fixed point numbers can be a potentially -verbose due to the many class constraints induced by the functions and operators -of this module. - -Writing a simple multiply-and-accumulate function can already give rise to many -lines of constraints: - -@ -mac :: ( 'GHC.TypeLits.KnownNat' frac - , 'GHC.TypeLits.KnownNat' (frac + frac) - , 'GHC.TypeLits.KnownNat' (int + frac) - , 'GHC.TypeLits.KnownNat' (1 + (int + frac)) - , 'GHC.TypeLits.KnownNat' ((int + frac) + (int + frac)) - , ((int + int) + (frac + frac)) ~ ((int + frac) + (int + frac)) - ) - => 'SFixed' int frac - -> 'SFixed' int frac - -> 'SFixed' int frac - -> 'SFixed' int frac -mac s x y = s + (x * y) -@ - -But with constraint synonyms, you can write the type signature like this: - -@ -mac1 :: 'NumSFixedC' int frac - => 'SFixed' int frac - -> 'SFixed' int frac - -> 'SFixed' int frac - -> 'SFixed' int frac -mac1 s x y = s + (x * y) -@ - -Where 'NumSFixedC' refers to the @Constraints@ needed by the operators of -the 'Num' class for the 'SFixed' datatype. - -Although the number of constraints for the @mac@ function defined earlier might -be considered small, here is an \"this way lies madness\" example where you -really want to use constraint kinds: - -@ -mac2 :: ( 'GHC.TypeLits.KnownNat' frac1 - , 'GHC.TypeLits.KnownNat' frac2 - , 'GHC.TypeLits.KnownNat' frac3 - , 'GHC.TypeLits.KnownNat' (Max frac1 frac2) - , 'GHC.TypeLits.KnownNat' (int1 + frac1) - , 'GHC.TypeLits.KnownNat' (int2 + frac2) - , 'GHC.TypeLits.KnownNat' (int3 + frac3) - , 'GHC.TypeLits.KnownNat' (frac1 + frac2) - , 'GHC.TypeLits.KnownNat' (Max (frac1 + frac2) frac3) - , 'GHC.TypeLits.KnownNat' (((int1 + int2) + (frac1 + frac2)) + (int3 + frac3)) - , 'GHC.TypeLits.KnownNat' ((int1 + int2) + (frac1 + frac2)) - , 'GHC.TypeLits.KnownNat' (1 + Max (int1 + frac1) (int2 + frac2)) - , 'GHC.TypeLits.KnownNat' (1 + Max (int1 + int2) int3 + Max (frac1 + frac2) frac3) - , 'GHC.TypeLits.KnownNat' ((1 + Max int1 int2) + Max frac1 frac2) - , 'GHC.TypeLits.KnownNat' ((1 + Max ((int1 + int2) + (frac1 + frac2)) (int3 + frac3))) - , ((int1 + frac1) + (int2 + frac2)) ~ ((int1 + int2) + (frac1 + frac2)) - , (((int1 + int2) + int3) + ((frac1 + frac2) + frac3)) ~ (((int1 + int2) + (frac1 + frac2)) + (int3 + frac3)) - ) - => 'SFixed' int1 frac1 - -> 'SFixed' int2 frac2 - -> 'SFixed' int3 frac3 - -> 'SFixed' (1 + Max (int1 + int2) int3) (Max (frac1 + frac2) frac3) -mac2 x y s = (x \`times\` y) \`plus\` s -@ - -Which, with the proper constraint kinds can be reduced to: - -@ -mac3 :: ( 'ENumSFixedC' int1 frac1 int2 frac2 - , 'ENumSFixedC' (int1 + int2) (frac1 + frac2) int3 frac3 - ) - => 'SFixed' int1 frac1 - -> 'SFixed' int2 frac2 - -> 'SFixed' int3 frac3 - -> 'SFixed' (1 + Max (int1 + int2) int3) (Max (frac1 + frac2) frac3) -mac3 x y s = (x \`times\` y) \`plus\` s -@ --} - --- | Constraint for the 'ExtendingNum' instance of 'Fixed' -type ENumFixedC rep int1 frac1 int2 frac2 - = ( Bounded (rep ((1 + Max int1 int2) + Max frac1 frac2)) - , Num (rep ((1 + Max int1 int2) + Max frac1 frac2)) - , Bits (rep ((1 + Max int1 int2) + Max frac1 frac2)) - , ExtendingNum (rep (int1 + frac1)) (rep (int2 + frac2)) - , MResult (rep (int1 + frac1)) (rep (int2 + frac2)) ~ - rep ((int1 + int2) + (frac1 + frac2)) - , KnownNat int1 - , KnownNat int2 - , KnownNat frac1 - , KnownNat frac2 - , Resize rep - ) - --- | Constraint for the 'ExtendingNum' instance of 'SFixed' -type ENumSFixedC int1 frac1 int2 frac2 - = ( KnownNat (int2 + frac2) - , KnownNat (1 + Max int1 int2 + Max frac1 frac2) - , KnownNat (Max frac1 frac2) - , KnownNat (1 + Max int1 int2) - , KnownNat (int1 + frac1) - , KnownNat frac2 - , KnownNat int2 - , KnownNat frac1 - , KnownNat int1 - ) - --- | Constraint for the 'ExtendingNum' instance of 'UFixed' -type ENumUFixedC int1 frac1 int2 frac2 = - ENumSFixedC int1 frac1 int2 frac2 - --- | When used in a polymorphic setting, use the following --- for less --- verbose type signatures: --- --- * @'ENumFixedC' rep frac1 frac2 size1 size2@ for: 'Fixed' --- * @'ENumSFixedC' int1 frac1 int2 frac2@ for: 'SFixed' --- * @'ENumUFixedC' int1 frac1 int2 frac2@ for: 'UFixed' -instance ENumFixedC rep int1 frac1 int2 frac2 => - ExtendingNum (Fixed rep int1 frac1) (Fixed rep int2 frac2) where - type AResult (Fixed rep int1 frac1) (Fixed rep int2 frac2) = - Fixed rep (1 + Max int1 int2) (Max frac1 frac2) - plus (Fixed f1) (Fixed f2) = - let sh1 = fromInteger (natVal (Proxy @(Max frac1 frac2)) - natVal (Proxy @frac1)) :: Int - f1R = shiftL (resize f1) sh1 :: rep ((1 + Max int1 int2) + (Max frac1 frac2)) - sh2 = fromInteger (natVal (Proxy @(Max frac1 frac2)) - natVal (Proxy @frac2)) :: Int - f2R = shiftL (resize f2) sh2 :: rep ((1 + Max int1 int2) + (Max frac1 frac2)) - in Fixed (f1R + f2R) - minus (Fixed f1) (Fixed f2) = - let sh1 = fromInteger (natVal (Proxy @(Max frac1 frac2)) - natVal (Proxy @frac1)) :: Int - f1R = shiftL (resize f1) sh1 :: rep ((1 + Max int1 int2) + (Max frac1 frac2)) - sh2 = fromInteger (natVal (Proxy @(Max frac1 frac2)) - natVal (Proxy @frac2)) :: Int - f2R = shiftL (resize f2) sh2 :: rep ((1 + Max int1 int2) + (Max frac1 frac2)) - in Fixed (f1R - f2R) - type MResult (Fixed rep int1 frac1) (Fixed rep int2 frac2) = - Fixed rep (int1 + int2) (frac1 + frac2) - times (Fixed fRep1) (Fixed fRep2) = Fixed (times fRep1 fRep2) - --- | Constraint for the 'Num' instance of 'Fixed' -type NumFixedC rep int frac - = ( SaturatingNum (rep (int + frac)) - , ExtendingNum (rep (int + frac)) (rep (int + frac)) - , MResult (rep (int + frac)) (rep (int + frac)) ~ - rep ((int + int) + (frac + frac)) - , BitSize (rep ((int + int) + (frac + frac))) ~ - (int + ((int + frac) + frac)) - , BitPack (rep ((int + int) + (frac + frac))) - , Bits (rep ((int + int) + (frac + frac))) - , KnownNat (BitSize (rep (int + frac))) - , BitPack (rep (int + frac)) - , Enum (rep (int + frac)) - , Bits (rep (int + frac)) - , Resize rep - , KnownNat int - , KnownNat frac - ) - --- | Constraint for the 'Num' instance of 'SFixed' -type NumSFixedC int frac = - ( KnownNat ((int + int) + (frac + frac)) - , KnownNat (frac + frac) - , KnownNat (int + int) - , KnownNat (int + frac) - , KnownNat frac - , KnownNat int - ) - --- | Constraint for the 'Num' instance of 'UFixed' -type NumUFixedC int frac = - NumSFixedC int frac - --- | The operators of this instance saturate on overflow, and use truncation as --- the rounding method. --- --- When used in a polymorphic setting, use the following --- for less --- verbose type signatures: --- --- * @'NumFixedC' frac rep size@ for: @'Fixed' frac rep size@ --- * @'NumSFixedC' int frac@ for: @'SFixed' int frac@ --- * @'NumUFixedC' int frac@ for: @'UFixed' int frac@ -instance (NumFixedC rep int frac) => Num (Fixed rep int frac) where - (+) = boundedPlus - (*) = boundedMult - (-) = boundedMin - negate (Fixed a) = Fixed (negate a) - abs (Fixed a) = Fixed (abs a) - signum (Fixed a) = Fixed (signum a) - fromInteger i = let fSH = fromInteger (natVal (Proxy @frac)) - res = Fixed (fromInteger i `shiftL` fSH) - in res - -instance (BitPack (rep (int + frac))) => BitPack (Fixed rep int frac) where - type BitSize (Fixed rep int frac) = BitSize (rep (int + frac)) - pack (Fixed fRep) = pack fRep - unpack bv = Fixed (unpack bv) - -instance (Lift (rep (int + frac)), KnownNat frac, KnownNat int, Typeable rep) => - Lift (Fixed rep int frac) where - lift f@(Fixed fRep) = sigE [| Fixed fRep |] - (decFixed (typeRep (asRepProxy f)) - (natVal (asIntProxy f)) - (natVal f)) - -decFixed :: TypeRep -> Integer -> Integer -> TypeQ -decFixed r i f = do - foldl appT (conT ''Fixed) [ conT (mkName (show r)) - , litT (numTyLit i) - , litT (numTyLit f) - ] - --- | Constraint for the 'resizeF' function -type ResizeFC rep int1 frac1 int2 frac2 - = ( Resize rep - , Ord (rep (int1 + frac1)) - , Num (rep (int1 + frac1)) - , Bits (rep (int1 + frac1)) - , Bits (rep (int2 + frac2)) - , Bounded (rep (int2 + frac2)) - , KnownNat int1 - , KnownNat frac1 - , KnownNat int2 - , KnownNat frac2 - ) - --- | Constraint for the 'resizeF' function, specialized for 'SFixed' -type ResizeSFC int1 frac1 int2 frac2 - = ( KnownNat int1 - , KnownNat frac1 - , KnownNat int2 - , KnownNat frac2 - , KnownNat (int2 + frac2) - , KnownNat (int1 + frac1) - ) - --- | Constraint for the 'resizeF' function, specialized for 'UFixed' -type ResizeUFC int1 frac1 int2 frac2 = - ResizeSFC int1 frac1 int2 frac2 - -{-# INLINE resizeF #-} --- | Saturating resize operation, truncates for rounding --- --- >>> 0.8125 :: SFixed 3 4 --- 0.8125 --- >>> resizeF (0.8125 :: SFixed 3 4) :: SFixed 2 3 --- 0.75 --- >>> 3.4 :: SFixed 3 4 --- 3.375 --- >>> resizeF (3.4 :: SFixed 3 4) :: SFixed 2 3 --- 1.875 --- >>> maxBound :: SFixed 2 3 --- 1.875 --- --- When used in a polymorphic setting, use the following --- <#constraintsynonyms Constraint synonyms> for less verbose type signatures: --- --- * @'ResizeFC' rep int1 frac1 int2 frac2@ for: --- @'Fixed' rep int1 frac1 -> 'Fixed' rep int2 frac2@ --- --- * @'ResizeSFC' int1 frac1 int2 frac2@ for: --- @'SFixed' int1 frac1 -> 'SFixed' int2 frac2@ --- --- * @'ResizeUFC' rep int1 frac1 int2 frac2@ for: --- @'UFixed' int1 frac1 -> 'UFixed' int2 frac2@ -resizeF :: forall rep int1 frac1 int2 frac2 . ResizeFC rep int1 frac1 int2 frac2 - => Fixed rep int1 frac1 - -> Fixed rep int2 frac2 -resizeF (Fixed fRep) = Fixed sat - where - fMin = minBound :: rep (int2 + frac2) - fMax = maxBound :: rep (int2 + frac2) - argSZ = natVal (Proxy @(int1 + frac1)) - resSZ = natVal (Proxy @(int2 + frac2)) - - argFracSZ = fromInteger (natVal (Proxy @frac1)) - resFracSZ = fromInteger (natVal (Proxy @frac2)) - - -- All size and frac comparisons and related if-then-else statements should - -- be optimized away by the compiler - sat = if argSZ <= resSZ - -- if the argument is smaller than the result, resize before shift - then if argFracSZ <= resFracSZ - then resize fRep `shiftL` (resFracSZ - argFracSZ) - else resize fRep `shiftR` (argFracSZ - resFracSZ) - -- if the argument is bigger than the result, shift before resize - else let mask = complement (resize fMax) :: rep (int1 + frac1) - in if argFracSZ <= resFracSZ - then let shiftedL = fRep `shiftL` - (resFracSZ - argFracSZ) - shiftedL_masked = shiftedL .&. mask - shiftedL_resized = resize shiftedL - in if fRep >= 0 - then if shiftedL_masked == 0 - then shiftedL_resized - else fMax - else if shiftedL_masked == mask - then shiftedL_resized - else fMin - else let shiftedR = fRep `shiftR` - (argFracSZ - resFracSZ) - shiftedR_masked = shiftedR .&. mask - shiftedR_resized = resize shiftedR - in if fRep >= 0 - then if shiftedR_masked == 0 - then shiftedR_resized - else fMax - else if shiftedR_masked == mask - then shiftedR_resized - else fMin - --- | Convert, at compile-time, a 'Double' /constant/ to a 'Fixed'-point /literal/. --- The conversion saturates on overflow, and uses truncation as its rounding --- method. --- --- So when you type: --- --- @ --- n = $$('fLit' pi) :: 'SFixed' 4 4 --- @ --- --- The compiler sees: --- --- @ --- n = 'Fixed' (fromInteger 50) :: 'SFixed' 4 4 --- @ --- --- Upon evaluation you see that the value is rounded / truncated in accordance --- to the fixed point representation: --- --- >>> n --- 3.125 --- --- Further examples: --- --- >>> sin 0.5 :: Double --- 0.479425538604203 --- >>> $$(fLit (sin 0.5)) :: SFixed 1 8 --- 0.4765625 --- >>> atan 0.2 :: Double --- 0.19739555984988078 --- >>> $$(fLit (atan 0.2)) :: SFixed 1 8 --- 0.1953125 --- >>> $$(fLit (atan 0.2)) :: SFixed 1 20 --- 0.19739532470703125 -fLit :: forall rep int frac size . - ( size ~ (int + frac), KnownNat frac, Bounded (rep size) - , Integral (rep size)) - => Double - -> Q (TExp (Fixed rep int frac)) -fLit a = [|| Fixed (fromInteger sat) ||] - where - rMax = toInteger (maxBound :: rep size) - rMin = toInteger (minBound :: rep size) - sat = if truncated > rMax - then rMax - else if truncated < rMin - then rMin - else truncated - truncated = truncate shifted :: Integer - shifted = a * (2 ^ (natVal (Proxy @frac))) - --- | Convert, at run-time, a 'Double' to a 'Fixed'-point. --- --- __NB__: this functions is /not/ synthesisable --- --- = Creating data-files #creatingdatafiles# --- --- An example usage of this function is for example to convert a data file --- containing 'Double's to a data file with ASCI-encoded binary numbers to be --- used by a synthesisable function like 'CLaSH.Prelude.ROM.File.asyncRomFile'. --- For example, given a file @Data.txt@ containing: --- --- @ --- 1.2 2.0 3.0 4.0 --- -1.0 -2.0 -3.5 -4.0 --- @ --- --- which we want to put in a ROM, interpreting them as @8.8@ signed fixed point --- numbers. What we do is that we first create a conversion utility, --- @createRomFile@, which uses 'fLitR': --- --- @createRomFile.hs@: --- --- @ --- module Main where --- --- import CLaSH.Prelude --- import System.Environment --- import qualified Data.List as L --- --- createRomFile :: KnownNat n => (Double -> BitVector n) --- -> FilePath -> FilePath -> IO () --- createRomFile convert fileR fileW = do --- f <- readFile fileR --- let ds :: [Double] --- ds = L.concat . (L.map . L.map) read . L.map words $ lines f --- bvs = L.map (filter (/= '_') . show . convert) ds --- writeFile fileW (unlines bvs) --- --- toSFixed8_8 :: Double -> SFixed 8 8 --- toSFixed8_8 = 'fLitR' --- --- main :: IO () --- main = do --- [fileR,fileW] <- getArgs --- createRomFile ('pack' . toSFixed8_8) fileR fileW --- @ --- --- We then compile this to an executable: --- --- @ --- \$ clash --make createRomFile.hs --- @ --- --- We can then use this utility to convert our @Data.txt@ file which contains --- 'Double's to a @Data.bin@ file which will containing the desired ASCI-encoded --- binary data: --- --- @ --- \$ ./createRomFile \"Data.txt\" \"Data.bin\" --- @ --- --- Which results in a @Data.bin@ file containing: --- --- @ --- 0000000100110011 --- 0000001000000000 --- 0000001100000000 --- 0000010000000000 --- 1111111100000000 --- 1111111000000000 --- 1111110010000000 --- 1111110000000000 --- @ --- --- We can then use this @Data.bin@ file in for our ROM: --- --- @ --- romF :: Unsigned 3 -> Unsigned 3 -> SFixed 8 8 --- romF rowAddr colAddr = 'unpack' --- $ 'CLaSH.Prelude.ROM.File.asyncRomFile' d8 "Data.bin" ((rowAddr * 4) + colAddr) --- @ --- --- And see that it works as expected: --- --- @ --- __>>> romF 1 2__ --- -3.5 --- __>>> romF 0 0__ --- 1.19921875 --- @ --- --- == Using Template Haskell --- --- For those of us who like to live on the edge, another option is to convert --- our @Data.txt@ at compile-time using --- . --- For this we first create a module @CreateRomFileTH.hs@: --- --- @ --- module CreateRomFileTH (romDataFromFile) where --- --- import CLaSH.Prelude --- import qualified Data.List as L --- import Language.Haskell.TH (ExpQ, litE, stringL) --- import Language.Haskell.TH.Syntax (qRunIO) --- --- createRomFile :: KnownNat n => (Double -> BitVector n) --- -> FilePath -> FilePath -> IO () --- createRomFile convert fileR fileW = do --- f <- readFile fileR --- let ds :: [Double] --- ds = L.concat . (L.map . L.map) read . L.map words $ lines f --- bvs = L.map (filter (/= '_') . show . convert) ds --- writeFile fileW (unlines bvs) --- --- romDataFromFile :: KnownNat n => (Double -> BitVector n) -> String -> ExpQ --- romDataFromFile convert fileR = do --- let fileW = fileR L.++ ".bin" --- bvF <- qRunIO (createRomFile convert fileR fileW) --- litE (stringL fileW) --- @ --- --- Instead of first converting @Data.txt@ to @Data.bin@, we will now use the --- @romDataFromFile@ function to convert @Data.txt@ to a new file in the proper --- format at compile-time of our new @romF'@ function: --- --- @ --- import CLaSH.Prelude --- import CreateRomFileTH --- --- toSFixed8_8 :: Double -> SFixed 8 8 --- toSFixed8_8 = 'fLitR' --- --- romF' :: Unsigned 3 -> Unsigned 3 -> SFixed 8 8 --- romF' rowAddr colAddr = unpack $ --- asyncRomFile d8 --- $(romDataFromFile (pack . toSFixed8_8) "Data.txt") -- Template Haskell splice --- ((rowAddr * 4) + colAddr) --- @ --- --- And see that it works just like the @romF@ function from earlier: --- --- @ --- __>>> romF' 1 2__ --- -3.5 --- __>>> romF' 0 0__ --- 1.19921875 --- @ -fLitR :: forall rep int frac size . - ( size ~ (int + frac), KnownNat frac, Bounded (rep size) - , Integral (rep size)) - => Double - -> Fixed rep int frac -fLitR a = Fixed (fromInteger sat) - where - rMax = toInteger (maxBound :: rep size) - rMin = toInteger (minBound :: rep size) - sat = if truncated > rMax - then rMax - else if truncated < rMin - then rMin - else truncated - truncated = truncate shifted :: Integer - shifted = a * (2 ^ (natVal (Proxy @frac))) - -instance NumFixedC rep int frac => SaturatingNum (Fixed rep int frac) where - satPlus w (Fixed a) (Fixed b) = Fixed (satPlus w a b) - satMin w (Fixed a) (Fixed b) = Fixed (satMin w a b) - - satMult SatWrap (Fixed a) (Fixed b) = - let res = a `times` b - sh = fromInteger (natVal (Proxy @frac)) - res' = shiftR res sh - in Fixed (resize res') - - satMult SatBound (Fixed a) (Fixed b) = - let res = a `times` b - sh = fromInteger (natVal (Proxy @frac)) - (rL,rR) = split res :: (BitVector int, BitVector (int + frac + frac)) - in case isSigned a of - True -> let overflow = complement (reduceOr (msb rR ++# pack rL)) .|. - reduceAnd (msb rR ++# pack rL) - in case overflow of - 1 -> unpack (resize (shiftR rR sh)) - _ -> case msb rL of - 0 -> maxBound - _ -> minBound - False -> case rL of - 0 -> unpack (resize (shiftR rR sh)) - _ -> maxBound - - satMult SatZero (Fixed a) (Fixed b) = - let res = a `times` b - sh = fromInteger (natVal (Proxy @frac)) - (rL,rR) = split res :: (BitVector int, BitVector (int + frac + frac)) - in case isSigned a of - True -> let overflow = complement (reduceOr (msb rR ++# pack rL)) .|. - reduceAnd (msb rR ++# pack rL) - in case overflow of - 1 -> unpack (resize (shiftR rR sh)) - _ -> 0 - False -> case rL of - 0 -> unpack (resize (shiftR rR sh)) - _ -> 0 - - satMult SatSymmetric (Fixed a) (Fixed b) = - let res = a `times` b - sh = fromInteger (natVal (Proxy @frac)) - (rL,rR) = split res :: (BitVector int, BitVector (int + frac + frac)) - in case isSigned a of - True -> let overflow = complement (reduceOr (msb rR ++# pack rL)) .|. - reduceAnd (msb rR ++# pack rL) - in case overflow of - 1 -> unpack (resize (shiftR rR sh)) - _ -> case msb rL of - 0 -> maxBound - _ -> succ minBound - False -> case rL of - 0 -> unpack (resize (shiftR rR sh)) - _ -> maxBound - --- | Constraint for the 'divide' function -type DivideC rep int1 frac1 int2 frac2 - = ( Resize rep - , Integral (rep (((int1 + frac2) + 1) + (int2 + frac1))) - , Bits (rep (((int1 + frac2) + 1) + (int2 + frac1))) - , KnownNat int1 - , KnownNat frac1 - , KnownNat int2 - , KnownNat frac2 - ) - --- | Constraint for the 'divide' function, specialized for 'SFixed' -type DivideSC int1 frac1 int2 frac2 - = ( KnownNat (((int1 + frac2) + 1) + (int2 + frac1)) - , KnownNat frac2 - , KnownNat int2 - , KnownNat frac1 - , KnownNat int1 - ) - --- | Constraint for the 'divide' function, specialized for 'UFixed' -type DivideUC int1 frac1 int2 frac2 = - DivideSC int1 frac1 int2 frac2 - --- | Fixed point division --- --- When used in a polymorphic setting, use the following --- <#constraintsynonyms Constraint synonyms> for less verbose type signatures: --- --- * @'DivideC' rep int1 frac1 int2 frac2@ for: --- @'Fixed' rep int1 frac1 -> 'Fixed' rep int2 frac2 -> 'Fixed' rep (int1 + frac2 + 1) (int2 + frac1)@ --- --- * @'DivideSC' rep int1 frac1 int2 frac2@ for: --- @'SFixed' int1 frac1 -> 'SFixed' int2 frac2 -> 'SFixed' (int1 + frac2 + 1) (int2 + frac1)@ --- --- * @'DivideUC' rep int1 frac1 int2 frac2@ for: --- @'UFixed' int1 frac1 -> 'UFixed' int2 frac2 -> 'UFixed' (int1 + frac2 + 1) (int2 + frac1)@ -divide :: DivideC rep int1 frac1 int2 frac2 - => Fixed rep int1 frac1 - -> Fixed rep int2 frac2 - -> Fixed rep (int1 + frac2 + 1) (int2 + frac1) -divide (Fixed fr1) fx2@(Fixed fr2) = - let int2 = fromInteger (natVal (asIntProxy fx2)) - frac2 = fromInteger (natVal fx2) - fr1' = resize fr1 - fr2' = resize fr2 - fr1SH = shiftL fr1' ((int2 + frac2)) - res = fr1SH `quot` fr2' - in Fixed res - --- | Constraint for the 'Fractional' instance of 'Fixed' -type FracFixedC rep int frac - = ( NumFixedC rep int frac - , DivideC rep int frac int frac - , Integral (rep (int + frac)) - , KnownNat int - , KnownNat frac - ) - --- | Constraint for the 'Fractional' instance of 'SFixed' -type FracSFixedC int frac - = ( NumSFixedC int frac - , KnownNat ((int + frac + 1) + (int + frac)) - ) - --- | Constraint for the 'Fractional' instance of 'UFixed' -type FracUFixedC int frac - = FracSFixedC int frac - --- | The operators of this instance saturate on overflow, and use truncation as --- the rounding method. --- --- When used in a polymorphic setting, use the following --- for less --- verbose type signatures: --- --- * @'FracFixedC' frac rep size@ for: @'Fixed' frac rep size@ --- * @'FracSFixedC' int frac@ for: @'SFixed' int frac@ --- * @'FracUFixedC' int frac@ for: @'UFixed' int frac@ -instance FracFixedC rep int frac => Fractional (Fixed rep int frac) where - f1 / f2 = resizeF (divide f1 f2) - recip fx = resizeF (divide (1 :: Fixed rep int frac) fx) - fromRational r = res - where - res = Fixed (fromInteger sat) - sat = if res' > rMax - then rMax - else if res' < rMin then rMin else res' - - rMax = toInteger (maxBound :: rep (int + frac)) - rMin = toInteger (minBound :: rep (int + frac)) - res' = n `div` d - - frac = fromInteger (natVal res) - n = numerator r `shiftL` (2 * frac) - d = denominator r `shiftL` frac - -instance (NumFixedC rep int frac, Integral (rep (int + frac))) => - Real (Fixed rep int frac) where - toRational f@(Fixed fRep) = nom % denom - where - nF = fracShift f - denom = 1 `shiftL` nF - nom = toInteger fRep diff --git a/src/CLaSH/Sized/Index.hs b/src/CLaSH/Sized/Index.hs deleted file mode 100644 --- a/src/CLaSH/Sized/Index.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-| -Copyright : (C) 2013-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij --} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TypeOperators #-} - -{-# LANGUAGE Trustworthy #-} - -{-# OPTIONS_GHC -fplugin GHC.TypeLits.Extra.Solver -fplugin GHC.TypeLits.KnownNat.Solver #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Sized.Index - (Index, bv2i) -where - -import GHC.TypeLits (KnownNat, type (^)) -import GHC.TypeLits.Extra (CLog) -- documentation only - -import CLaSH.Promoted.Nat (SNat (..), pow2SNat) -import CLaSH.Sized.BitVector (BitVector) -import CLaSH.Sized.Internal.Index - --- | An alternative implementation of 'CLaSH.Class.BitPack.unpack' for the --- 'Index' data type; for when you know the size of the 'BitVector' and want --- to determine the size of the 'Index'. --- --- That is, the type of 'CLaSH.Class.BitPack.unpack' is: --- --- @ --- __unpack__ :: 'BitVector' ('CLog' 2 n) -> 'Index' n --- @ --- --- And is useful when you know the size of the 'Index', and want to get a value --- from a 'BitVector' that is large enough (@CLog 2 n@) enough to hold an --- 'Index'. Note that 'CLaSH.Class.BitPack.unpack' can fail at /run-time/ when --- the value inside the 'BitVector' is higher than 'n-1'. --- --- 'bv2i' on the other hand will /never/ fail at run-time, because the --- 'BitVector' argument determines the size. -bv2i :: KnownNat n => BitVector n -> Index (2^n) -bv2i = unpack# diff --git a/src/CLaSH/Sized/Internal/BitVector.hs b/src/CLaSH/Sized/Internal/BitVector.hs deleted file mode 100644 --- a/src/CLaSH/Sized/Internal/BitVector.hs +++ /dev/null @@ -1,650 +0,0 @@ -{-| -Copyright : (C) 2013-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij --} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# LANGUAGE Unsafe #-} - -{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Sized.Internal.BitVector - ( -- * Datatypes - BitVector (..) - , Bit - -- * Accessors - -- ** Length information - , size# - , maxIndex# - -- * Construction - -- ** Initialisation - , high - , low - , bLit - -- ** Concatenation - , (++#) - -- * Reduction - , reduceAnd# - , reduceOr# - , reduceXor# - -- * Indexing - , index# - , replaceBit# - , setSlice# - , slice# - , split# - , msb# - , lsb# - -- * Type classes - -- ** Eq - , eq# - , neq# - -- ** Ord - , lt# - , ge# - , gt# - , le# - -- ** Enum (not synthesisable) - , enumFrom# - , enumFromThen# - , enumFromTo# - , enumFromThenTo# - -- ** Bounded - , minBound# - , maxBound# - -- ** Num - , (+#) - , (-#) - , (*#) - , negate# - , fromInteger# - -- ** ExtendingNum - , plus# - , minus# - , times# - -- ** Integral - , quot# - , rem# - , toInteger# - -- ** Bits - , and# - , or# - , xor# - , complement# - , shiftL# - , shiftR# - , rotateL# - , rotateR# - , popCountBV - -- ** FiniteBits - , countLeadingZerosBV - , countTrailingZerosBV - -- ** Resize - , resize# - -- ** QuickCheck - , shrinkSizedUnsigned - ) -where - -import Control.DeepSeq (NFData (..)) -import Control.Lens (Index, Ixed (..), IxValue) -import Data.Bits (Bits (..), FiniteBits (..)) -import Data.Char (digitToInt) -import Data.Data (Data) -import Data.Default (Default (..)) -import Data.Maybe (listToMaybe) -import Data.Proxy (Proxy (..)) -import GHC.Integer (smallInteger) -import GHC.Prim (dataToTag#) -import GHC.TypeLits (KnownNat, Nat, type (+), type (-), natVal) -import GHC.TypeLits.Extra (Max) -import Language.Haskell.TH (Q, TExp, TypeQ, appT, conT, litT, numTyLit, sigE) -import Language.Haskell.TH.Syntax (Lift(..)) -import Numeric (readInt) -import Test.QuickCheck.Arbitrary (Arbitrary (..), CoArbitrary (..), - arbitraryBoundedIntegral, - coarbitraryIntegral, shrinkIntegral) - -import CLaSH.Class.Num (ExtendingNum (..), SaturatingNum (..), - SaturationMode (..)) -import CLaSH.Class.Resize (Resize (..)) -import CLaSH.Promoted.Nat (SNat, snatToInteger, snatToNum) -import CLaSH.XException (ShowX (..), showsPrecXWith) - -import {-# SOURCE #-} qualified CLaSH.Sized.Vector as V -import {-# SOURCE #-} qualified CLaSH.Sized.Internal.Index as I - -{- $setup ->>> :set -XTemplateHaskell ->>> :set -XBinaryLiterals --} - --- * Type definitions - --- | A vector of bits. --- --- * Bit indices are descending --- * 'Num' instance performs /unsigned/ arithmetic. -newtype BitVector (n :: Nat) = - -- | The constructor, 'BV', and the field, 'unsafeToInteger', are not - -- synthesisable. - BV { unsafeToInteger :: Integer} - deriving (Data) - --- | 'Bit': a 'BitVector' of length 1 -type Bit = BitVector 1 - --- * Instances -instance NFData (BitVector n) where - rnf (BV i) = rnf i `seq` () - {-# NOINLINE rnf #-} - -- NOINLINE is needed so that CLaSH doesn't trip on the "BitVector ~# Integer" - -- coercion - -instance KnownNat n => Show (BitVector n) where - show bv@(BV i) = reverse . underScore . reverse $ showBV (natVal bv) i [] - where - showBV 0 _ s = s - showBV n v s = let (a,b) = divMod v 2 - in case b of - 1 -> showBV (n - 1) a ('1':s) - _ -> showBV (n - 1) a ('0':s) - - underScore xs = case splitAt 5 xs of - ([a,b,c,d,e],rest) -> [a,b,c,d,'_'] ++ underScore (e:rest) - (rest,_) -> rest - {-# NOINLINE show #-} - -instance KnownNat n => ShowX (BitVector n) where - showsPrecX = showsPrecXWith showsPrec - --- | Create a binary literal --- --- >>> $$(bLit "1001") :: BitVector 4 --- 1001 --- >>> $$(bLit "1001") :: BitVector 3 --- 001 --- --- __NB__: You can also just write: --- --- >>> 0b1001 :: BitVector 4 --- 1001 --- --- The advantage of 'bLit' is that you can use computations to create the --- string literal: --- --- >>> import qualified Data.List as List --- >>> $$(bLit (List.replicate 4 '1')) :: BitVector 4 --- 1111 -bLit :: KnownNat n => String -> Q (TExp (BitVector n)) -bLit s = [|| fromInteger# i' ||] - where - i :: Maybe Integer - i = fmap fst . listToMaybe . (readInt 2 (`elem` "01") digitToInt) $ filter (/= '_') s - - i' :: Integer - i' = case i of - Just j -> j - _ -> error "Failed to parse: " s - -instance Eq (BitVector n) where - (==) = eq# - (/=) = neq# - -{-# NOINLINE eq# #-} -eq# :: BitVector n -> BitVector n -> Bool -eq# (BV v1) (BV v2) = v1 == v2 - -{-# NOINLINE neq# #-} -neq# :: BitVector n -> BitVector n -> Bool -neq# (BV v1) (BV v2) = v1 /= v2 - -instance Ord (BitVector n) where - (<) = lt# - (>=) = ge# - (>) = gt# - (<=) = le# - -lt#,ge#,gt#,le# :: BitVector n -> BitVector n -> Bool -{-# NOINLINE lt# #-} -lt# (BV n) (BV m) = n < m -{-# NOINLINE ge# #-} -ge# (BV n) (BV m) = n >= m -{-# NOINLINE gt# #-} -gt# (BV n) (BV m) = n > m -{-# NOINLINE le# #-} -le# (BV n) (BV m) = n <= m - --- | The functions: 'enumFrom', 'enumFromThen', 'enumFromTo', and --- 'enumFromThenTo', are not synthesisable. -instance KnownNat n => Enum (BitVector n) where - succ = (+# fromInteger# 1) - pred = (-# fromInteger# 1) - toEnum = fromInteger# . toInteger - fromEnum = fromEnum . toInteger# - enumFrom = enumFrom# - enumFromThen = enumFromThen# - enumFromTo = enumFromTo# - enumFromThenTo = enumFromThenTo# - -{-# NOINLINE enumFrom# #-} -{-# NOINLINE enumFromThen# #-} -{-# NOINLINE enumFromTo# #-} -{-# NOINLINE enumFromThenTo# #-} -enumFrom# :: KnownNat n => BitVector n -> [BitVector n] -enumFromThen# :: KnownNat n => BitVector n -> BitVector n -> [BitVector n] -enumFromTo# :: BitVector n -> BitVector n -> [BitVector n] -enumFromThenTo# :: BitVector n -> BitVector n -> BitVector n -> [BitVector n] -enumFrom# x = map fromInteger_INLINE [unsafeToInteger x ..] -enumFromThen# x y = map fromInteger_INLINE [unsafeToInteger x, unsafeToInteger y ..] -enumFromTo# x y = map BV [unsafeToInteger x .. unsafeToInteger y] -enumFromThenTo# x1 x2 y = map BV [unsafeToInteger x1, unsafeToInteger x2 .. unsafeToInteger y] - -instance KnownNat n => Bounded (BitVector n) where - minBound = minBound# - maxBound = maxBound# - -{-# NOINLINE minBound# #-} -minBound# :: BitVector n -minBound# = BV 0 - -{-# NOINLINE maxBound# #-} -maxBound# :: forall n . KnownNat n => BitVector n -maxBound# = let m = 1 `shiftL` fromInteger (natVal (Proxy @n)) - in BV (m-1) - -instance KnownNat n => Num (BitVector n) where - (+) = (+#) - (-) = (-#) - (*) = (*#) - negate = negate# - abs = id - signum bv = resize# (reduceOr# bv) - fromInteger = fromInteger# - -(+#),(-#),(*#) :: forall n . KnownNat n => BitVector n -> BitVector n -> BitVector n -{-# NOINLINE (+#) #-} -(+#) (BV i) (BV j) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n)) - z = i + j - in if z >= m then BV (z - m) else BV z - -{-# NOINLINE (-#) #-} -(-#) (BV i) (BV j) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n)) - z = i - j - in if z < 0 then BV (m + z) else BV z - -{-# NOINLINE (*#) #-} -(*#) (BV i) (BV j) = fromInteger_INLINE (i * j) - -{-# NOINLINE negate# #-} -negate# :: forall n . KnownNat n => BitVector n -> BitVector n -negate# (BV 0) = BV 0 -negate# (BV i) = BV (sz - i) - where - sz = 1 `shiftL` fromInteger (natVal (Proxy @n)) - -{-# NOINLINE fromInteger# #-} -fromInteger# :: KnownNat n => Integer -> BitVector n -fromInteger# = fromInteger_INLINE - -{-# INLINE fromInteger_INLINE #-} -fromInteger_INLINE :: forall n . KnownNat n => Integer -> BitVector n -fromInteger_INLINE i = sz `seq` BV (i `mod` sz) - where - sz = 1 `shiftL` fromInteger (natVal (Proxy @n)) - -instance (KnownNat m, KnownNat n) => ExtendingNum (BitVector m) (BitVector n) where - type AResult (BitVector m) (BitVector n) = BitVector (Max m n + 1) - plus = plus# - minus = minus# - type MResult (BitVector m) (BitVector n) = BitVector (m + n) - times = times# - -{-# NOINLINE plus# #-} -plus# :: BitVector m -> BitVector n -> BitVector (Max m n + 1) -plus# (BV a) (BV b) = BV (a + b) - -{-# NOINLINE minus# #-} -minus# :: forall m n . (KnownNat m, KnownNat n) => BitVector m -> BitVector n - -> BitVector (Max m n + 1) -minus# (BV a) (BV b) = - let sz = fromInteger (natVal (Proxy @(Max m n + 1))) - mask = 1 `shiftL` sz - z = a - b - in if z < 0 then BV (mask + z) else BV z - -{-# NOINLINE times# #-} -times# :: BitVector m -> BitVector n -> BitVector (m + n) -times# (BV a) (BV b) = BV (a * b) - -instance KnownNat n => Real (BitVector n) where - toRational = toRational . toInteger# - -instance KnownNat n => Integral (BitVector n) where - quot = quot# - rem = rem# - div = quot# - mod = rem# - quotRem n d = (n `quot#` d,n `rem#` d) - divMod n d = (n `quot#` d,n `rem#` d) - toInteger = toInteger# - -quot#,rem# :: BitVector n -> BitVector n -> BitVector n -{-# NOINLINE quot# #-} -quot# (BV i) (BV j) = BV (i `quot` j) -{-# NOINLINE rem# #-} -rem# (BV i) (BV j) = BV (i `rem` j) - -{-# NOINLINE toInteger# #-} -toInteger# :: BitVector n -> Integer -toInteger# (BV i) = i - -instance KnownNat n => Bits (BitVector n) where - (.&.) = and# - (.|.) = or# - xor = xor# - complement = complement# - zeroBits = 0 - bit i = replaceBit# 0 i high - setBit v i = replaceBit# v i high - clearBit v i = replaceBit# v i low - complementBit v i = replaceBit# v i (complement# (index# v i)) - testBit v i = eq# (index# v i) high - bitSizeMaybe v = Just (size# v) - bitSize = size# - isSigned _ = False - shiftL v i = shiftL# v i - shiftR v i = shiftR# v i - rotateL v i = rotateL# v i - rotateR v i = rotateR# v i - popCount bv = fromInteger (I.toInteger# (popCountBV (bv ++# (0 :: Bit)))) - -instance KnownNat n => FiniteBits (BitVector n) where - finiteBitSize = size# - countLeadingZeros = fromInteger . I.toInteger# . countLeadingZerosBV - countTrailingZeros = fromInteger . I.toInteger# . countTrailingZerosBV - -countLeadingZerosBV :: KnownNat n => BitVector n -> I.Index (n+1) -countLeadingZerosBV = V.foldr (\l r -> if eq# l low then 1 + r else 0) 0 . V.bv2v -{-# INLINE countLeadingZerosBV #-} - -countTrailingZerosBV :: KnownNat n => BitVector n -> I.Index (n+1) -countTrailingZerosBV = V.foldl (\l r -> if eq# r low then 1 + l else 0) 0 . V.bv2v -{-# INLINE countTrailingZerosBV #-} - -{-# NOINLINE reduceAnd# #-} -reduceAnd# :: KnownNat n => BitVector n -> BitVector 1 -reduceAnd# bv@(BV i) = BV (smallInteger (dataToTag# check)) - where - check = i == maxI - - sz = natVal bv - maxI = (2 ^ sz) - 1 - -{-# NOINLINE reduceOr# #-} -reduceOr# :: BitVector n -> BitVector 1 -reduceOr# (BV i) = BV (smallInteger (dataToTag# check)) - where - check = i /= 0 - -{-# NOINLINE reduceXor# #-} -reduceXor# :: BitVector n -> BitVector 1 -reduceXor# (BV i) = BV (toInteger (popCount i `mod` 2)) - -instance Default (BitVector n) where - def = minBound# - --- * Accessors --- ** Length information -{-# NOINLINE size# #-} -size# :: KnownNat n => BitVector n -> Int -size# bv = fromInteger (natVal bv) - -{-# NOINLINE maxIndex# #-} -maxIndex# :: KnownNat n => BitVector n -> Int -maxIndex# bv = fromInteger (natVal bv) - 1 - --- ** Indexing -{-# NOINLINE index# #-} -index# :: KnownNat n => BitVector n -> Int -> Bit -index# bv@(BV v) i - | i >= 0 && i < sz = BV (smallInteger - (dataToTag# - (testBit v i))) - | otherwise = err - where - sz = fromInteger (natVal bv) - err = error $ concat [ "(!): " - , show i - , " is out of range [" - , show (sz - 1) - , "..0]" - ] - -{-# NOINLINE msb# #-} --- | MSB -msb# :: forall n . KnownNat n => BitVector n -> Bit -msb# (BV v) - = let i = fromInteger (natVal (Proxy @n) - 1) - in BV (smallInteger (dataToTag# (testBit v i))) - -{-# NOINLINE lsb# #-} --- | LSB -lsb# :: BitVector n -> Bit -lsb# (BV v) = BV (smallInteger (dataToTag# (testBit v 0))) - -{-# NOINLINE slice# #-} -slice# :: BitVector (m + 1 + i) -> SNat m -> SNat n -> BitVector (m + 1 - n) -slice# (BV i) m n = BV (shiftR (i .&. mask) n') - where - m' = snatToInteger m - n' = snatToNum n - - mask = 2 ^ (m' + 1) - 1 - --- * Constructions --- ** Initialisation -{-# NOINLINE high #-} --- | logic '1' -high :: Bit -high = BV 1 - -{-# NOINLINE low #-} --- | logic '0' -low :: Bit -low = BV 0 - --- ** Concatenation -{-# NOINLINE (++#) #-} --- | Concatenate two 'BitVector's -(++#) :: KnownNat m => BitVector n -> BitVector m -> BitVector (n + m) -(BV v1) ++# bv2@(BV v2) = BV (v1' + v2) - where - v1' = shiftL v1 (fromInteger (natVal bv2)) - --- * Modifying BitVectors -{-# NOINLINE replaceBit# #-} -replaceBit# :: KnownNat n => BitVector n -> Int -> Bit -> BitVector n -replaceBit# bv@(BV v) i (BV b) - | i >= 0 && i < sz = BV (if b == 1 then setBit v i else clearBit v i) - | otherwise = err - where - sz = fromInteger (natVal bv) - err = error $ concat [ "replaceBit: " - , show i - , " is out of range [" - , show (sz - 1) - , "..0]" - ] - -{-# NOINLINE setSlice# #-} -setSlice# :: BitVector (m + 1 + i) -> SNat m -> SNat n -> BitVector (m + 1 - n) - -> BitVector (m + 1 + i) -setSlice# (BV i) m n (BV j) = BV ((i .&. mask) .|. j') - where - m' = snatToInteger m - n' = snatToInteger n - - j' = shiftL j (fromInteger n') - mask = complement ((2 ^ (m' + 1) - 1) `xor` (2 ^ n' - 1)) - -{-# NOINLINE split# #-} -split# :: forall n m . KnownNat n - => BitVector (m + n) -> (BitVector m, BitVector n) -split# (BV i) = (BV l, BV r) - where - n = fromInteger (natVal (Proxy @n)) - mask = 1 `shiftL` n - -- The code below is faster than: - -- > (l,r) = i `divMod` mask - r = i `mod` mask - l = i `shiftR` n - -and#, or#, xor# :: BitVector n -> BitVector n -> BitVector n -{-# NOINLINE and# #-} -and# (BV v1) (BV v2) = BV (v1 .&. v2) - -{-# NOINLINE or# #-} -or# (BV v1) (BV v2) = BV (v1 .|. v2) - -{-# NOINLINE xor# #-} -xor# (BV v1) (BV v2) = BV (v1 `xor` v2) - -{-# NOINLINE complement# #-} -complement# :: KnownNat n => BitVector n -> BitVector n -complement# (BV v1) = fromInteger_INLINE (complement v1) - -shiftL#, rotateL#, rotateR# :: KnownNat n - => BitVector n -> Int -> BitVector n - -{-# NOINLINE shiftL# #-} -shiftL# (BV v) i - | i < 0 = error - $ "'shiftL undefined for negative number: " ++ show i - | otherwise = fromInteger_INLINE (shiftL v i) - -{-# NOINLINE shiftR# #-} -shiftR# :: BitVector n -> Int -> BitVector n -shiftR# (BV v) i - | i < 0 = error - $ "'shiftR undefined for negative number: " ++ show i - | otherwise = BV (shiftR v i) - -{-# NOINLINE rotateL# #-} -rotateL# _ b | b < 0 = error "'shiftL undefined for negative numbers" -rotateL# bv@(BV n) b = fromInteger_INLINE (l .|. r) - where - l = shiftL n b' - r = shiftR n b'' - - b' = b `mod` sz - b'' = sz - b' - sz = fromInteger (natVal bv) - -{-# NOINLINE rotateR# #-} -rotateR# _ b | b < 0 = error "'shiftR undefined for negative numbers" -rotateR# bv@(BV n) b = fromInteger_INLINE (l .|. r) - where - l = shiftR n b' - r = shiftL n b'' - - b' = b `mod` sz - b'' = sz - b' - sz = fromInteger (natVal bv) - -popCountBV :: forall n . KnownNat n => BitVector (n+1) -> I.Index (n+2) -popCountBV bv = - let v = V.bv2v bv - in sum (V.map fromIntegral v) -{-# INLINE popCountBV #-} - -instance Resize BitVector where - resize = resize# - zeroExtend = extend - signExtend = \ bv -> (case msb# bv of 0 -> id - 1 -> complement) 0 ++# bv - truncateB = resize# - -{-# NOINLINE resize# #-} -resize# :: forall n m . KnownNat m => BitVector n -> BitVector m -resize# (BV i) = let m = 1 `shiftL` fromInteger (natVal (Proxy @m)) - in if i >= m then fromInteger_INLINE i else BV i - -instance KnownNat n => Lift (BitVector n) where - lift bv@(BV i) = sigE [| fromInteger# i |] (decBitVector (natVal bv)) - {-# NOINLINE lift #-} - -decBitVector :: Integer -> TypeQ -decBitVector n = appT (conT ''BitVector) (litT $ numTyLit n) - -instance KnownNat n => SaturatingNum (BitVector n) where - satPlus SatWrap a b = a +# b - satPlus SatZero a b = - let r = plus# a b - in case msb# r of - 0 -> resize# r - _ -> minBound# - satPlus _ a b = - let r = plus# a b - in case msb# r of - 0 -> resize# r - _ -> maxBound# - - satMin SatWrap a b = a -# b - satMin _ a b = - let r = minus# a b - in case msb# r of - 0 -> resize# r - _ -> minBound# - - satMult SatWrap a b = a *# b - satMult SatZero a b = - let r = times# a b - (rL,rR) = split# r - in case rL of - 0 -> rR - _ -> minBound# - satMult _ a b = - let r = times# a b - (rL,rR) = split# r - in case rL of - 0 -> rR - _ -> maxBound# - -instance KnownNat n => Arbitrary (BitVector n) where - arbitrary = arbitraryBoundedIntegral - shrink = shrinkSizedUnsigned - --- | 'shrink' for sized unsigned types -shrinkSizedUnsigned :: (KnownNat n, Integral (p n)) => p n -> [p n] -shrinkSizedUnsigned x | natVal x < 2 = case toInteger x of - 1 -> [0] - _ -> [] - -- 'shrinkIntegral' uses "`quot` 2", which for sized types - -- less than 2 bits wide results in a division by zero. - -- - -- See: https://github.com/clash-lang/clash-compiler/issues/153 - | otherwise = shrinkIntegral x -{-# INLINE shrinkSizedUnsigned #-} - -instance KnownNat n => CoArbitrary (BitVector n) where - coarbitrary = coarbitraryIntegral - -type instance Index (BitVector n) = Int -type instance IxValue (BitVector n) = Bit -instance KnownNat n => Ixed (BitVector n) where - ix i f bv = replaceBit# bv i <$> f (index# bv i) diff --git a/src/CLaSH/Sized/Internal/BitVector.hs-boot b/src/CLaSH/Sized/Internal/BitVector.hs-boot deleted file mode 100644 --- a/src/CLaSH/Sized/Internal/BitVector.hs-boot +++ /dev/null @@ -1,16 +0,0 @@ -{-| -Copyright : (C) 2015-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij --} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RoleAnnotations #-} -module CLaSH.Sized.Internal.BitVector where - -import GHC.TypeLits (Nat) - -type role BitVector phantom -data BitVector :: Nat -> * -type Bit = BitVector 1 diff --git a/src/CLaSH/Sized/Internal/Index.hs b/src/CLaSH/Sized/Internal/Index.hs deleted file mode 100644 --- a/src/CLaSH/Sized/Internal/Index.hs +++ /dev/null @@ -1,357 +0,0 @@ -{-| -Copyright : (C) 2013-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij --} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# LANGUAGE Unsafe #-} - -{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Sized.Internal.Index - ( -- * Datatypes - Index (..) - -- * Construction - , fromSNat - -- * Type classes - -- ** BitConvert - , pack# - , unpack# - -- ** Eq - , eq# - , neq# - -- ** Ord - , lt# - , ge# - , gt# - , le# - -- ** Enum (not synthesisable) - , enumFrom# - , enumFromThen# - , enumFromTo# - , enumFromThenTo# - -- ** Bounded - , maxBound# - -- ** Num - , (+#) - , (-#) - , (*#) - , fromInteger# - -- ** ExtendingNum - , plus# - , minus# - , times# - -- ** Integral - , quot# - , rem# - , toInteger# - -- ** Resize - , resize# - ) -where - -import Control.DeepSeq (NFData (..)) -import Data.Data (Data) -import Data.Default (Default (..)) -import Data.Proxy (Proxy (..)) -import Text.Read (Read (..), ReadPrec) -import Language.Haskell.TH (TypeQ, appT, conT, litT, numTyLit, sigE) -import Language.Haskell.TH.Syntax (Lift(..)) -import GHC.TypeLits (CmpNat, KnownNat, Nat, type (+), type (-), - type (*), type (<=), type (^), natVal) -import GHC.TypeLits.Extra (CLog) -import Test.QuickCheck.Arbitrary (Arbitrary (..), CoArbitrary (..), - arbitraryBoundedIntegral, - coarbitraryIntegral, shrinkIntegral) - -import CLaSH.Class.BitPack (BitPack (..)) -import CLaSH.Class.Num (ExtendingNum (..), SaturatingNum (..), - SaturationMode (..)) -import CLaSH.Class.Resize (Resize (..)) -import {-# SOURCE #-} CLaSH.Sized.Internal.BitVector (BitVector (BV)) -import CLaSH.Promoted.Nat (SNat, snatToNum) -import CLaSH.XException (ShowX (..), showsPrecXWith) - --- | Arbitrary-bounded unsigned integer represented by @ceil(log_2(n))@ bits. --- --- Given an upper bound @n@, an 'Index' @n@ number has a range of: [0 .. @n@-1] --- --- >>> maxBound :: Index 8 --- 7 --- >>> minBound :: Index 8 --- 0 --- >>> read (show (maxBound :: Index 8)) :: Index 8 --- 7 --- >>> 1 + 2 :: Index 8 --- 3 --- >>> 2 + 6 :: Index 8 --- *** Exception: CLaSH.Sized.Index: result 8 is out of bounds: [0..7] --- ... --- >>> 1 - 3 :: Index 8 --- *** Exception: CLaSH.Sized.Index: result -2 is out of bounds: [0..7] --- ... --- >>> 2 * 3 :: Index 8 --- 6 --- >>> 2 * 4 :: Index 8 --- *** Exception: CLaSH.Sized.Index: result 8 is out of bounds: [0..7] --- ... -newtype Index (n :: Nat) = - -- | The constructor, 'I', and the field, 'unsafeToInteger', are not - -- synthesisable. - I { unsafeToInteger :: Integer } - deriving Data - -instance NFData (Index n) where - rnf (I i) = rnf i `seq` () - {-# NOINLINE rnf #-} - -- NOINLINE is needed so that CLaSH doesn't trip on the "Index ~# Integer" - -- coercion - -instance KnownNat n => BitPack (Index n) where - type BitSize (Index n) = CLog 2 n - pack = pack# - unpack = unpack# - --- | Safely convert an `SNat` value to an `Index` -fromSNat :: (KnownNat m, CmpNat n m ~ 'LT) => SNat n -> Index m -fromSNat = snatToNum - -{-# NOINLINE pack# #-} -pack# :: Index n -> BitVector (CLog 2 n) -pack# (I i) = BV i - -{-# NOINLINE unpack# #-} -unpack# :: KnownNat n => BitVector (CLog 2 n) -> Index n -unpack# (BV i) = fromInteger_INLINE i - -instance Eq (Index n) where - (==) = eq# - (/=) = neq# - -{-# NOINLINE eq# #-} -eq# :: (Index n) -> (Index n) -> Bool -(I n) `eq#` (I m) = n == m - -{-# NOINLINE neq# #-} -neq# :: (Index n) -> (Index n) -> Bool -(I n) `neq#` (I m) = n /= m - -instance Ord (Index n) where - (<) = lt# - (>=) = ge# - (>) = gt# - (<=) = le# - -lt#,ge#,gt#,le# :: Index n -> Index n -> Bool -{-# NOINLINE lt# #-} -lt# (I n) (I m) = n < m -{-# NOINLINE ge# #-} -ge# (I n) (I m) = n >= m -{-# NOINLINE gt# #-} -gt# (I n) (I m) = n > m -{-# NOINLINE le# #-} -le# (I n) (I m) = n <= m - --- | The functions: 'enumFrom', 'enumFromThen', 'enumFromTo', and --- 'enumFromThenTo', are not synthesisable. -instance KnownNat n => Enum (Index n) where - succ = (+# fromInteger# 1) - pred = (-# fromInteger# 1) - toEnum = fromInteger# . toInteger - fromEnum = fromEnum . toInteger# - enumFrom = enumFrom# - enumFromThen = enumFromThen# - enumFromTo = enumFromTo# - enumFromThenTo = enumFromThenTo# - -{-# NOINLINE enumFrom# #-} -{-# NOINLINE enumFromThen# #-} -{-# NOINLINE enumFromTo# #-} -{-# NOINLINE enumFromThenTo# #-} -enumFrom# :: KnownNat n => Index n -> [Index n] -enumFromThen# :: KnownNat n => Index n -> Index n -> [Index n] -enumFromTo# :: Index n -> Index n -> [Index n] -enumFromThenTo# :: Index n -> Index n -> Index n -> [Index n] -enumFrom# x = map fromInteger_INLINE [unsafeToInteger x ..] -enumFromThen# x y = map fromInteger_INLINE [unsafeToInteger x, unsafeToInteger y ..] -enumFromTo# x y = map I [unsafeToInteger x .. unsafeToInteger y] -enumFromThenTo# x1 x2 y = map I [unsafeToInteger x1, unsafeToInteger x2 .. unsafeToInteger y] - -instance KnownNat n => Bounded (Index n) where - minBound = fromInteger# 0 - maxBound = maxBound# - -{-# NOINLINE maxBound# #-} -maxBound# :: KnownNat n => Index n -maxBound# = let res = I (natVal res - 1) in res - --- | Operators report an error on overflow and underflow -instance KnownNat n => Num (Index n) where - (+) = (+#) - (-) = (-#) - (*) = (*#) - negate = (maxBound# -#) - abs = id - signum i = if i == 0 then 0 else 1 - fromInteger = fromInteger# - -(+#),(-#),(*#) :: KnownNat n => Index n -> Index n -> Index n -{-# NOINLINE (+#) #-} -(+#) (I a) (I b) = fromInteger_INLINE $ a + b - -{-# NOINLINE (-#) #-} -(-#) (I a) (I b) = fromInteger_INLINE $ a - b - -{-# NOINLINE (*#) #-} -(*#) (I a) (I b) = fromInteger_INLINE $ a * b - -fromInteger# :: KnownNat n => Integer -> Index n -{-# NOINLINE fromInteger# #-} -fromInteger# = fromInteger_INLINE -{-# INLINE fromInteger_INLINE #-} -fromInteger_INLINE :: forall n . KnownNat n => Integer -> Index n -fromInteger_INLINE i = bound `seq` if i > (-1) && i < bound then I i else err - where - bound = natVal (Proxy @n) - err = error ("CLaSH.Sized.Index: result " ++ show i ++ - " is out of bounds: [0.." ++ show (bound - 1) ++ "]") - -instance ExtendingNum (Index m) (Index n) where - type AResult (Index m) (Index n) = Index (m + n - 1) - plus = plus# - minus = minus# - type MResult (Index m) (Index n) = Index (((m - 1) * (n - 1)) + 1) - times = times# - -plus#, minus# :: Index m -> Index n -> Index (m + n - 1) -{-# NOINLINE plus# #-} -plus# (I a) (I b) = I (a + b) - -{-# NOINLINE minus# #-} -minus# (I a) (I b) = - let z = a - b - err = error ("CLaSH.Sized.Index.minus: result " ++ show z ++ - " is smaller than 0") - res = if z < 0 then err else I z - in res - -{-# NOINLINE times# #-} -times# :: Index m -> Index n -> Index (((m - 1) * (n - 1)) + 1) -times# (I a) (I b) = I (a * b) - -instance (KnownNat n, 1 <= (n*2), (n*2) <= (n^2)) => SaturatingNum (Index n) where - satPlus SatWrap a b = case plus# a b of - z | let m = fromInteger# (natVal (Proxy @ n)) - , z >= m -> resize# (z - m) - z -> resize# z - satPlus SatZero a b = case plus# a b of - z | let m = fromInteger# (natVal (Proxy @ n)) - , z >= m -> fromInteger# 0 - z -> resize# z - satPlus _ a b = case plus# a b of - z | let m = fromInteger# (natVal (Proxy @ n)) - , z >= m -> maxBound# - z -> resize# z - - satMin SatWrap a b = - if lt# a b - then maxBound -# (b -# a) +# 1 - else a -# b - - satMin _ a b = - if lt# a b - then fromInteger# 0 - else a -# b - - satMult SatWrap a b = case times# a b of - z | let m = fromInteger# (natVal (Proxy @ n)) - , z >= m -> resize# (z - m) - z -> resize# z - satMult SatZero a b = case times# a b of - z | let m = fromInteger# (natVal (Proxy @ n)) - , z >= m -> fromInteger# 0 - z -> resize# z - satMult _ a b = case times# a b of - z | let m = fromInteger# (natVal (Proxy @ n)) - , z >= m -> maxBound# - z -> resize# z - -instance KnownNat n => Real (Index n) where - toRational = toRational . toInteger# - -instance KnownNat n => Integral (Index n) where - quot = quot# - rem = rem# - div = quot# - mod = rem# - quotRem n d = (n `quot#` d,n `rem#` d) - divMod n d = (n `quot#` d,n `rem#` d) - toInteger = toInteger# - -quot#,rem# :: Index n -> Index n -> Index n -{-# NOINLINE quot# #-} -(I a) `quot#` (I b) = I (a `div` b) -{-# NOINLINE rem# #-} -(I a) `rem#` (I b) = I (a `rem` b) - -{-# NOINLINE toInteger# #-} -toInteger# :: Index n -> Integer -toInteger# (I n) = n - -instance Resize Index where - resize = resize# - zeroExtend = extend - truncateB = resize# - -resize# :: KnownNat m => Index n -> Index m -resize# (I i) = fromInteger_INLINE i -{-# NOINLINE resize# #-} - -instance KnownNat n => Lift (Index n) where - lift u@(I i) = sigE [| fromInteger# i |] (decIndex (natVal u)) - {-# NOINLINE lift #-} - -decIndex :: Integer -> TypeQ -decIndex n = appT (conT ''Index) (litT $ numTyLit n) - -instance Show (Index n) where - show (I i) = show i - {-# NOINLINE show #-} - -instance ShowX (Index n) where - showsPrecX = showsPrecXWith showsPrec - --- | None of the 'Read' class' methods are synthesisable. -instance KnownNat n => Read (Index n) where - readPrec = fromIntegral <$> (readPrec :: ReadPrec Word) - -instance KnownNat n => Default (Index n) where - def = fromInteger# 0 - -instance KnownNat n => Arbitrary (Index n) where - arbitrary = arbitraryBoundedIntegral - shrink = shrinkIndex - -shrinkIndex :: KnownNat n => Index n -> [Index n] -shrinkIndex x | natVal x < 3 = case toInteger x of - 1 -> [0] - _ -> [] - -- 'shrinkIntegral' uses "`quot` 2", which for 'Index' types with - -- an upper bound less than 2 results in an error. - | otherwise = shrinkIntegral x - -instance KnownNat n => CoArbitrary (Index n) where - coarbitrary = coarbitraryIntegral diff --git a/src/CLaSH/Sized/Internal/Index.hs-boot b/src/CLaSH/Sized/Internal/Index.hs-boot deleted file mode 100644 --- a/src/CLaSH/Sized/Internal/Index.hs-boot +++ /dev/null @@ -1,19 +0,0 @@ -{-| -Copyright : (C) 2015-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij --} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RoleAnnotations #-} -module CLaSH.Sized.Internal.Index where - -import GHC.TypeLits (KnownNat, Nat) - -type role Index phantom -data Index :: Nat -> * - -instance KnownNat n => Num (Index n) -toInteger# :: Index n -> Integer diff --git a/src/CLaSH/Sized/Internal/Signed.hs b/src/CLaSH/Sized/Internal/Signed.hs deleted file mode 100644 --- a/src/CLaSH/Sized/Internal/Signed.hs +++ /dev/null @@ -1,557 +0,0 @@ -{-| -Copyright : (C) 2013-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij --} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# LANGUAGE Unsafe #-} - -{-# OPTIONS_HADDOCK show-extensions #-} -{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} -{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} - -module CLaSH.Sized.Internal.Signed - ( -- * Datatypes - Signed (..) - -- * Accessors - -- ** Length information - , size# - -- * Type classes - -- ** BitConvert - , pack# - , unpack# - -- Eq - , eq# - , neq# - -- ** Ord - , lt# - , ge# - , gt# - , le# - -- ** Enum (not synthesisable) - , enumFrom# - , enumFromThen# - , enumFromTo# - , enumFromThenTo# - -- ** Bounded - , minBound# - , maxBound# - -- ** Num - , (+#) - , (-#) - , (*#) - , negate# - , abs# - , fromInteger# - -- ** ExtendingNum - , plus# - , minus# - , times# - -- ** Integral - , quot# - , rem# - , div# - , mod# - , toInteger# - -- ** Bits - , and# - , or# - , xor# - , complement# - , shiftL# - , shiftR# - , rotateL# - , rotateR# - -- ** Resize - , resize# - , truncateB# - -- ** SaturatingNum - , minBoundSym# - ) -where - -import Control.DeepSeq (NFData (..)) -import Control.Lens (Index, Ixed (..), IxValue) -import Data.Bits (Bits (..), FiniteBits (..)) -import Data.Data (Data) -import Data.Default (Default (..)) -import Data.Proxy (Proxy (..)) -import Text.Read (Read (..), ReadPrec) -import GHC.TypeLits (KnownNat, Nat, type (+), natVal) -import GHC.TypeLits.Extra (Max) -import Language.Haskell.TH (TypeQ, appT, conT, litT, numTyLit, sigE) -import Language.Haskell.TH.Syntax (Lift(..)) -import Test.QuickCheck.Arbitrary (Arbitrary (..), CoArbitrary (..), - arbitraryBoundedIntegral, - coarbitraryIntegral, shrinkIntegral) - -import CLaSH.Class.BitPack (BitPack (..)) -import CLaSH.Class.Num (ExtendingNum (..), SaturatingNum (..), - SaturationMode (..)) -import CLaSH.Class.Resize (Resize (..)) -import CLaSH.Prelude.BitIndex ((!), msb, replaceBit, split) -import CLaSH.Prelude.BitReduction (reduceAnd, reduceOr) -import CLaSH.Sized.Internal.BitVector (BitVector (BV), Bit, (++#), high, low) -import qualified CLaSH.Sized.Internal.BitVector as BV -import CLaSH.XException (ShowX (..), showsPrecXWith) - --- | Arbitrary-width signed integer represented by @n@ bits, including the sign --- bit. --- --- Uses standard 2-complements representation. Meaning that, given @n@ bits, --- a 'Signed' @n@ number has a range of: [-(2^(@n@-1)) .. 2^(@n@-1)-1] --- --- __NB__: The 'Num' operators perform @wrap-around@ on overflow. If you want --- saturation on overflow, check out the 'SaturatingNum' class. --- --- >>> maxBound :: Signed 3 --- 3 --- >>> minBound :: Signed 3 --- -4 --- >>> read (show (minBound :: Signed 3)) :: Signed 3 --- -4 --- >>> 1 + 2 :: Signed 3 --- 3 --- >>> 2 + 3 :: Signed 3 --- -3 --- >>> (-2) + (-3) :: Signed 3 --- 3 --- >>> 2 * 3 :: Signed 4 --- 6 --- >>> 2 * 4 :: Signed 4 --- -8 --- >>> (2 :: Signed 3) `times` (4 :: Signed 4) :: Signed 7 --- 8 --- >>> (2 :: Signed 3) `plus` (3 :: Signed 3) :: Signed 4 --- 5 --- >>> (-2 :: Signed 3) `plus` (-3 :: Signed 3) :: Signed 4 --- -5 --- >>> satPlus SatSymmetric 2 3 :: Signed 3 --- 3 --- >>> satPlus SatSymmetric (-2) (-3) :: Signed 3 --- -3 -newtype Signed (n :: Nat) = - -- | The constructor, 'S', and the field, 'unsafeToInteger', are not - -- synthesisable. - S { unsafeToInteger :: Integer} - deriving (Data) - -{-# NOINLINE size# #-} -size# :: KnownNat n => Signed n -> Int -size# bv = fromInteger (natVal bv) - -instance NFData (Signed n) where - rnf (S i) = rnf i `seq` () - {-# NOINLINE rnf #-} - -- NOINLINE is needed so that CLaSH doesn't trip on the "Signed ~# Integer" - -- coercion - -instance Show (Signed n) where - show (S i) = show i - {-# NOINLINE show #-} - -instance ShowX (Signed n) where - showsPrecX = showsPrecXWith showsPrec - --- | None of the 'Read' class' methods are synthesisable. -instance KnownNat n => Read (Signed n) where - readPrec = fromIntegral <$> (readPrec :: ReadPrec Int) - -instance KnownNat n => BitPack (Signed n) where - type BitSize (Signed n) = n - pack = pack# - unpack = unpack# - -{-# NOINLINE pack# #-} -pack# :: forall n . KnownNat n => Signed n -> BitVector n -pack# (S i) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n)) - in if i < 0 then BV (m + i) else BV i - -{-# NOINLINE unpack# #-} -unpack# :: forall n . KnownNat n => BitVector n -> Signed n -unpack# (BV i) = - let m = 1 `shiftL` fromInteger (natVal (Proxy @n) - 1) - in if i >= m then S (i-2*m) else S i - -instance Eq (Signed n) where - (==) = eq# - (/=) = neq# - -{-# NOINLINE eq# #-} -eq# :: Signed n -> Signed n -> Bool -eq# (S v1) (S v2) = v1 == v2 - -{-# NOINLINE neq# #-} -neq# :: Signed n -> Signed n -> Bool -neq# (S v1) (S v2) = v1 /= v2 - -instance Ord (Signed n) where - (<) = lt# - (>=) = ge# - (>) = gt# - (<=) = le# - -lt#,ge#,gt#,le# :: Signed n -> Signed n -> Bool -{-# NOINLINE lt# #-} -lt# (S n) (S m) = n < m -{-# NOINLINE ge# #-} -ge# (S n) (S m) = n >= m -{-# NOINLINE gt# #-} -gt# (S n) (S m) = n > m -{-# NOINLINE le# #-} -le# (S n) (S m) = n <= m - --- | The functions: 'enumFrom', 'enumFromThen', 'enumFromTo', and --- 'enumFromThenTo', are not synthesisable. -instance KnownNat n => Enum (Signed n) where - succ = (+# fromInteger# 1) - pred = (-# fromInteger# 1) - toEnum = fromInteger# . toInteger - fromEnum = fromEnum . toInteger# - enumFrom = enumFrom# - enumFromThen = enumFromThen# - enumFromTo = enumFromTo# - enumFromThenTo = enumFromThenTo# - -{-# NOINLINE enumFrom# #-} -{-# NOINLINE enumFromThen# #-} -{-# NOINLINE enumFromTo# #-} -{-# NOINLINE enumFromThenTo# #-} -enumFrom# :: KnownNat n => Signed n -> [Signed n] -enumFromThen# :: KnownNat n => Signed n -> Signed n -> [Signed n] -enumFromTo# :: Signed n -> Signed n -> [Signed n] -enumFromThenTo# :: Signed n -> Signed n -> Signed n -> [Signed n] -enumFrom# x = map fromInteger_INLINE [unsafeToInteger x ..] -enumFromThen# x y = map fromInteger_INLINE [unsafeToInteger x, unsafeToInteger y ..] -enumFromTo# x y = map S [unsafeToInteger x .. unsafeToInteger y] -enumFromThenTo# x1 x2 y = map S [unsafeToInteger x1, unsafeToInteger x2 .. unsafeToInteger y] - - -instance KnownNat n => Bounded (Signed n) where - minBound = minBound# - maxBound = maxBound# - -minBound#,maxBound# :: KnownNat n => Signed n -{-# NOINLINE minBound# #-} -minBound# = let res = S $ negate $ 2 ^ (natVal res - 1) in res -{-# NOINLINE maxBound# #-} -maxBound# = let res = S $ 2 ^ (natVal res - 1) - 1 in res - --- | Operators do @wrap-around@ on overflow -instance KnownNat n => Num (Signed n) where - (+) = (+#) - (-) = (-#) - (*) = (*#) - negate = negate# - abs = abs# - signum s = if s < 0 then (-1) else - if s > 0 then 1 else 0 - fromInteger = fromInteger# - -(+#), (-#), (*#) :: forall n . KnownNat n => Signed n -> Signed n -> Signed n -{-# NOINLINE (+#) #-} -(S a) +# (S b) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n) -1) - z = a + b - in if z >= m then S (z - 2*m) else - if z < negate m then S (z + 2*m) else S z - -{-# NOINLINE (-#) #-} -(S a) -# (S b) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n) -1) - z = a - b - in if z < negate m then S (z + 2*m) else - if z >= m then S (z - 2*m) else S z - -{-# NOINLINE (*#) #-} -(S a) *# (S b) = fromInteger_INLINE (a * b) - -negate#,abs# :: forall n . KnownNat n => Signed n -> Signed n -{-# NOINLINE negate# #-} -negate# (S n) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n) -1) - z = negate n - in if z == m then S n else S z - -{-# NOINLINE abs# #-} -abs# (S n) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n) -1) - z = abs n - in if z == m then S n else S z - -{-# NOINLINE fromInteger# #-} -fromInteger# :: KnownNat n => Integer -> Signed (n :: Nat) -fromInteger# = fromInteger_INLINE - -{-# INLINE fromInteger_INLINE #-} -fromInteger_INLINE :: forall n . KnownNat n => Integer -> Signed n -fromInteger_INLINE i = mask `seq` S res - where - mask = 1 `shiftL` fromInteger (natVal (Proxy @n) -1) - res = case divMod i mask of - (s,i') | even s -> i' - | otherwise -> i' - mask - -instance ExtendingNum (Signed m) (Signed n) where - type AResult (Signed m) (Signed n) = Signed (Max m n + 1) - plus = plus# - minus = minus# - type MResult (Signed m) (Signed n) = Signed (m + n) - times = times# - -plus#, minus# :: Signed m -> Signed n -> Signed (Max m n + 1) -{-# NOINLINE plus# #-} -plus# (S a) (S b) = S (a + b) - -{-# NOINLINE minus# #-} -minus# (S a) (S b) = S (a - b) - -{-# NOINLINE times# #-} -times# :: Signed m -> Signed n -> Signed (m + n) -times# (S a) (S b) = S (a * b) - -instance KnownNat n => Real (Signed n) where - toRational = toRational . toInteger# - -instance KnownNat n => Integral (Signed n) where - quot = quot# - rem = rem# - div = div# - mod = mod# - quotRem n d = (n `quot#` d,n `rem#` d) - divMod n d = (n `div#` d,n `mod#` d) - toInteger = toInteger# - -quot#,rem# :: Signed n -> Signed n -> Signed n -{-# NOINLINE quot# #-} -quot# (S a) (S b) = S (a `quot` b) -{-# NOINLINE rem# #-} -rem# (S a) (S b) = S (a `rem` b) - -div#,mod# :: Signed n -> Signed n -> Signed n -{-# NOINLINE div# #-} -div# (S a) (S b) = S (a `div` b) -{-# NOINLINE mod# #-} -mod# (S a) (S b) = S (a `mod` b) - -{-# NOINLINE toInteger# #-} -toInteger# :: Signed n -> Integer -toInteger# (S n) = n - -instance KnownNat n => Bits (Signed n) where - (.&.) = and# - (.|.) = or# - xor = xor# - complement = complement# - zeroBits = 0 - bit i = replaceBit i high 0 - setBit v i = replaceBit i high v - clearBit v i = replaceBit i low v - complementBit v i = replaceBit i (BV.complement# (v ! i)) v - testBit v i = v ! i == 1 - bitSizeMaybe v = Just (size# v) - bitSize = size# - isSigned _ = True - shiftL v i = shiftL# v i - shiftR v i = shiftR# v i - rotateL v i = rotateL# v i - rotateR v i = rotateR# v i - popCount s = popCount (pack# s) - -and#,or#,xor# :: KnownNat n => Signed n -> Signed n -> Signed n -{-# NOINLINE and# #-} -and# (S a) (S b) = fromInteger_INLINE (a .&. b) -{-# NOINLINE or# #-} -or# (S a) (S b) = fromInteger_INLINE (a .|. b) -{-# NOINLINE xor# #-} -xor# (S a) (S b) = fromInteger_INLINE (xor a b) - -{-# NOINLINE complement# #-} -complement# :: KnownNat n => Signed n -> Signed n -complement# (S a) = fromInteger_INLINE (complement a) - -shiftL#,shiftR#,rotateL#,rotateR# :: KnownNat n => Signed n -> Int -> Signed n -{-# NOINLINE shiftL# #-} -shiftL# _ b | b < 0 = error "'shiftL undefined for negative numbers" -shiftL# (S n) b = fromInteger_INLINE (shiftL n b) -{-# NOINLINE shiftR# #-} -shiftR# _ b | b < 0 = error "'shiftR undefined for negative numbers" -shiftR# (S n) b = fromInteger_INLINE (shiftR n b) -{-# NOINLINE rotateL# #-} -rotateL# _ b | b < 0 = error "'shiftL undefined for negative numbers" -rotateL# s@(S n) b = fromInteger_INLINE (l .|. r) - where - l = shiftL n b' - r = shiftR n b'' .&. mask - mask = 2 ^ b' - 1 - - b' = b `mod` sz - b'' = sz - b' - sz = fromInteger (natVal s) - -{-# NOINLINE rotateR# #-} -rotateR# _ b | b < 0 = error "'shiftR undefined for negative numbers" -rotateR# s@(S n) b = fromInteger_INLINE (l .|. r) - where - l = shiftR n b' .&. mask - r = shiftL n b'' - mask = 2 ^ b'' - 1 - - b' = b `mod` sz - b'' = sz - b' - sz = fromInteger (natVal s) - -instance KnownNat n => FiniteBits (Signed n) where - finiteBitSize = size# - countLeadingZeros s = countLeadingZeros (pack# s) - countTrailingZeros s = countTrailingZeros (pack# s) - -instance Resize Signed where - resize = resize# - zeroExtend s = unpack# (0 ++# pack s) - truncateB = truncateB# - -{-# NOINLINE resize# #-} -resize# :: forall m n . (KnownNat n, KnownNat m) => Signed n -> Signed m -resize# s@(S i) | n' <= m' = extended - | otherwise = truncated - where - n = fromInteger (natVal s) - n' = shiftL 1 n - m' = shiftL mask 1 - extended = S i - - mask = 1 `shiftL` fromInteger (natVal (Proxy @m) -1) - i' = i `mod` mask - truncated = if testBit i (n-1) - then S (i' - mask) - else S i' - -{-# NOINLINE truncateB# #-} -truncateB# :: KnownNat m => Signed (m + n) -> Signed m -truncateB# (S n) = fromInteger_INLINE n - -instance KnownNat n => Default (Signed n) where - def = fromInteger# 0 - -instance KnownNat n => Lift (Signed n) where - lift s@(S i) = sigE [| fromInteger# i |] (decSigned (natVal s)) - {-# NOINLINE lift #-} - -decSigned :: Integer -> TypeQ -decSigned n = appT (conT ''Signed) (litT $ numTyLit n) - -instance KnownNat n => SaturatingNum (Signed n) where - satPlus SatWrap a b = a +# b - satPlus SatBound a b = - let r = plus# a b - (_,r') = split r - in case msb r `xor` msb r' of - 0 -> unpack# r' - _ -> case msb a .&. msb b of - 0 -> maxBound# - _ -> minBound# - satPlus SatZero a b = - let r = plus# a b - (_,r') = split r - in case msb r `xor` msb r' of - 0 -> unpack# r' - _ -> fromInteger# 0 - satPlus SatSymmetric a b = - let r = plus# a b - (_,r') = split r - in case msb r `xor` msb r' of - 0 -> unpack# r' - _ -> case msb a .&. msb b of - 0 -> maxBound# - _ -> minBoundSym# - - satMin SatWrap a b = a -# b - satMin SatBound a b = - let r = minus# a b - (_,r') = split r - in case msb r `xor` msb r' of - 0 -> unpack# r' - _ -> case msb a ++# msb b of - 2 -> minBound# - _ -> maxBound# - satMin SatZero a b = - let r = minus# a b - (_,r') = split r - in case msb r `xor` msb r' of - 0 -> unpack# r' - _ -> fromInteger# 0 - satMin SatSymmetric a b = - let r = minus# a b - (_,r') = split r - in case msb r `xor` msb r' of - 0 -> unpack# r' - _ -> case msb a ++# msb b of - 2 -> minBoundSym# - _ -> maxBound# - - satMult SatWrap a b = a *# b - satMult SatBound a b = - let r = times# a b - (rL,rR) = split r - overflow = complement (reduceOr (msb rR ++# pack rL)) .|. - reduceAnd (msb rR ++# pack rL) - in case overflow of - 1 -> unpack# rR - _ -> case msb rL of - 0 -> maxBound# - _ -> minBound# - satMult SatZero a b = - let r = times# a b - (rL,rR) = split r - overflow = complement (reduceOr (msb rR ++# pack rL)) .|. - reduceAnd (msb rR ++# pack rL) - in case overflow of - 1 -> unpack# rR - _ -> fromInteger# 0 - satMult SatSymmetric a b = - let r = times# a b - (rL,rR) = split r - overflow = complement (reduceOr (msb rR ++# pack rL)) .|. - reduceAnd (msb rR ++# pack rL) - in case overflow of - 1 -> unpack# rR - _ -> case msb rL of - 0 -> maxBound# - _ -> minBoundSym# - -minBoundSym# :: KnownNat n => Signed n -minBoundSym# = minBound# +# fromInteger# 1 - -instance KnownNat n => Arbitrary (Signed n) where - arbitrary = arbitraryBoundedIntegral - shrink = shrinkSizedSigned - -shrinkSizedSigned :: (KnownNat n, Integral (p n)) => p n -> [p n] -shrinkSizedSigned x | natVal x < 2 = case toInteger x of - 0 -> [] - _ -> [0] - -- 'shrinkIntegral' uses "`quot` 2", which for sized types - -- less than 2 bits wide results in a division by zero. - -- - -- See: https://github.com/clash-lang/clash-compiler/issues/153 - | otherwise = shrinkIntegral x -{-# INLINE shrinkSizedSigned #-} - -instance KnownNat n => CoArbitrary (Signed n) where - coarbitrary = coarbitraryIntegral - -type instance Index (Signed n) = Int -type instance IxValue (Signed n) = Bit -instance KnownNat n => Ixed (Signed n) where - ix i f s = unpack# <$> BV.replaceBit# (pack# s) i - <$> f (BV.index# (pack# s) i) diff --git a/src/CLaSH/Sized/Internal/Unsigned.hs b/src/CLaSH/Sized/Internal/Unsigned.hs deleted file mode 100644 --- a/src/CLaSH/Sized/Internal/Unsigned.hs +++ /dev/null @@ -1,467 +0,0 @@ -{-| -Copyright : (C) 2013-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij --} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# LANGUAGE Unsafe #-} - -{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Sized.Internal.Unsigned - ( -- * Datatypes - Unsigned (..) - -- * Accessors - -- ** Length information - , size# - -- * Type classes - -- ** BitConvert - , pack# - , unpack# - -- ** Eq - , eq# - , neq# - -- ** Ord - , lt# - , ge# - , gt# - , le# - -- ** Enum (not synthesisable) - , enumFrom# - , enumFromThen# - , enumFromTo# - , enumFromThenTo# - -- ** Bounded - , minBound# - , maxBound# - -- ** Num - , (+#) - , (-#) - , (*#) - , negate# - , fromInteger# - -- ** ExtendingNum - , plus# - , minus# - , times# - -- ** Integral - , quot# - , rem# - , toInteger# - -- ** Bits - , and# - , or# - , xor# - , complement# - , shiftL# - , shiftR# - , rotateL# - , rotateR# - -- ** Resize - , resize# - ) -where - -import Control.DeepSeq (NFData (..)) -import Control.Lens (Index, Ixed (..), IxValue) -import Data.Bits (Bits (..), FiniteBits (..)) -import Data.Data (Data) -import Data.Default (Default (..)) -import Data.Proxy (Proxy (..)) -import Text.Read (Read (..), ReadPrec) -import GHC.TypeLits (KnownNat, Nat, type (+), natVal) -import GHC.TypeLits.Extra (Max) -import Language.Haskell.TH (TypeQ, appT, conT, litT, numTyLit, sigE) -import Language.Haskell.TH.Syntax (Lift(..)) -import Test.QuickCheck.Arbitrary (Arbitrary (..), CoArbitrary (..), - arbitraryBoundedIntegral, - coarbitraryIntegral) - -import CLaSH.Class.BitPack (BitPack (..)) -import CLaSH.Class.Num (ExtendingNum (..), SaturatingNum (..), - SaturationMode (..)) -import CLaSH.Class.Resize (Resize (..)) -import CLaSH.Prelude.BitIndex ((!), msb, replaceBit, split) -import CLaSH.Prelude.BitReduction (reduceOr) -import CLaSH.Sized.Internal.BitVector (BitVector (BV), Bit, high, low) -import qualified CLaSH.Sized.Internal.BitVector as BV -import CLaSH.XException (ShowX (..), showsPrecXWith) - --- | Arbitrary-width unsigned integer represented by @n@ bits --- --- Given @n@ bits, an 'Unsigned' @n@ number has a range of: [0 .. 2^@n@-1] --- --- __NB__: The 'Num' operators perform @wrap-around@ on overflow. If you want --- saturation on overflow, check out the 'SaturatingNum' class. --- --- >>> maxBound :: Unsigned 3 --- 7 --- >>> minBound :: Unsigned 3 --- 0 --- >>> read (show (maxBound :: Unsigned 3)) :: Unsigned 3 --- 7 --- >>> 1 + 2 :: Unsigned 3 --- 3 --- >>> 2 + 6 :: Unsigned 3 --- 0 --- >>> 1 - 3 :: Unsigned 3 --- 6 --- >>> 2 * 3 :: Unsigned 3 --- 6 --- >>> 2 * 4 :: Unsigned 3 --- 0 --- >>> (2 :: Unsigned 3) `times` (4 :: Unsigned 3) :: Unsigned 6 --- 8 --- >>> (2 :: Unsigned 3) `plus` (6 :: Unsigned 3) :: Unsigned 4 --- 8 --- >>> satPlus SatSymmetric 2 6 :: Unsigned 3 --- 7 --- >>> satMin SatSymmetric 2 3 :: Unsigned 3 --- 0 -newtype Unsigned (n :: Nat) = - -- | The constructor, 'U', and the field, 'unsafeToInteger', are not - -- synthesisable. - U { unsafeToInteger :: Integer } - deriving Data - -{-# NOINLINE size# #-} -size# :: KnownNat n => Unsigned n -> Int -size# u = fromInteger (natVal u) - -instance NFData (Unsigned n) where - rnf (U i) = rnf i `seq` () - {-# NOINLINE rnf #-} - -- NOINLINE is needed so that CLaSH doesn't trip on the "Unsigned ~# Integer" - -- coercion - -instance Show (Unsigned n) where - show (U i) = show i - {-# NOINLINE show #-} - -instance ShowX (Unsigned n) where - showsPrecX = showsPrecXWith showsPrec - --- | None of the 'Read' class' methods are synthesisable. -instance KnownNat n => Read (Unsigned n) where - readPrec = fromIntegral <$> (readPrec :: ReadPrec Word) - -instance BitPack (Unsigned n) where - type BitSize (Unsigned n) = n - pack = pack# - unpack = unpack# - -{-# NOINLINE pack# #-} -pack# :: Unsigned n -> BitVector n -pack# (U i) = BV i - -{-# NOINLINE unpack# #-} -unpack# :: BitVector n -> Unsigned n -unpack# (BV i) = U i - -instance Eq (Unsigned n) where - (==) = eq# - (/=) = neq# - -{-# NOINLINE eq# #-} -eq# :: Unsigned n -> Unsigned n -> Bool -eq# (U v1) (U v2) = v1 == v2 - -{-# NOINLINE neq# #-} -neq# :: Unsigned n -> Unsigned n -> Bool -neq# (U v1) (U v2) = v1 /= v2 - -instance Ord (Unsigned n) where - (<) = lt# - (>=) = ge# - (>) = gt# - (<=) = le# - -lt#,ge#,gt#,le# :: Unsigned n -> Unsigned n -> Bool -{-# NOINLINE lt# #-} -lt# (U n) (U m) = n < m -{-# NOINLINE ge# #-} -ge# (U n) (U m) = n >= m -{-# NOINLINE gt# #-} -gt# (U n) (U m) = n > m -{-# NOINLINE le# #-} -le# (U n) (U m) = n <= m - --- | The functions: 'enumFrom', 'enumFromThen', 'enumFromTo', and --- 'enumFromThenTo', are not synthesisable. -instance KnownNat n => Enum (Unsigned n) where - succ = (+# fromInteger# 1) - pred = (-# fromInteger# 1) - toEnum = fromInteger# . toInteger - fromEnum = fromEnum . toInteger# - enumFrom = enumFrom# - enumFromThen = enumFromThen# - enumFromTo = enumFromTo# - enumFromThenTo = enumFromThenTo# - -{-# NOINLINE enumFrom# #-} -{-# NOINLINE enumFromThen# #-} -{-# NOINLINE enumFromTo# #-} -{-# NOINLINE enumFromThenTo# #-} -enumFrom# :: KnownNat n => Unsigned n -> [Unsigned n] -enumFromThen# :: KnownNat n => Unsigned n -> Unsigned n -> [Unsigned n] -enumFromTo# :: Unsigned n -> Unsigned n -> [Unsigned n] -enumFromThenTo# :: Unsigned n -> Unsigned n -> Unsigned n -> [Unsigned n] -enumFrom# x = map fromInteger_INLINE [unsafeToInteger x ..] -enumFromThen# x y = map fromInteger_INLINE [unsafeToInteger x, unsafeToInteger y ..] -enumFromTo# x y = map U [unsafeToInteger x .. unsafeToInteger y] -enumFromThenTo# x1 x2 y = map U [unsafeToInteger x1, unsafeToInteger x2 .. unsafeToInteger y] - -instance KnownNat n => Bounded (Unsigned n) where - minBound = minBound# - maxBound = maxBound# - -{-# NOINLINE minBound# #-} -minBound# :: Unsigned n -minBound# = U 0 - -{-# NOINLINE maxBound# #-} -maxBound# :: forall n .KnownNat n => Unsigned n -maxBound# = let m = 1 `shiftL` fromInteger (natVal (Proxy @n)) - in U (m - 1) - -instance KnownNat n => Num (Unsigned n) where - (+) = (+#) - (-) = (-#) - (*) = (*#) - negate = negate# - abs = id - signum bv = resize# (unpack# (reduceOr bv)) - fromInteger = fromInteger# - -(+#),(-#),(*#) :: forall n . KnownNat n => Unsigned n -> Unsigned n -> Unsigned n -{-# NOINLINE (+#) #-} -(+#) (U i) (U j) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n)) - z = i + j - in if z >= m then U (z - m) else U z - -{-# NOINLINE (-#) #-} -(-#) (U i) (U j) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n)) - z = i - j - in if z < 0 then U (m + z) else U z - -{-# NOINLINE (*#) #-} -(*#) (U i) (U j) = fromInteger_INLINE (i * j) - -{-# NOINLINE negate# #-} -negate# :: forall n . KnownNat n => Unsigned n -> Unsigned n -negate# (U 0) = U 0 -negate# (U i) = sz `seq` U (sz - i) - where - sz = 1 `shiftL` fromInteger (natVal (Proxy @n)) - -{-# NOINLINE fromInteger# #-} -fromInteger# :: KnownNat n => Integer -> Unsigned n -fromInteger# = fromInteger_INLINE - -{-# INLINE fromInteger_INLINE #-} -fromInteger_INLINE :: forall n . KnownNat n => Integer -> Unsigned n -fromInteger_INLINE i = U (i `mod` sz) - where - sz = 1 `shiftL` fromInteger (natVal (Proxy @n)) - -instance (KnownNat m, KnownNat n) => ExtendingNum (Unsigned m) (Unsigned n) where - type AResult (Unsigned m) (Unsigned n) = Unsigned (Max m n + 1) - plus = plus# - minus = minus# - type MResult (Unsigned m) (Unsigned n) = Unsigned (m + n) - times = times# - -{-# NOINLINE plus# #-} -plus# :: Unsigned m -> Unsigned n -> Unsigned (Max m n + 1) -plus# (U a) (U b) = U (a + b) - -{-# NOINLINE minus# #-} -minus# :: forall m n . (KnownNat m, KnownNat n) => Unsigned m -> Unsigned n - -> Unsigned (Max m n + 1) -minus# (U a) (U b) = - let sz = fromInteger (natVal (Proxy @(Max m n + 1))) - mask = 1 `shiftL` sz - z = a - b - in if z < 0 then U (mask + z) else U z - -{-# NOINLINE times# #-} -times# :: Unsigned m -> Unsigned n -> Unsigned (m + n) -times# (U a) (U b) = U (a * b) - -instance KnownNat n => Real (Unsigned n) where - toRational = toRational . toInteger# - -instance KnownNat n => Integral (Unsigned n) where - quot = quot# - rem = rem# - div = quot# - mod = rem# - quotRem n d = (n `quot#` d,n `rem#` d) - divMod n d = (n `quot#` d,n `rem#` d) - toInteger = toInteger# - -quot#,rem# :: Unsigned n -> Unsigned n -> Unsigned n -{-# NOINLINE quot# #-} -quot# (U i) (U j) = U (i `quot` j) -{-# NOINLINE rem# #-} -rem# (U i) (U j) = U (i `rem` j) - -{-# NOINLINE toInteger# #-} -toInteger# :: Unsigned n -> Integer -toInteger# (U i) = i - -instance KnownNat n => Bits (Unsigned n) where - (.&.) = and# - (.|.) = or# - xor = xor# - complement = complement# - zeroBits = 0 - bit i = replaceBit i high 0 - setBit v i = replaceBit i high v - clearBit v i = replaceBit i low v - complementBit v i = replaceBit i (BV.complement# (v ! i)) v - testBit v i = v ! i == high - bitSizeMaybe v = Just (size# v) - bitSize = size# - isSigned _ = False - shiftL v i = shiftL# v i - shiftR v i = shiftR# v i - rotateL v i = rotateL# v i - rotateR v i = rotateR# v i - popCount u = popCount (pack# u) - -{-# NOINLINE and# #-} -and# :: Unsigned n -> Unsigned n -> Unsigned n -and# (U v1) (U v2) = U (v1 .&. v2) - -{-# NOINLINE or# #-} -or# :: Unsigned n -> Unsigned n -> Unsigned n -or# (U v1) (U v2) = U (v1 .|. v2) - -{-# NOINLINE xor# #-} -xor# :: Unsigned n -> Unsigned n -> Unsigned n -xor# (U v1) (U v2) = U (v1 `xor` v2) - -{-# NOINLINE complement# #-} -complement# :: KnownNat n => Unsigned n -> Unsigned n -complement# (U i) = fromInteger_INLINE (complement i) - -shiftL#, rotateL#, rotateR# :: KnownNat n => Unsigned n -> Int -> Unsigned n -{-# NOINLINE shiftL# #-} -shiftL# (U v) i - | i < 0 = error - $ "'shiftL undefined for negative number: " ++ show i - | otherwise = fromInteger_INLINE (shiftL v i) - -{-# NOINLINE shiftR# #-} -shiftR# :: Unsigned n -> Int -> Unsigned n -shiftR# (U v) i - | i < 0 = error - $ "'shiftR undefined for negative number: " ++ show i - | otherwise = U (shiftR v i) - -{-# NOINLINE rotateL# #-} -rotateL# _ b | b < 0 = error "'shiftL undefined for negative numbers" -rotateL# bv@(U n) b = fromInteger_INLINE (l .|. r) - where - l = shiftL n b' - r = shiftR n b'' - - b' = b `mod` sz - b'' = sz - b' - sz = fromInteger (natVal bv) - -{-# NOINLINE rotateR# #-} -rotateR# _ b | b < 0 = error "'shiftR undefined for negative numbers" -rotateR# bv@(U n) b = fromInteger_INLINE (l .|. r) - where - l = shiftR n b' - r = shiftL n b'' - - b' = b `mod` sz - b'' = sz - b' - sz = fromInteger (natVal bv) - -instance KnownNat n => FiniteBits (Unsigned n) where - finiteBitSize = size# - countLeadingZeros u = countLeadingZeros (pack# u) - countTrailingZeros u = countTrailingZeros (pack# u) - -instance Resize Unsigned where - resize = resize# - zeroExtend = extend - truncateB = resize# - -{-# NOINLINE resize# #-} -resize# :: forall n m . KnownNat m => Unsigned n -> Unsigned m -resize# (U i) = let m = 1 `shiftL` fromInteger (natVal (Proxy @m)) - in if i >= m then fromInteger_INLINE i else U i - -instance Default (Unsigned n) where - def = minBound# - -instance KnownNat n => Lift (Unsigned n) where - lift u@(U i) = sigE [| fromInteger# i |] (decUnsigned (natVal u)) - {-# NOINLINE lift #-} - -decUnsigned :: Integer -> TypeQ -decUnsigned n = appT (conT ''Unsigned) (litT $ numTyLit n) - -instance KnownNat n => SaturatingNum (Unsigned n) where - satPlus SatWrap a b = a +# b - satPlus SatZero a b = - let r = plus# a b - in case msb r of - 0 -> resize# r - _ -> minBound# - satPlus _ a b = - let r = plus# a b - in case msb r of - 0 -> resize# r - _ -> maxBound# - - satMin SatWrap a b = a -# b - satMin _ a b = - let r = minus# a b - in case msb r of - 0 -> resize# r - _ -> minBound# - - satMult SatWrap a b = a *# b - satMult SatZero a b = - let r = times# a b - (rL,rR) = split r - in case rL of - 0 -> unpack# rR - _ -> minBound# - satMult _ a b = - let r = times# a b - (rL,rR) = split r - in case rL of - 0 -> unpack# rR - _ -> maxBound# - -instance KnownNat n => Arbitrary (Unsigned n) where - arbitrary = arbitraryBoundedIntegral - shrink = BV.shrinkSizedUnsigned - -instance KnownNat n => CoArbitrary (Unsigned n) where - coarbitrary = coarbitraryIntegral - -type instance Index (Unsigned n) = Int -type instance IxValue (Unsigned n) = Bit -instance KnownNat n => Ixed (Unsigned n) where - ix i f s = unpack# <$> BV.replaceBit# (pack# s) i - <$> f (BV.index# (pack# s) i) diff --git a/src/CLaSH/Sized/RTree.hs b/src/CLaSH/Sized/RTree.hs deleted file mode 100644 --- a/src/CLaSH/Sized/RTree.hs +++ /dev/null @@ -1,478 +0,0 @@ -{-| -Copyright : (C) 2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij --} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - -{-# LANGUAGE Trustworthy #-} - -{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise -fplugin GHC.TypeLits.KnownNat.Solver #-} - -module CLaSH.Sized.RTree - ( -- * 'RTree' data type - RTree (LR, BR) - -- * Construction - , treplicate - , trepeat - -- * Accessors - -- ** Indexing - , indexTree - , tindices - -- * Modifying trees - , replaceTree - -- * Element-wise operations - -- ** Mapping - , tmap - , tzipWith - -- ** Zipping - , tzip - -- ** Unzipping - , tunzip - -- * Folding - , tfold - -- ** Specialised folds - , tdfold - -- * Conversions - , v2t - , t2v - -- * Misc - , lazyT - ) -where - -import Control.Applicative (liftA2) -import qualified Control.Lens as Lens -import Data.Default (Default (..)) -import Data.Foldable (toList) -import Data.Singletons.Prelude (Apply, TyFun, type (@@)) -import Data.Proxy (Proxy (..)) -import GHC.TypeLits (KnownNat, Nat, type (+), type (^), type (*)) -import Language.Haskell.TH.Syntax (Lift(..)) -import qualified Prelude as P -import Prelude hiding ((++), (!!)) -import Test.QuickCheck (Arbitrary (..), CoArbitrary (..)) - -import CLaSH.Class.BitPack (BitPack (..)) -import CLaSH.Promoted.Nat (SNat (..), UNat (..), pow2SNat, snatToNum, - subSNat, toUNat) -import CLaSH.Promoted.Nat.Literals (d1) -import CLaSH.Sized.Index (Index) -import CLaSH.Sized.Vector (Vec (..), (!!), (++), dtfold, replace) -import CLaSH.XException (ShowX (..), showsX, showsPrecXWith) - -{- $setup ->>> :set -XDataKinds ->>> :set -XTypeFamilies ->>> :set -XTypeOperators ->>> :set -XTemplateHaskell ->>> :set -XFlexibleContexts ->>> :set -XTypeApplications ->>> :set -fplugin GHC.TypeLits.Normalise ->>> :set -XUndecidableInstances ->>> import CLaSH.Prelude ->>> data IIndex (f :: TyFun Nat *) :: * ->>> type instance Apply IIndex l = Index ((2^l)+1) ->>> :{ -let populationCount' :: (KnownNat k, KnownNat (2^k)) => BitVector (2^k) -> Index ((2^k)+1) - populationCount' bv = tdfold (Proxy @IIndex) - fromIntegral - (\_ x y -> plus x y) - (v2t (bv2v bv)) -:} --} - --- | Perfect depth binary tree. --- --- * Only has elements at the leaf of the tree --- * A tree of depth /d/ has /2^d/ elements. -data RTree :: Nat -> * -> * where - LR_ :: a -> RTree 0 a - BR_ :: RTree d a -> RTree d a -> RTree (d+1) a - -textract :: RTree 0 a -> a -textract (LR_ x) = x -{-# NOINLINE textract #-} - -tsplit :: RTree (d+1) a -> (RTree d a,RTree d a) -tsplit (BR_ l r) = (l,r) -{-# NOINLINE tsplit #-} - --- | Leaf of a perfect depth tree --- --- >>> LR 1 --- 1 --- >>> let x = LR 1 --- >>> :t x --- x :: Num a => RTree 0 a --- --- Can be used as a pattern: --- --- >>> let f (LR a) (LR b) = a + b --- >>> :t f --- f :: Num a => RTree 0 a -> RTree 0 a -> a --- >>> f (LR 1) (LR 2) --- 3 -pattern LR :: a -> RTree 0 a -pattern LR x <- (textract -> x) - where - LR x = LR_ x - --- | Branch of a perfect depth tree --- --- >>> BR (LR 1) (LR 2) --- <1,2> --- >>> let x = BR (LR 1) (LR 2) --- >>> :t x --- x :: Num a => RTree 1 a --- --- Case be used a pattern: --- --- >>> let f (BR (LR a) (LR b)) = LR (a + b) --- >>> :t f --- f :: Num a => RTree 1 a -> RTree 0 a --- >>> f (BR (LR 1) (LR 2)) --- 3 -pattern BR :: RTree d a -> RTree d a -> RTree (d+1) a -pattern BR l r <- ((\t -> (tsplit t)) -> (l,r)) - where - BR l r = BR_ l r - -instance (KnownNat d, Eq a) => Eq (RTree d a) where - (==) t1 t2 = (==) (t2v t1) (t2v t2) - -instance (KnownNat d, Ord a) => Ord (RTree d a) where - compare t1 t2 = compare (t2v t1) (t2v t2) - -instance Show a => Show (RTree n a) where - showsPrec _ (LR_ a) = shows a - showsPrec _ (BR_ l r) = \s -> '<':shows l (',':shows r ('>':s)) - -instance ShowX a => ShowX (RTree n a) where - showsPrecX = showsPrecXWith go - where - go :: Int -> RTree d a -> ShowS - go _ (LR_ a) = showsX a - go _ (BR_ l r) = \s -> '<':showsX l (',':showsX r ('>':s)) - -instance KnownNat d => Functor (RTree d) where - fmap = tmap - -instance KnownNat d => Applicative (RTree d) where - pure = trepeat - (<*>) = tzipWith ($) - -instance KnownNat d => Foldable (RTree d) where - foldMap f = tfold f mappend - -data TraversableTree (g :: * -> *) (a :: *) (f :: TyFun Nat *) :: * -type instance Apply (TraversableTree f a) d = f (RTree d a) - -instance KnownNat d => Traversable (RTree d) where - traverse :: forall f a b . Applicative f => (a -> f b) -> RTree d a -> f (RTree d b) - traverse f = tdfold (Proxy @(TraversableTree f b)) - (fmap LR . f) - (const (liftA2 BR)) - -instance (KnownNat d, KnownNat (BitSize a), BitPack a) => - BitPack (RTree d a) where - type BitSize (RTree d a) = (2^d) * (BitSize a) - pack = pack . t2v - unpack = v2t . unpack - -type instance Lens.Index (RTree d a) = Int -type instance Lens.IxValue (RTree d a) = a -instance KnownNat d => Lens.Ixed (RTree d a) where - ix i f t = replaceTree i <$> f (indexTree t i) <*> pure t - -instance (KnownNat d, Default a) => Default (RTree d a) where - def = trepeat def - -instance Lift a => Lift (RTree d a) where - lift (LR_ a) = [| LR_ a |] - lift (BR_ t1 t2) = [| BR_ $(lift t1) $(lift t2) |] - -instance (KnownNat d, Arbitrary a) => Arbitrary (RTree d a) where - arbitrary = sequenceA (trepeat arbitrary) - shrink = sequenceA . fmap shrink - -instance (KnownNat d, CoArbitrary a) => CoArbitrary (RTree d a) where - coarbitrary = coarbitrary . toList - --- | A /dependently/ typed fold over trees. --- --- As an example of when you might want to use 'dtfold' we will build a --- population counter: a circuit that counts the number of bits set to '1' in --- a 'BitVector'. Given a vector of /n/ bits, we only need we need a data type --- that can represent the number /n/: 'Index' @(n+1)@. 'Index' @k@ has a range --- of @[0 .. k-1]@ (using @ceil(log2(k))@ bits), hence we need 'Index' @n+1@. --- As an initial attempt we will use 'tfold', because it gives a nice (@log2(n)@) --- tree-structure of adders: --- --- @ --- populationCount :: (KnownNat (2^d), KnownNat d, KnownNat (2^d+1)) --- => BitVector (2^d) -> Index (2^d+1) --- populationCount = tfold fromIntegral (+) . v2t . bv2v --- @ --- --- The \"problem\" with this description is that all adders have the same --- bit-width, i.e. all adders are of the type: --- --- @ --- (+) :: 'Index' (2^d+1) -> 'Index' (2^d+1) -> 'Index' (2^d+1). --- @ --- --- This is a \"problem\" because we could have a more efficient structure: --- one where each layer of adders is /precisely/ wide enough to count the number --- of bits at that layer. That is, at height /d/ we want the adder to be of --- type: --- --- @ --- 'Index' ((2^d)+1) -> 'Index' ((2^d)+1) -> 'Index' ((2^(d+1))+1) --- @ --- --- We have such an adder in the form of the 'CLaSH.Class.Num.plus' function, as --- defined in the instance 'CLaSH.Class.Num.ExtendingNum' instance of 'Index'. --- However, we cannot simply use 'fold' to create a tree-structure of --- 'CLaSH.Class.Num.plus'es: --- --- >>> :{ --- let populationCount' :: (KnownNat (2^d), KnownNat d, KnownNat (2^d+1)) --- => BitVector (2^d) -> Index (2^d+1) --- populationCount' = tfold fromIntegral plus . v2t . bv2v --- :} --- --- :... --- • Couldn't match type ‘(((2 ^ d) + 1) + ((2 ^ d) + 1)) - 1’ --- with ‘(2 ^ d) + 1’ --- Expected type: Index ((2 ^ d) + 1) --- -> Index ((2 ^ d) + 1) -> Index ((2 ^ d) + 1) --- Actual type: Index ((2 ^ d) + 1) --- -> Index ((2 ^ d) + 1) --- -> AResult (Index ((2 ^ d) + 1)) (Index ((2 ^ d) + 1)) --- • In the second argument of ‘tfold’, namely ‘plus’ --- In the first argument of ‘(.)’, namely ‘tfold fromIntegral plus’ --- In the expression: tfold fromIntegral plus . v2t . bv2v --- • Relevant bindings include --- populationCount' :: BitVector (2 ^ d) -> Index ((2 ^ d) + 1) --- (bound at ...) --- --- because 'tfold' expects a function of type \"@b -> b -> b@\", i.e. a function --- where the arguments and result all have exactly the same type. --- --- In order to accommodate the type of our 'CLaSH.Class.Num.plus', where the --- result is larger than the arguments, we must use a dependently typed fold in --- the the form of 'dtfold': --- --- @ --- {\-\# LANGUAGE UndecidableInstances \#-\} --- import Data.Singletons.Prelude --- import Data.Proxy --- --- data IIndex (f :: 'TyFun' Nat *) :: * --- type instance 'Apply' IIndex l = 'Index' ((2^l)+1) --- --- populationCount' :: (KnownNat k, KnownNat (2^k)) --- => BitVector (2^k) -> Index ((2^k)+1) --- populationCount' bv = 'tdfold' (Proxy @IIndex) --- fromIntegral --- (\\_ x y -> 'CLaSH.Class.Num.plus' x y) --- ('v2t' ('CLaSH.Sized.Vector.bv2v' bv)) --- @ --- --- And we can test that it works: --- --- >>> :t populationCount' (7 :: BitVector 16) --- populationCount' (7 :: BitVector 16) :: Index 17 --- >>> populationCount' (7 :: BitVector 16) --- 3 -tdfold :: forall p k a . KnownNat k - => Proxy (p :: TyFun Nat * -> *) -- ^ The /motive/ - -> (a -> (p @@ 0)) -- ^ Function to apply to the elements on the leafs - -> (forall l . SNat l -> (p @@ l) -> (p @@ l) -> (p @@ (l+1))) - -- ^ Function to fold the branches with. - -- - -- __NB:__ @SNat l@ is the depth of the two sub-branches. - -> RTree k a -- ^ Tree to fold over. - -> (p @@ k) -tdfold _ f g = go SNat - where - go :: SNat m -> RTree m a -> (p @@ m) - go _ (LR_ a) = f a - go sn (BR_ l r) = let sn' = sn `subSNat` d1 - in g sn' (go sn' l) (go sn' r) -{-# NOINLINE tdfold #-} - -data TfoldTree (a :: *) (f :: TyFun Nat *) :: * -type instance Apply (TfoldTree a) d = a - --- | Reduce a tree to a single element -tfold :: forall d a b . - KnownNat d - => (a -> b) -- ^ Function to apply to the leaves - -> (b -> b -> b) -- ^ Function to combine the results of the reduction - -- of two branches - -> RTree d a -- ^ Tree to fold reduce - -> b -tfold f g = tdfold (Proxy @(TfoldTree b)) f (const g) - --- | \"'treplicate' @d a@\" returns a tree of depth /d/, and has /2^d/ copies --- of /a/. --- --- >>> treplicate (SNat :: SNat 3) 6 --- <<<6,6>,<6,6>>,<<6,6>,<6,6>>> --- >>> treplicate d3 6 --- <<<6,6>,<6,6>>,<<6,6>,<6,6>>> -treplicate :: forall d a . SNat d -> a -> RTree d a -treplicate sn a = go (toUNat sn) - where - go :: UNat n -> RTree n a - go UZero = LR a - go (USucc un) = BR (go un) (go un) -{-# NOINLINE treplicate #-} - --- | \"'trepeat' @a@\" creates a tree with as many copies of /a/ as demanded by --- the context. --- --- >>> trepeat 6 :: RTree 2 Int --- <<6,6>,<6,6>> -trepeat :: KnownNat d => a -> RTree d a -trepeat = treplicate SNat - -data MapTree (a :: *) (f :: TyFun Nat *) :: * -type instance Apply (MapTree a) d = RTree d a - --- | \"'tmap' @f t@\" is the tree obtained by apply /f/ to each element of /t/, --- i.e., --- --- > tmap f (BR (LR a) (LR b)) == BR (LR (f a)) (LR (f b)) -tmap :: forall d a b . KnownNat d => (a -> b) -> RTree d a -> RTree d b -tmap f = tdfold (Proxy @(MapTree b)) (LR . f) (\_ l r -> BR l r) - --- | Generate a tree of indices, where the depth of the tree is determined by --- the context. --- --- >>> tindices :: RTree 3 (Index 8) --- <<<0,1>,<2,3>>,<<4,5>,<6,7>>> -tindices :: forall d . KnownNat d => RTree d (Index (2^d)) -tindices = - tdfold (Proxy @(MapTree (Index (2^d)))) LR - (\s@SNat l r -> BR l (tmap (+(snatToNum (pow2SNat s))) r)) - (treplicate SNat 0) - -data V2TTree (a :: *) (f :: TyFun Nat *) :: * -type instance Apply (V2TTree a) d = RTree d a - --- | Convert a vector with /2^d/ elements to a tree of depth /d/. --- --- >>> (1:>2:>3:>4:>Nil) --- <1,2,3,4> --- >>> v2t (1:>2:>3:>4:>Nil) --- <<1,2>,<3,4>> -v2t :: forall d a . KnownNat d => Vec (2^d) a -> RTree d a -v2t = dtfold (Proxy @(V2TTree a)) LR (const BR) - -data T2VTree (a :: *) (f :: TyFun Nat *) :: * -type instance Apply (T2VTree a) d = Vec (2^d) a - --- | Convert a tree of depth /d/ to a vector of /2^d/ elements --- --- >>> (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4))) --- <<1,2>,<3,4>> --- >>> t2v (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4))) --- <1,2,3,4> -t2v :: forall d a . KnownNat d => RTree d a -> Vec (2^d) a -t2v = tdfold (Proxy @(T2VTree a)) (:> Nil) (\_ l r -> l ++ r) - --- | \"'indexTree' @t n@\" returns the /n/'th element of /t/. --- --- The bottom-left leaf had index /0/, and the bottom-right leaf has index --- /2^d-1/, where /d/ is the depth of the tree --- --- >>> indexTree (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4))) 0 --- 1 --- >>> indexTree (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4))) 2 --- 3 --- >>> indexTree (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4))) 14 --- *** Exception: CLaSH.Sized.Vector.(!!): index 14 is larger than maximum index 3 --- ... -indexTree :: (KnownNat d, Enum i) => RTree d a -> i -> a -indexTree t i = (t2v t) !! i - --- | \"'replaceTree' @n a t@\" returns the tree /t/ where the /n/'th element is --- replaced by /a/. --- --- The bottom-left leaf had index /0/, and the bottom-right leaf has index --- /2^d-1/, where /d/ is the depth of the tree --- --- >>> replaceTree 0 5 (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4))) --- <<5,2>,<3,4>> --- >>> replaceTree 2 7 (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4))) --- <<1,2>,<7,4>> --- >>> replaceTree 9 6 (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4))) --- <<1,2>,<3,*** Exception: CLaSH.Sized.Vector.replace: index 9 is larger than maximum index 3 --- ... -replaceTree :: (KnownNat d, Enum i) => i -> a -> RTree d a -> RTree d a -replaceTree i a = v2t . replace i a . t2v - -data ZipWithTree (b :: *) (c :: *) (f :: TyFun Nat *) :: * -type instance Apply (ZipWithTree b c) d = RTree d b -> RTree d c - --- | 'tzipWith' generalises 'tzip' by zipping with the function given as the --- first argument, instead of a tupling function. For example, "tzipWith (+)" --- applied to two trees produces the tree of corresponding sums. --- --- > tzipWith f (BR (LR a1) (LR b1)) (BR (LR a2) (LR b2)) == BR (LR (f a1 a2)) (LR (f b1 b2)) -tzipWith :: forall a b c d . KnownNat d => (a -> b -> c) -> RTree d a -> RTree d b -> RTree d c -tzipWith f = tdfold (Proxy @(ZipWithTree b c)) lr br - where - lr :: a -> RTree 0 b -> RTree 0 c - lr a (LR b) = LR (f a b) - lr _ _ = error "impossible" - - br :: SNat l - -> (RTree l b -> RTree l c) - -> (RTree l b -> RTree l c) - -> RTree (l+1) b - -> RTree (l+1) c - br _ fl fr (BR l r) = BR (fl l) (fr r) - br _ _ _ _ = error "impossible" - --- | 'tzip' takes two trees and returns a tree of corresponding pairs. -tzip :: KnownNat d => RTree d a -> RTree d b -> RTree d (a,b) -tzip = tzipWith (,) - -data UnzipTree (a :: *) (b :: *) (f :: TyFun Nat *) :: * -type instance Apply (UnzipTree a b) d = (RTree d a, RTree d b) - --- | 'tunzip' transforms a tree of pairs into a tree of first components and a --- tree of second components. -tunzip :: forall d a b . KnownNat d => RTree d (a,b) -> (RTree d a,RTree d b) -tunzip = tdfold (Proxy @(UnzipTree a b)) lr br - where - lr (a,b) = (LR a,LR b) - - br _ (l1,r1) (l2,r2) = (BR l1 l2, BR r1 r2) - --- | Given a function 'f' that is strict in its /n/th 'RTree' argument, make it --- lazy by applying 'lazyT' to this argument: --- --- > f x0 x1 .. (lazyT xn) .. xn_plus_k -lazyT :: KnownNat d - => RTree d a - -> RTree d a -lazyT = tzipWith (flip const) (trepeat undefined) diff --git a/src/CLaSH/Sized/Signed.hs b/src/CLaSH/Sized/Signed.hs deleted file mode 100644 --- a/src/CLaSH/Sized/Signed.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-| -Copyright : (C) 2013-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij --} - -{-# LANGUAGE Trustworthy #-} - -module CLaSH.Sized.Signed - ( Signed - ) -where - -import CLaSH.Sized.Internal.Signed diff --git a/src/CLaSH/Sized/Unsigned.hs b/src/CLaSH/Sized/Unsigned.hs deleted file mode 100644 --- a/src/CLaSH/Sized/Unsigned.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-| -Copyright : (C) 2013-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij --} - -{-# LANGUAGE Trustworthy #-} - -module CLaSH.Sized.Unsigned - (Unsigned) -where - -import CLaSH.Sized.Internal.Unsigned diff --git a/src/CLaSH/Sized/Vector.hs b/src/CLaSH/Sized/Vector.hs deleted file mode 100644 --- a/src/CLaSH/Sized/Vector.hs +++ /dev/null @@ -1,1992 +0,0 @@ -{-| -Copyright : (C) 2013-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij --} - -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - -{-# LANGUAGE Trustworthy #-} - -{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise -fplugin GHC.TypeLits.KnownNat.Solver #-} -{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-redundant-constraints #-} - -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Sized.Vector - ( -- * 'Vec'tor data type - Vec(Nil,(:>),(:<)) - -- * Accessors - -- ** Length information - , length, maxIndex, lengthS - -- ** Indexing - , (!!), head, last, at - , indices, indicesI - , findIndex, elemIndex - -- ** Extracting sub-vectors (slicing) - , tail, init - , take, takeI, drop, dropI - , select, selectI - -- *** Splitting - , splitAt, splitAtI - , unconcat, unconcatI - -- * Construction - -- ** Initialisation - , singleton - , replicate, replicateI, repeat - , iterate, iterateI, generate, generateI - -- *** Initialisation from a list - , listToVecTH, v - -- ** Concatenation - , (++), (+>>), (<<+), concat - , shiftInAt0, shiftInAtN , shiftOutFrom0, shiftOutFromN - , merge - -- * Modifying vectors - , replace - -- ** Permutations - , permute, backpermute, scatter, gather - -- *** Specialised permutations - , reverse, transpose, interleave - , rotateLeft, rotateRight, rotateLeftS, rotateRightS - -- * Element-wise operations - -- ** Mapping - , map, imap, smap - -- ** Zipping - , zipWith, zipWith3 - , zip, zip3 - , izipWith - -- ** Unzipping - , unzip, unzip3 - -- * Folding - , foldr, foldl, foldr1, foldl1, fold - , ifoldr, ifoldl - -- ** Specialised folds - , dfold, dtfold, vfold - -- * Prefix sums (scans) - , scanl, scanr, postscanl, postscanr - , mapAccumL, mapAccumR - -- * Stencil computations - , stencil1d, stencil2d - , windows1d, windows2d - -- * Conversions - , toList - , bv2v - , v2bv - -- * Misc - , lazyV, VCons, asNatProxy - -- * Primitives - -- ** 'Traversable' instance - , traverse# - -- ** 'BitPack' instance - , concatBitVector# - , unconcatBitVector# - ) -where - -import Control.DeepSeq (NFData (..)) -import qualified Control.Lens as Lens hiding (pattern (:>), pattern (:<)) -import Data.Default (Default (..)) -import qualified Data.Foldable as F -import Data.Proxy (Proxy (..)) -import Data.Singletons.Prelude (TyFun,Apply,type (@@)) -import GHC.TypeLits (CmpNat, KnownNat, Nat, type (+), type (-), type (*), - type (^), natVal) -import GHC.Base (Int(I#),Int#,isTrue#) -import GHC.Prim ((==#),(<#),(-#)) -import Language.Haskell.TH (ExpQ) -import Language.Haskell.TH.Syntax (Lift(..)) -import Prelude hiding ((++), (!!), concat, drop, foldl, - foldl1, foldr, foldr1, head, init, - iterate, last, length, map, repeat, - replicate, reverse, scanl, scanr, - splitAt, tail, take, unzip, unzip3, - zip, zip3, zipWith, zipWith3) -import qualified Prelude as P -import Test.QuickCheck (Arbitrary (..), CoArbitrary (..)) -import Unsafe.Coerce (unsafeCoerce) - -import CLaSH.Promoted.Nat (SNat (..), UNat (..), pow2SNat, snatProxy, - snatToInteger, subSNat, withSNat, toUNat) -import CLaSH.Promoted.Nat.Literals (d1) -import CLaSH.Sized.Internal.BitVector (Bit, BitVector, (++#), split#) -import CLaSH.Sized.Index (Index) - -import CLaSH.Class.BitPack (BitPack (..)) -import CLaSH.XException (ShowX (..), showsX, showsPrecXWith) - -{- $setup ->>> :set -XDataKinds ->>> :set -XTypeFamilies ->>> :set -XTypeOperators ->>> :set -XTemplateHaskell ->>> :set -XFlexibleContexts ->>> :set -XTypeApplications ->>> :set -fplugin GHC.TypeLits.Normalise ->>> import CLaSH.Prelude ->>> let compareSwapL a b = if a < b then (a,b) else (b,a) ->>> :{ -let sortV xs = map fst sorted :< (snd (last sorted)) - where - lefts = head xs :> map snd (init sorted) - rights = tail xs - sorted = zipWith compareSwapL lefts rights -:} - ->>> :{ -let sortVL xs = map fst sorted :< (snd (last sorted)) - where - lefts = head xs :> map snd (init sorted) - rights = tail xs - sorted = zipWith compareSwapL (lazyV lefts) rights -:} - ->>> :{ -let sortV_flip xs = map fst sorted :< (snd (last sorted)) - where - lefts = head xs :> map snd (init sorted) - rights = tail xs - sorted = zipWith (flip compareSwapL) rights lefts -:} - ->>> data Append (m :: Nat) (a :: *) (f :: TyFun Nat *) :: * ->>> type instance Apply (Append m a) l = Vec (l + m) a ->>> let append' xs ys = dfold (Proxy :: Proxy (Append m a)) (const (:>)) ys xs ->>> let compareSwap a b = if a > b then (a,b) else (b,a) ->>> let insert y xs = let (y',xs') = mapAccumL compareSwap y xs in xs' :< y' ->>> let insertionSort = vfold (const insert) ->>> data IIndex (f :: TyFun Nat *) :: * ->>> :set -XUndecidableInstances ->>> type instance Apply IIndex l = Index ((2^l)+1) ->>> :{ -let populationCount' :: (KnownNat k, KnownNat (2^k)) => BitVector (2^k) -> Index ((2^k)+1) - populationCount' bv = dtfold (Proxy @IIndex) - fromIntegral - (\_ x y -> plus x y) - (bv2v bv) -:} - --} - -infixr 5 `Cons` --- | Fixed size vectors. --- --- * Lists with their length encoded in their type --- * 'Vec'tor elements have an __ASCENDING__ subscript starting from 0 and --- ending at @'length' - 1@. -data Vec :: Nat -> * -> * where - Nil :: Vec 0 a - Cons :: a -> Vec n a -> Vec (n + 1) a - -instance NFData a => NFData (Vec n a) where - rnf Nil = () - rnf (Cons x xs) = rnf x `seq` rnf xs - --- | Add an element to the head of a vector. --- --- >>> 3:>4:>5:>Nil --- <3,4,5> --- >>> let x = 3:>4:>5:>Nil --- >>> :t x --- x :: Num a => Vec 3 a --- --- Can be used as a pattern: --- --- >>> let f (x :> y :> _) = x + y --- >>> :t f --- f :: Num a => Vec ((n + 1) + 1) a -> a --- >>> f (3:>4:>5:>6:>7:>Nil) --- 7 --- --- Also in conjunctions with (':<'): --- --- >>> let g (a :> b :> (_ :< y :< x)) = a + b + x + y --- >>> :t g --- g :: Num a => Vec ((((n + 1) + 1) + 1) + 1) a -> a --- >>> g (1:>2:>3:>4:>5:>Nil) --- 12 -pattern (:>) :: a -> Vec n a -> Vec (n + 1) a -pattern (:>) x xs <- ((\ys -> (head ys,tail ys)) -> (x,xs)) - where - (:>) x xs = Cons x xs - -infixr 5 :> - -instance Show a => Show (Vec n a) where - showsPrec _ vs = \s -> '<':punc vs ('>':s) - where - punc :: Vec m a -> ShowS - punc Nil = id - punc (x `Cons` Nil) = shows x - punc (x `Cons` xs) = \s -> shows x (',':punc xs s) - -instance ShowX a => ShowX (Vec n a) where - showsPrecX = showsPrecXWith go - where - go _ vs = \s -> '<': punc vs ('>':s) - where - punc :: Vec m a -> ShowS - punc Nil = id - punc (x `Cons` Nil) = showsX x - punc (x `Cons` xs) = \s -> showsX x (',':punc xs s) - -instance (KnownNat n, Eq a) => Eq (Vec n a) where - (==) v1 v2 - | length v1 == 0 = True - | otherwise = fold @Bool @n (&&) (unsafeCoerce (zipWith (==) v1 v2)) - -- FIXME: the `unsafeCoerce` is a hack because the CLaSH compiler cannot deal - -- with the existential length of the 'xs' in "Cons x xs". - -- - -- Ideally we would write: - -- - -- (==) Nil _ = True - -- (==) v1@(Cons _ _) v2 = fold (&&) (zipWith (==) v1 v2) - -- - -- But the CLaSH compiler currently fails on that definition. - -instance (KnownNat n, Ord a) => Ord (Vec n a) where - compare x y = foldr f EQ $ zipWith compare x y - where f EQ keepGoing = keepGoing - f done _ = done - -instance KnownNat n => Applicative (Vec n) where - pure = repeat - fs <*> xs = zipWith ($) fs xs - -instance (KnownNat m, m ~ (n+1)) => F.Foldable (Vec m) where - fold = fold mappend - foldMap f = fold mappend . map f - foldr = foldr - foldl = foldl - foldr1 = foldr1 - foldl1 = foldl1 - toList = toList - null _ = False - length = length - maximum = fold (\x y -> if x >= y then x else y) - minimum = fold (\x y -> if x <= y then x else y) - sum = fold (+) - product = fold (*) - -instance Functor (Vec n) where - fmap = map - -instance (KnownNat m, m ~ (n+1)) => Traversable (Vec m) where - traverse = traverse# - -{-# NOINLINE traverse# #-} -traverse# :: forall a f b n . Applicative f => (a -> f b) -> Vec n a -> f (Vec n b) -traverse# _ Nil = pure Nil -traverse# f (x `Cons` xs) = Cons <$> f x <*> traverse# f xs - -instance (Default a, KnownNat n) => Default (Vec n a) where - def = repeat def - -{-# INLINE singleton #-} --- | Create a vector of one element --- --- >>> singleton 5 --- <5> -singleton :: a -> Vec 1 a -singleton = (`Cons` Nil) - -{-# NOINLINE head #-} --- | Extract the first element of a vector --- --- >>> head (1:>2:>3:>Nil) --- 1 --- >>> head Nil --- --- :... --- • Couldn't match type ‘1’ with ‘0’ --- Expected type: Vec (0 + 1) a --- Actual type: Vec 0 a --- • In the first argument of ‘head’, namely ‘Nil’ --- In the expression: head Nil --- In an equation for ‘it’: it = head Nil -head :: Vec (n + 1) a -> a -head (x `Cons` _) = x - -{-# NOINLINE tail #-} --- | Extract the elements after the head of a vector --- --- >>> tail (1:>2:>3:>Nil) --- <2,3> --- >>> tail Nil --- --- :... --- • Couldn't match type ‘1’ with ‘0’ --- Expected type: Vec (0 + 1) a --- Actual type: Vec 0 a --- • In the first argument of ‘tail’, namely ‘Nil’ --- In the expression: tail Nil --- In an equation for ‘it’: it = tail Nil -tail :: Vec (n + 1) a -> Vec n a -tail (_ `Cons` xs) = xs - -{-# NOINLINE last #-} --- | Extract the last element of a vector --- --- >>> last (1:>2:>3:>Nil) --- 3 --- >>> last Nil --- --- :... --- • Couldn't match type ‘1’ with ‘0’ --- Expected type: Vec (0 + 1) a --- Actual type: Vec 0 a --- • In the first argument of ‘last’, namely ‘Nil’ --- In the expression: last Nil --- In an equation for ‘it’: it = last Nil -last :: Vec (n + 1) a -> a -last (x `Cons` Nil) = x -last (_ `Cons` y `Cons` ys) = last (y `Cons` ys) - -{-# NOINLINE init #-} --- | Extract all the elements of a vector except the last element --- --- >>> init (1:>2:>3:>Nil) --- <1,2> --- >>> init Nil --- --- :... --- • Couldn't match type ‘1’ with ‘0’ --- Expected type: Vec (0 + 1) a --- Actual type: Vec 0 a --- • In the first argument of ‘init’, namely ‘Nil’ --- In the expression: init Nil --- In an equation for ‘it’: it = init Nil -init :: Vec (n + 1) a -> Vec n a -init (_ `Cons` Nil) = Nil -init (x `Cons` y `Cons` ys) = x `Cons` init (y `Cons` ys) - -{-# INLINE shiftInAt0 #-} --- | Shift in elements to the head of a vector, bumping out elements at the --- tail. The result is a tuple containing: --- --- * The new vector --- * The shifted out elements --- --- >>> shiftInAt0 (1 :> 2 :> 3 :> 4 :> Nil) ((-1) :> 0 :> Nil) --- (<-1,0,1,2>,<3,4>) --- >>> shiftInAt0 (1 :> Nil) ((-1) :> 0 :> Nil) --- (<-1>,<0,1>) -shiftInAt0 :: KnownNat n - => Vec n a -- ^ The old vector - -> Vec m a -- ^ The elements to shift in at the head - -> (Vec n a, Vec m a) -- ^ (The new vector, shifted out elements) -shiftInAt0 xs ys = splitAtI zs - where - zs = ys ++ xs - -{-# INLINE shiftInAtN #-} --- | Shift in element to the tail of a vector, bumping out elements at the head. --- The result is a tuple containing: --- --- * The new vector --- * The shifted out elements --- --- >>> shiftInAtN (1 :> 2 :> 3 :> 4 :> Nil) (5 :> 6 :> Nil) --- (<3,4,5,6>,<1,2>) --- >>> shiftInAtN (1 :> Nil) (2 :> 3 :> Nil) --- (<3>,<1,2>) -shiftInAtN :: KnownNat m - => Vec n a -- ^ The old vector - -> Vec m a -- ^ The elements to shift in at the tail - -> (Vec n a,Vec m a) -- ^ (The new vector, shifted out elements) -shiftInAtN xs ys = (zsR, zsL) - where - zs = xs ++ ys - (zsL,zsR) = splitAtI zs - -infixl 5 :< --- | Add an element to the tail of a vector. --- --- >>> (3:>4:>5:>Nil) :< 1 --- <3,4,5,1> --- >>> let x = (3:>4:>5:>Nil) :< 1 --- >>> :t x --- x :: Num a => Vec 4 a --- --- Can be used as a pattern: --- --- >>> let f (_ :< y :< x) = y + x --- >>> :t f --- f :: Num a => Vec ((n + 1) + 1) a -> a --- >>> f (3:>4:>5:>6:>7:>Nil) --- 13 --- --- Also in conjunctions with (':>'): --- --- >>> let g (a :> b :> (_ :< y :< x)) = a + b + x + y --- >>> :t g --- g :: Num a => Vec ((((n + 1) + 1) + 1) + 1) a -> a --- >>> g (1:>2:>3:>4:>5:>Nil) --- 12 -pattern (:<) :: Vec n a -> a -> Vec (n+1) a -pattern (:<) xs x <- ((\ys -> (init ys,last ys)) -> (xs,x)) - where - (:<) xs x = xs ++ singleton x - -infixr 4 +>> --- | Add an element to the head of a vector, and extract all but the last --- element. --- --- >>> 1 +>> (3:>4:>5:>Nil) --- <1,3,4> --- >>> 1 +>> Nil --- <> -(+>>) :: KnownNat n => a -> Vec n a -> Vec n a -s +>> xs = fst (shiftInAt0 xs (singleton s)) -{-# INLINE (+>>) #-} - - -infixl 4 <<+ --- | Add an element to the tail of a vector, and extract all but the first --- element. --- --- >>> (3:>4:>5:>Nil) <<+ 1 --- <4,5,1> --- >>> Nil <<+ 1 --- <> -(<<+) :: Vec n a -> a -> Vec n a -xs <<+ s = fst (shiftInAtN xs (singleton s)) -{-# INLINE (<<+) #-} - --- | Shift /m/ elements out from the head of a vector, filling up the tail with --- 'Default' values. The result is a tuple containing: --- --- * The new vector --- * The shifted out values --- --- >>> shiftOutFrom0 d2 ((1 :> 2 :> 3 :> 4 :> 5 :> Nil) :: Vec 5 Integer) --- (<3,4,5,0,0>,<1,2>) -shiftOutFrom0 :: (Default a, KnownNat m) - => SNat m -- ^ @m@, the number of elements to shift out - -> Vec (m + n) a -- ^ The old vector - -> (Vec (m + n) a, Vec m a) - -- ^ (The new vector, shifted out elements) -shiftOutFrom0 m xs = shiftInAtN xs (replicate m def) -{-# INLINE shiftOutFrom0 #-} - --- | Shift /m/ elements out from the tail of a vector, filling up the head with --- 'Default' values. The result is a tuple containing: --- --- * The new vector --- * The shifted out values --- --- >>> shiftOutFromN d2 ((1 :> 2 :> 3 :> 4 :> 5 :> Nil) :: Vec 5 Integer) --- (<0,0,1,2,3>,<4,5>) -shiftOutFromN :: (Default a, KnownNat n) - => SNat m -- ^ @m@, the number of elements to shift out - -> Vec (m + n) a -- ^ The old vector - -> (Vec (m + n) a, Vec m a) - -- ^ (The new vector, shifted out elements) -shiftOutFromN m@SNat xs = shiftInAt0 xs (replicate m def) -{-# INLINE shiftOutFromN #-} - -infixr 5 ++ --- | Append two vectors. --- --- >>> (1:>2:>3:>Nil) ++ (7:>8:>Nil) --- <1,2,3,7,8> -(++) :: Vec n a -> Vec m a -> Vec (n + m) a -Nil ++ ys = ys -(x `Cons` xs) ++ ys = x `Cons` xs ++ ys -{-# NOINLINE (++) #-} - --- | Split a vector into two vectors at the given point. --- --- >>> splitAt (SNat :: SNat 3) (1:>2:>3:>7:>8:>Nil) --- (<1,2,3>,<7,8>) --- >>> splitAt d3 (1:>2:>3:>7:>8:>Nil) --- (<1,2,3>,<7,8>) -splitAt :: SNat m -> Vec (m + n) a -> (Vec m a, Vec n a) -splitAt n xs = splitAtU (toUNat n) xs -{-# NOINLINE splitAt #-} - -splitAtU :: UNat m -> Vec (m + n) a -> (Vec m a, Vec n a) -splitAtU UZero ys = (Nil,ys) -splitAtU (USucc s) (y `Cons` ys) = let (as,bs) = splitAtU s ys - in (y `Cons` as, bs) - --- | Split a vector into two vectors where the length of the two is determined --- by the context. --- --- >>> splitAtI (1:>2:>3:>7:>8:>Nil) :: (Vec 2 Int, Vec 3 Int) --- (<1,2>,<3,7,8>) -splitAtI :: KnownNat m => Vec (m + n) a -> (Vec m a, Vec n a) -splitAtI = withSNat splitAt -{-# INLINE splitAtI #-} - --- | Concatenate a vector of vectors. --- --- >>> concat ((1:>2:>3:>Nil) :> (4:>5:>6:>Nil) :> (7:>8:>9:>Nil) :> (10:>11:>12:>Nil) :> Nil) --- <1,2,3,4,5,6,7,8,9,10,11,12> -concat :: Vec n (Vec m a) -> Vec (n * m) a -concat Nil = Nil -concat (x `Cons` xs) = x ++ concat xs -{-# NOINLINE concat #-} - --- | Split a vector of \(n * m)\ elements into a vector of \"vectors of length --- /m/\", where the length /m/ is given. --- --- >>> unconcat d4 (1:>2:>3:>4:>5:>6:>7:>8:>9:>10:>11:>12:>Nil) --- <<1,2,3,4>,<5,6,7,8>,<9,10,11,12>> -unconcat :: KnownNat n => SNat m -> Vec (n * m) a -> Vec n (Vec m a) -unconcat n xs = unconcatU (withSNat toUNat) (toUNat n) xs -{-# NOINLINE unconcat #-} - -unconcatU :: UNat n -> UNat m -> Vec (n * m) a -> Vec n (Vec m a) -unconcatU UZero _ _ = Nil -unconcatU (USucc n') m ys = let (as,bs) = splitAtU m ys - in as `Cons` unconcatU n' m bs - --- | Split a vector of /(n * m)/ elements into a vector of \"vectors of length --- /m/\", where the length /m/ is determined by the context. --- --- >>> unconcatI (1:>2:>3:>4:>5:>6:>7:>8:>9:>10:>11:>12:>Nil) :: Vec 2 (Vec 6 Int) --- <<1,2,3,4,5,6>,<7,8,9,10,11,12>> -unconcatI :: (KnownNat n, KnownNat m) => Vec (n * m) a -> Vec n (Vec m a) -unconcatI = withSNat unconcat -{-# INLINE unconcatI #-} - --- | Merge two vectors, alternating their elements, i.e., --- --- >>> merge (1 :> 2 :> 3 :> 4 :> Nil) (5 :> 6 :> 7 :> 8 :> Nil) --- <1,5,2,6,3,7,4,8> -merge :: KnownNat n => Vec n a -> Vec n a -> Vec (2 * n) a -merge x y = concat (transpose (x :> singleton y)) -{-# INLINE merge #-} - --- | The elements in a vector in reverse order. --- --- >>> reverse (1:>2:>3:>4:>Nil) --- <4,3,2,1> -reverse :: Vec n a -> Vec n a -reverse Nil = Nil -reverse (x `Cons` xs) = reverse xs :< x -{-# NOINLINE reverse #-} - --- | \"'map' @f xs@\" is the vector obtained by applying /f/ to each element --- of /xs/, i.e., --- --- > map f (x1 :> x2 :> ... :> xn :> Nil) == (f x1 :> f x2 :> ... :> f xn :> Nil) --- --- and corresponds to the following circuit layout: --- --- <> -map :: (a -> b) -> Vec n a -> Vec n b -map _ Nil = Nil -map f (x `Cons` xs) = f x `Cons` map f xs -{-# NOINLINE map #-} - --- | Apply a function of every element of a vector and its index. --- --- >>> :t imap (+) (2 :> 2 :> 2 :> 2 :> Nil) --- imap (+) (2 :> 2 :> 2 :> 2 :> Nil) :: Vec 4 (Index 4) --- >>> imap (+) (2 :> 2 :> 2 :> 2 :> Nil) --- <2,3,*** Exception: CLaSH.Sized.Index: result 4 is out of bounds: [0..3] --- ... --- >>> imap (\i a -> fromIntegral i + a) (2 :> 2 :> 2 :> 2 :> Nil) :: Vec 4 (Unsigned 8) --- <2,3,4,5> --- --- \"'imap' @f xs@\" corresponds to the following circuit layout: --- --- <> -imap :: forall n a b . KnownNat n => (Index n -> a -> b) -> Vec n a -> Vec n b -imap f = go 0 - where - go :: Index n -> Vec m a -> Vec m b - go _ Nil = Nil - go n (x `Cons` xs) = f n x `Cons` go (n+1) xs -{-# NOINLINE imap #-} - --- | Zip two vectors with a functions that also takes the elements' indices. --- --- >>> izipWith (\i a b -> i + a + b) (2 :> 2 :> Nil) (3 :> 3:> Nil) --- <*** Exception: CLaSH.Sized.Index: result 3 is out of bounds: [0..1] --- ... --- >>> izipWith (\i a b -> fromIntegral i + a + b) (2 :> 2 :> Nil) (3 :> 3 :> Nil) :: Vec 2 (Unsigned 8) --- <5,6> --- --- \"'imap' @f xs@\" corresponds to the following circuit layout: --- --- <> --- --- __NB:__ 'izipWith' is /strict/ in its second argument, and /lazy/ in its --- third. This matters when 'izipWith' is used in a recursive setting. See --- 'lazyV' for more information. -izipWith :: KnownNat n => (Index n -> a -> b -> c) -> Vec n a -> Vec n b - -> Vec n c -izipWith f xs ys = imap (\i -> uncurry (f i)) (zip xs ys) -{-# INLINE izipWith #-} - --- | Right fold (function applied to each element and its index) --- --- >>> let findLeftmost x xs = ifoldr (\i a b -> if a == x then Just i else b) Nothing xs --- >>> findLeftmost 3 (1:>3:>2:>4:>3:>5:>6:>Nil) --- Just 1 --- >>> findLeftmost 8 (1:>3:>2:>4:>3:>5:>6:>Nil) --- Nothing --- --- \"'ifoldr' @f z xs@\" corresponds to the following circuit layout: --- --- <> -ifoldr :: KnownNat n => (Index n -> a -> b -> b) -> b -> Vec n a -> b -ifoldr f z xs = head ws - where - ws = izipWith f xs ((tail ws)) :< z -{-# INLINE ifoldr #-} - --- | Left fold (function applied to each element and its index) --- --- >>> let findRightmost x xs = ifoldl (\a i b -> if b == x then Just i else a) Nothing xs --- >>> findRightmost 3 (1:>3:>2:>4:>3:>5:>6:>Nil) --- Just 4 --- >>> findRightmost 8 (1:>3:>2:>4:>3:>5:>6:>Nil) --- Nothing --- --- \"'ifoldl' @f z xs@\" corresponds to the following circuit layout: --- --- <> -ifoldl :: KnownNat n => (a -> Index n -> b -> a) -> a -> Vec n b -> a -ifoldl f z xs = last ws - where - ws = z `Cons` izipWith (\i b a -> f a i b) xs (init ws) -{-# INLINE ifoldl #-} - --- | Generate a vector of indices. --- --- >>> indices d4 --- <0,1,2,3> -indices :: KnownNat n => SNat n -> Vec n (Index n) -indices _ = indicesI -{-# INLINE indices #-} - --- | Generate a vector of indices, where the length of the vector is determined --- by the context. --- --- >>> indicesI :: Vec 4 (Index 4) --- <0,1,2,3> -indicesI :: KnownNat n => Vec n (Index n) -indicesI = imap const (repeat ()) -{-# INLINE indicesI #-} - --- | \"'findIndex' @p xs@\" returns the index of the /first/ element of /xs/ --- satisfying the predicate /p/, or 'Nothing' if there is no such element. --- --- >>> findIndex (> 3) (1:>3:>2:>4:>3:>5:>6:>Nil) --- Just 3 --- >>> findIndex (> 8) (1:>3:>2:>4:>3:>5:>6:>Nil) --- Nothing -findIndex :: KnownNat n => (a -> Bool) -> Vec n a -> Maybe (Index n) -findIndex f = ifoldr (\i a b -> if f a then Just i else b) Nothing -{-# INLINE findIndex #-} - --- | \"'elemIndex' @a xs@\" returns the index of the /first/ element which is --- equal (by '==') to the query element /a/, or 'Nothing' if there is no such --- element. --- --- >>> elemIndex 3 (1:>3:>2:>4:>3:>5:>6:>Nil) --- Just 1 --- >>> elemIndex 8 (1:>3:>2:>4:>3:>5:>6:>Nil) --- Nothing -elemIndex :: (KnownNat n, Eq a) => a -> Vec n a -> Maybe (Index n) -elemIndex x = findIndex (x ==) -{-# INLINE elemIndex #-} - --- | 'zipWith' generalises 'zip' by zipping with the function given --- as the first argument, instead of a tupling function. --- For example, \"'zipWith' @(+)@\" applied to two vectors produces the --- vector of corresponding sums. --- --- > zipWith f (x1 :> x2 :> ... xn :> Nil) (y1 :> y2 :> ... :> yn :> Nil) == (f x1 y1 :> f x2 y2 :> ... :> f xn yn :> Nil) --- --- \"'zipWith' @f xs ys@\" corresponds to the following circuit layout: --- --- <> --- --- __NB:__ 'zipWith' is /strict/ in its second argument, and /lazy/ in its --- third. This matters when 'zipWith' is used in a recursive setting. See --- 'lazyV' for more information. -zipWith :: (a -> b -> c) -> Vec n a -> Vec n b -> Vec n c -zipWith _ Nil _ = Nil -zipWith f (x `Cons` xs) ys = f x (head ys) `Cons` zipWith f xs (tail ys) -{-# NOINLINE zipWith #-} - --- | 'zipWith3' generalises 'zip3' by zipping with the function given --- as the first argument, instead of a tupling function. --- --- > zipWith3 f (x1 :> x2 :> ... xn :> Nil) (y1 :> y2 :> ... :> yn :> Nil) (z1 :> z2 :> ... :> zn :> Nil) == (f x1 y1 z1 :> f x2 y2 z2 :> ... :> f xn yn zn :> Nil) --- --- \"'zipWith3' @f xs ys zs@\" corresponds to the following circuit layout: --- --- <> --- --- __NB:__ 'zipWith3' is /strict/ in its second argument, and /lazy/ in its --- third and fourth. This matters when 'zipWith3' is used in a recursive setting. --- See 'lazyV' for more information. -zipWith3 :: (a -> b -> c -> d) -> Vec n a -> Vec n b -> Vec n c -> Vec n d -zipWith3 f us vs ws = zipWith (\a (b,c) -> f a b c) us (zip vs ws) -{-# INLINE zipWith3 #-} - --- | 'foldr', applied to a binary operator, a starting value (typically --- the right-identity of the operator), and a vector, reduces the vector --- using the binary operator, from right to left: --- --- > foldr f z (x1 :> ... :> xn1 :> xn :> Nil) == x1 `f` (... (xn1 `f` (xn `f` z))...) --- > foldr r z Nil == z --- --- >>> foldr (/) 1 (5 :> 4 :> 3 :> 2 :> Nil) --- 1.875 --- --- \"'foldr' @f z xs@\" corresponds to the following circuit layout: --- --- <> --- --- __NB__: @"'foldr' f z xs"@ produces a linear structure, which has a depth, or --- delay, of O(@'length' xs@). Use 'fold' if your binary operator @f@ is --- associative, as @"'fold' f xs"@ produces a structure with a depth of --- O(log_2(@'length' xs@)). -foldr :: (a -> b -> b) -> b -> Vec n a -> b -foldr _ z Nil = z -foldr f z (x `Cons` xs) = f x (foldr f z xs) -{-# NOINLINE foldr #-} - --- | 'foldl', applied to a binary operator, a starting value (typically --- the left-identity of the operator), and a vector, reduces the vector --- using the binary operator, from left to right: --- --- > foldl f z (x1 :> x2 :> ... :> xn :> Nil) == (...((z `f` x1) `f` x2) `f`...) `f` xn --- > foldl f z Nil == z --- --- >>> foldl (/) 1 (5 :> 4 :> 3 :> 2 :> Nil) --- 8.333333333333333e-3 --- --- \"'foldl' @f z xs@\" corresponds to the following circuit layout: --- --- <> --- --- __NB__: @"'foldl' f z xs"@ produces a linear structure, which has a depth, or --- delay, of O(@'length' xs@). Use 'fold' if your binary operator @f@ is --- associative, as @"'fold' f xs"@ produces a structure with a depth of --- O(log_2(@'length' xs@)). -foldl :: (b -> a -> b) -> b -> Vec n a -> b -foldl f z xs = last (scanl f z xs) -{-# INLINE foldl #-} - --- | 'foldr1' is a variant of 'foldr' that has no starting value argument, --- and thus must be applied to non-empty vectors. --- --- > foldr1 f (x1 :> ... :> xn2 :> xn1 :> xn :> Nil) == x1 `f` (... (xn2 `f` (xn1 `f` xn))...) --- > foldr1 f (x1 :> Nil) == x1 --- > foldr1 f Nil == TYPE ERROR --- --- >>> foldr1 (/) (5 :> 4 :> 3 :> 2 :> 1 :> Nil) --- 1.875 --- --- \"'foldr1' @f xs@\" corresponds to the following circuit layout: --- --- <> --- --- __NB__: @"'foldr1' f z xs"@ produces a linear structure, which has a depth, --- or delay, of O(@'length' xs@). Use 'fold' if your binary operator @f@ is --- associative, as @"'fold' f xs"@ produces a structure with a depth of --- O(log_2(@'length' xs@)). -foldr1 :: (a -> a -> a) -> Vec (n + 1) a -> a -foldr1 f xs = foldr f (last xs) (init xs) -{-# INLINE foldr1 #-} - --- | 'foldl1' is a variant of 'foldl' that has no starting value argument, --- and thus must be applied to non-empty vectors. --- --- > foldl1 f (x1 :> x2 :> x3 :> ... :> xn :> Nil) == (...((x1 `f` x2) `f` x3) `f`...) `f` xn --- > foldl1 f (x1 :> Nil) == x1 --- > foldl1 f Nil == TYPE ERROR --- --- >>> foldl1 (/) (1 :> 5 :> 4 :> 3 :> 2 :> Nil) --- 8.333333333333333e-3 --- --- \"'foldl1' @f xs@\" corresponds to the following circuit layout: --- --- <> --- --- __NB__: @"'foldl1' f z xs"@ produces a linear structure, which has a depth, --- or delay, of O(@'length' xs@). Use 'fold' if your binary operator @f@ is --- associative, as @"'fold' f xs"@ produces a structure with a depth of --- O(log_2(@'length' xs@)). -foldl1 :: (a -> a -> a) -> Vec (n + 1) a -> a -foldl1 f xs = foldl f (head xs) (tail xs) -{-# INLINE foldl1 #-} - --- | 'fold' is a variant of 'foldr1' and 'foldl1', but instead of reducing from --- right to left, or left to right, it reduces a vector using a tree-like --- structure. The depth, or delay, of the structure produced by --- \"@'fold' f xs@\", is hence @O(log_2('length' xs))@, and not --- @O('length' xs)@. --- --- __NB__: The binary operator \"@f@\" in \"@'fold' f xs@\" must be associative. --- --- > fold f (x1 :> x2 :> ... :> xn1 :> xn :> Nil) == ((x1 `f` x2) `f` ...) `f` (... `f` (xn1 `f` xn)) --- > fold f (x1 :> Nil) == x1 --- > fold f Nil == TYPE ERROR --- --- >>> fold (+) (5 :> 4 :> 3 :> 2 :> 1 :> Nil) --- 15 --- --- \"'fold' @f xs@\" corresponds to the following circuit layout: --- --- <> -fold :: (a -> a -> a) -> Vec (n + 1) a -> a -fold f vs = fold' (toList vs) - where - fold' [x] = x - fold' xs = fold' ys `f` fold' zs - where - (ys,zs) = P.splitAt (P.length xs `div` 2) xs -{-# NOINLINE fold #-} - --- | 'scanl' is similar to 'foldl', but returns a vector of successive reduced --- values from the left: --- --- > scanl f z (x1 :> x2 :> ... :> Nil) == z :> (z `f` x1) :> ((z `f` x1) `f` x2) :> ... :> Nil --- --- >>> scanl (+) 0 (5 :> 4 :> 3 :> 2 :> Nil) --- <0,5,9,12,14> --- --- \"'scanl' @f z xs@\" corresponds to the following circuit layout: --- --- <> --- --- __NB__: --- --- > last (scanl f z xs) == foldl f z xs -scanl :: (b -> a -> b) -> b -> Vec n a -> Vec (n + 1) b -scanl f z xs = ws - where - ws = z `Cons` zipWith (flip f) xs (init ws) -{-# INLINE scanl #-} - --- | 'postscanl' is a variant of 'scanl' where the first result is dropped: --- --- > postscanl f z (x1 :> x2 :> ... :> Nil) == (z `f` x1) :> ((z `f` x1) `f` x2) :> ... :> Nil --- --- >>> postscanl (+) 0 (5 :> 4 :> 3 :> 2 :> Nil) --- <5,9,12,14> --- --- \"'postscanl' @f z xs@\" corresponds to the following circuit layout: --- --- <> -postscanl :: (b -> a -> b) -> b -> Vec n a -> Vec n b -postscanl f z xs = tail (scanl f z xs) -{-# INLINE postscanl #-} - --- | 'scanr' is similar to 'foldr', but returns a vector of successive reduced --- values from the right: --- --- > scanr f z (... :> xn1 :> xn :> Nil) == ... :> (xn1 `f` (xn `f` z)) :> (xn `f` z) :> z :> Nil --- --- >>> scanr (+) 0 (5 :> 4 :> 3 :> 2 :> Nil) --- <14,9,5,2,0> --- --- \"'scanr' @f z xs@\" corresponds to the following circuit layout: --- --- <> --- --- __NB__: --- --- > head (scanr f z xs) == foldr f z xs -scanr :: (a -> b -> b) -> b -> Vec n a -> Vec (n + 1) b -scanr f z xs = ws - where - ws = zipWith f xs ((tail ws)) :< z -{-# INLINE scanr #-} - --- | 'postscanr' is a variant of 'scanr' that where the last result is dropped: --- --- > postscanr f z (... :> xn1 :> xn :> Nil) == ... :> (xn1 `f` (xn `f` z)) :> (xn `f` z) :> Nil --- --- >>> postscanr (+) 0 (5 :> 4 :> 3 :> 2 :> Nil) --- <14,9,5,2> --- --- \"'postscanr' @f z xs@\" corresponds to the following circuit layout: --- --- <> -postscanr :: (a -> b -> b) -> b -> Vec n a -> Vec n b -postscanr f z xs = init (scanr f z xs) -{-# INLINE postscanr #-} - --- | The 'mapAccumL' function behaves like a combination of 'map' and 'foldl'; --- it applies a function to each element of a vector, passing an accumulating --- parameter from left to right, and returning a final value of this accumulator --- together with the new vector. --- --- >>> mapAccumL (\acc x -> (acc + x,acc + 1)) 0 (1 :> 2 :> 3 :> 4 :> Nil) --- (10,<1,2,4,7>) --- --- \"'mapAccumL' @f acc xs@\" corresponds to the following circuit layout: --- --- <> -mapAccumL :: (acc -> x -> (acc,y)) -> acc -> Vec n x -> (acc,Vec n y) -mapAccumL f acc xs = (acc',ys) - where - accs = acc `Cons` accs' - ws = zipWith (flip f) xs (init accs) - accs' = map fst ws - ys = map snd ws - acc' = last accs -{-# INLINE mapAccumL #-} - --- | The 'mapAccumR' function behaves like a combination of 'map' and 'foldr'; --- it applies a function to each element of a vector, passing an accumulating --- parameter from right to left, and returning a final value of this accumulator --- together with the new vector. --- --- >>> mapAccumR (\acc x -> (acc + x,acc + 1)) 0 (1 :> 2 :> 3 :> 4 :> Nil) --- (10,<10,8,5,1>) --- --- \"'mapAccumR' @f acc xs@\" corresponds to the following circuit layout: --- --- <> -mapAccumR :: (acc -> x -> (acc,y)) -> acc -> Vec n x -> (acc, Vec n y) -mapAccumR f acc xs = (acc',ys) - where - accs = accs' :< acc - ws = zipWith (flip f) xs (tail accs) - accs' = map fst ws - ys = map snd ws - acc' = head accs -{-# INLINE mapAccumR #-} - --- | 'zip' takes two vectors and returns a vector of corresponding pairs. --- --- >>> zip (1:>2:>3:>4:>Nil) (4:>3:>2:>1:>Nil) --- <(1,4),(2,3),(3,2),(4,1)> -zip :: Vec n a -> Vec n b -> Vec n (a,b) -zip = zipWith (,) -{-# INLINE zip #-} - --- | 'zip' takes three vectors and returns a vector of corresponding triplets. --- --- >>> zip3 (1:>2:>3:>4:>Nil) (4:>3:>2:>1:>Nil) (5:>6:>7:>8:>Nil) --- <(1,4,5),(2,3,6),(3,2,7),(4,1,8)> -zip3 :: Vec n a -> Vec n b -> Vec n c -> Vec n (a,b,c) -zip3 = zipWith3 (,,) -{-# INLINE zip3 #-} - --- | 'unzip' transforms a vector of pairs into a vector of first components --- and a vector of second components. --- --- >>> unzip ((1,4):>(2,3):>(3,2):>(4,1):>Nil) --- (<1,2,3,4>,<4,3,2,1>) -unzip :: Vec n (a,b) -> (Vec n a, Vec n b) -unzip xs = (map fst xs, map snd xs) -{-# INLINE unzip #-} - --- | 'unzip3' transforms a vector of triplets into a vector of first components, --- a vector of second components, and a vector of third components. --- --- >>> unzip3 ((1,4,5):>(2,3,6):>(3,2,7):>(4,1,8):>Nil) --- (<1,2,3,4>,<4,3,2,1>,<5,6,7,8>) -unzip3 :: Vec n (a,b,c) -> (Vec n a, Vec n b, Vec n c) -unzip3 xs = ( map (\(x,_,_) -> x) xs - , map (\(_,y,_) -> y) xs - , map (\(_,_,z) -> z) xs - ) -{-# INLINE unzip3 #-} - -index_int :: KnownNat n => Vec n a -> Int -> a -index_int xs i@(I# n0) - | isTrue# (n0 <# 0#) = error "CLaSH.Sized.Vector.(!!): negative index" - | otherwise = sub xs n0 - where - sub :: Vec m a -> Int# -> a - sub Nil _ = error (P.concat [ "CLaSH.Sized.Vector.(!!): index " - , show i - , " is larger than maximum index " - , show ((length xs)-1) - ]) - sub (y `Cons` (!ys)) n = if isTrue# (n ==# 0#) - then y - else sub ys (n -# 1#) -{-# NOINLINE index_int #-} - --- | \"@xs@ '!!' @n@\" returns the /n/'th element of /xs/. --- --- __NB__: vector elements have an __ASCENDING__ subscript starting from 0 and --- ending at @'length' - 1@. --- --- >>> (1:>2:>3:>4:>5:>Nil) !! 4 --- 5 --- >>> (1:>2:>3:>4:>5:>Nil) !! (length (1:>2:>3:>4:>5:>Nil) - 1) --- 5 --- >>> (1:>2:>3:>4:>5:>Nil) !! 1 --- 2 --- >>> (1:>2:>3:>4:>5:>Nil) !! 14 --- *** Exception: CLaSH.Sized.Vector.(!!): index 14 is larger than maximum index 4 --- ... -(!!) :: (KnownNat n, Enum i) => Vec n a -> i -> a -xs !! i = index_int xs (fromEnum i) -{-# INLINE (!!) #-} - --- | The index (subscript) of the last element in a 'Vec'tor as an 'Int' --- value. -maxIndex :: KnownNat n => Vec n a -> Int -maxIndex = subtract 1 . length -{-# NOINLINE maxIndex #-} -{-# DEPRECATED maxIndex "'maxIndex' will be removed in clash-prelude-1.0, use 'length xs - 1' instead." #-} - --- | The length of a 'Vec'tor as an 'Int' value. --- --- >>> length (6 :> 7 :> 8 :> Nil) --- 3 -length :: KnownNat n => Vec n a -> Int -length = fromInteger . natVal . asNatProxy -{-# NOINLINE length #-} - -replace_int :: KnownNat n => Vec n a -> Int -> a -> Vec n a -replace_int xs i@(I# n0) a - | isTrue# (n0 <# 0#) = error "CLaSH.Sized.Vector.replace: negative index" - | otherwise = sub xs n0 a - where - sub :: Vec m b -> Int# -> b -> Vec m b - sub Nil _ _ = error (P.concat [ "CLaSH.Sized.Vector.replace: index " - , show i - , " is larger than maximum index " - , show (length xs - 1) - ]) - sub (y `Cons` (!ys)) n b = if isTrue# (n ==# 0#) - then b `Cons` ys - else y `Cons` sub ys (n -# 1#) b -{-# NOINLINE replace_int #-} - --- | \"'replace' @n a xs@\" returns the vector /xs/ where the /n/'th element is --- replaced by /a/. --- --- __NB__: vector elements have an __ASCENDING__ subscript starting from 0 and --- ending at @'length' - 1@. --- --- >>> replace 3 7 (1:>2:>3:>4:>5:>Nil) --- <1,2,3,7,5> --- >>> replace 0 7 (1:>2:>3:>4:>5:>Nil) --- <7,2,3,4,5> --- >>> replace 9 7 (1:>2:>3:>4:>5:>Nil) --- <1,2,3,4,*** Exception: CLaSH.Sized.Vector.replace: index 9 is larger than maximum index 4 --- ... -replace :: (KnownNat n, Enum i) => i -> a -> Vec n a -> Vec n a -replace i y xs = replace_int xs (fromEnum i) y -{-# INLINE replace #-} - --- | \"'take' @n xs@\" returns the /n/-length prefix of /xs/. --- --- >>> take (SNat :: SNat 3) (1:>2:>3:>4:>5:>Nil) --- <1,2,3> --- >>> take d3 (1:>2:>3:>4:>5:>Nil) --- <1,2,3> --- >>> take d0 (1:>2:>Nil) --- <> --- >>> take d4 (1:>2:>Nil) --- --- :... --- • Couldn't match type ‘4 + n0’ with ‘2’ --- Expected type: Vec (4 + n0) a --- Actual type: Vec (1 + 1) a --- The type variable ‘n0’ is ambiguous --- • In the second argument of ‘take’, namely ‘(1 :> 2 :> Nil)’ --- In the expression: take d4 (1 :> 2 :> Nil) --- In an equation for ‘it’: it = take d4 (1 :> 2 :> Nil) -take :: SNat m -> Vec (m + n) a -> Vec m a -take n = fst . splitAt n -{-# INLINE take #-} - --- | \"'takeI' @xs@\" returns the prefix of /xs/ as demanded by the context. --- --- >>> takeI (1:>2:>3:>4:>5:>Nil) :: Vec 2 Int --- <1,2> -takeI :: KnownNat m => Vec (m + n) a -> Vec m a -takeI = withSNat take -{-# INLINE takeI #-} - --- | \"'drop' @n xs@\" returns the suffix of /xs/ after the first /n/ elements. --- --- >>> drop (SNat :: SNat 3) (1:>2:>3:>4:>5:>Nil) --- <4,5> --- >>> drop d3 (1:>2:>3:>4:>5:>Nil) --- <4,5> --- >>> drop d0 (1:>2:>Nil) --- <1,2> --- >>> drop d4 (1:>2:>Nil) --- --- :... --- • Couldn't match expected type ‘2’ with actual type ‘4 + n0’ --- The type variable ‘n0’ is ambiguous --- • In the first argument of ‘print’, namely ‘it’ --- In a stmt of an interactive GHCi command: print it -drop :: SNat m -> Vec (m + n) a -> Vec n a -drop n = snd . splitAt n -{-# INLINE drop #-} - --- | \"'dropI' @xs@\" returns the suffix of /xs/ as demanded by the context. --- --- >>> dropI (1:>2:>3:>4:>5:>Nil) :: Vec 2 Int --- <4,5> -dropI :: KnownNat m => Vec (m + n) a -> Vec n a -dropI = withSNat drop -{-# INLINE dropI #-} - --- | \"'at' @n xs@\" returns /n/'th element of /xs/ --- --- __NB__: vector elements have an __ASCENDING__ subscript starting from 0 and --- ending at @'length' - 1@. --- --- >>> at (SNat :: SNat 1) (1:>2:>3:>4:>5:>Nil) --- 2 --- >>> at d1 (1:>2:>3:>4:>5:>Nil) --- 2 -at :: SNat m -> Vec (m + (n + 1)) a -> a -at n xs = head $ snd $ splitAt n xs -{-# INLINE at #-} - --- | \"'select' @f s n xs@\" selects /n/ elements with step-size /s/ and --- offset @f@ from /xs/. --- --- >>> select (SNat :: SNat 1) (SNat :: SNat 2) (SNat :: SNat 3) (1:>2:>3:>4:>5:>6:>7:>8:>Nil) --- <2,4,6> --- >>> select d1 d2 d3 (1:>2:>3:>4:>5:>6:>7:>8:>Nil) --- <2,4,6> -select :: (CmpNat (i + s) (s * n) ~ 'GT) - => SNat f - -> SNat s - -> SNat n - -> Vec (f + i) a - -> Vec n a -select f s n xs = select' (toUNat n) $ drop f xs - where - select' :: UNat n -> Vec i a -> Vec n a - select' UZero _ = Nil - select' (USucc n') vs@(x `Cons` _) = x `Cons` - select' n' (drop s (unsafeCoerce vs)) -{-# NOINLINE select #-} - --- | \"'selectI' @f s xs@\" selects as many elements as demanded by the context --- with step-size /s/ and offset /f/ from /xs/. --- --- >>> selectI d1 d2 (1:>2:>3:>4:>5:>6:>7:>8:>Nil) :: Vec 2 Int --- <2,4> -selectI :: (CmpNat (i + s) (s * n) ~ 'GT, KnownNat n) - => SNat f - -> SNat s - -> Vec (f + i) a - -> Vec n a -selectI f s xs = withSNat (\n -> select f s n xs) -{-# INLINE selectI #-} - --- | \"'replicate' @n a@\" returns a vector that has /n/ copies of /a/. --- --- >>> replicate (SNat :: SNat 3) 6 --- <6,6,6> --- >>> replicate d3 6 --- <6,6,6> -replicate :: SNat n -> a -> Vec n a -replicate n a = replicateU (toUNat n) a -{-# NOINLINE replicate #-} - -replicateU :: UNat n -> a -> Vec n a -replicateU UZero _ = Nil -replicateU (USucc s) x = x `Cons` replicateU s x - --- | \"'replicateI' @a@\" creates a vector with as many copies of /a/ as --- demanded by the context. --- --- >>> replicateI 6 :: Vec 5 Int --- --- :... --- In the use of ‘replicateI’ --- (imported from CLaSH.Prelude, but defined in CLaSH.Sized.Vector): --- Deprecated: "Use 'repeat' instead of 'replicateI'" --- <6,6,6,6,6> -replicateI :: KnownNat n => a -> Vec n a -replicateI = withSNat replicate -{-# INLINE replicateI #-} -{-# DEPRECATED replicateI "Use 'repeat' instead of 'replicateI'" #-} - --- | \"'repeat' @a@\" creates a vector with as many copies of /a/ as demanded --- by the context. --- --- >>> repeat 6 :: Vec 5 Int --- <6,6,6,6,6> -repeat :: KnownNat n => a -> Vec n a -repeat = withSNat replicate -{-# INLINE repeat #-} - --- | \"'iterate' @n f x@\" returns a vector starting with /x/ followed by --- /n/ repeated applications of /f/ to /x/. --- --- > iterate (SNat :: SNat 4) f x == (x :> f x :> f (f x) :> f (f (f x)) :> Nil) --- > iterate d4 f x == (x :> f x :> f (f x) :> f (f (f x)) :> Nil) --- --- >>> iterate d4 (+1) 1 --- <1,2,3,4> --- --- \"'interate' @n f z@\" corresponds to the following circuit layout: --- --- <> -iterate :: SNat n -> (a -> a) -> a -> Vec n a -iterate SNat = iterateI -{-# INLINE iterate #-} - --- | \"'iterate' @f x@\" returns a vector starting with @x@ followed by @n@ --- repeated applications of @f@ to @x@, where @n@ is determined by the context. --- --- > iterateI f x :: Vec 3 a == (x :> f x :> f (f x) :> Nil) --- --- >>> iterateI (+1) 1 :: Vec 3 Int --- <1,2,3> --- --- \"'interateI' @f z@\" corresponds to the following circuit layout: --- --- <> -iterateI :: KnownNat n => (a -> a) -> a -> Vec n a -iterateI f a = xs - where - xs = init (a `Cons` ws) - ws = map f (lazyV xs) -{-# INLINE iterateI #-} - --- | \"'generate' @n f x@\" returns a vector with @n@ repeated applications of --- @f@ to @x@. --- --- > generate (SNat :: SNat 4) f x == (f x :> f (f x) :> f (f (f x)) :> f (f (f (f x))) :> Nil) --- > generate d4 f x == (f x :> f (f x) :> f (f (f x)) :> f (f (f (f x))) :> Nil) --- --- >>> generate d4 (+1) 1 --- <2,3,4,5> --- --- \"'generate' @n f z@\" corresponds to the following circuit layout: --- --- <> -generate :: SNat n -> (a -> a) -> a -> Vec n a -generate SNat f a = iterateI f (f a) -{-# INLINE generate #-} - --- | \"'generateI' @f x@\" returns a vector with @n@ repeated applications of --- @f@ to @x@, where @n@ is determined by the context. --- --- > generateI f x :: Vec 3 a == (f x :> f (f x) :> f (f (f x)) :> Nil) --- --- >>> generateI (+1) 1 :: Vec 3 Int --- <2,3,4> --- --- \"'generateI' @f z@\" corresponds to the following circuit layout: --- --- <> -generateI :: KnownNat n => (a -> a) -> a -> Vec n a -generateI f a = iterateI f (f a) -{-# INLINE generateI #-} - --- | Transpose a matrix: go from row-major to column-major --- --- >>> let xss = (1:>2:>Nil):>(3:>4:>Nil):>(5:>6:>Nil):>Nil --- >>> xss --- <<1,2>,<3,4>,<5,6>> --- >>> transpose xss --- <<1,3,5>,<2,4,6>> -transpose :: KnownNat n => Vec m (Vec n a) -> Vec n (Vec m a) -transpose = traverse# id -{-# NOINLINE transpose #-} - --- | 1-dimensional stencil computations --- --- \"'stencil1d' @stX f xs@\", where /xs/ has /stX + n/ elements, applies the --- stencil computation /f/ on: /n + 1/ overlapping (1D) windows of length /stX/, --- drawn from /xs/. The resulting vector has /n + 1/ elements. --- --- >>> let xs = (1:>2:>3:>4:>5:>6:>Nil) --- >>> :t xs --- xs :: Num a => Vec 6 a --- >>> :t stencil1d d2 sum xs --- stencil1d d2 sum xs :: Num b => Vec 5 b --- >>> stencil1d d2 sum xs --- <3,5,7,9,11> -stencil1d :: KnownNat n - => SNat (stX + 1) -- ^ Windows length /stX/, at least size 1 - -> (Vec (stX + 1) a -> b) -- ^ The stencil (function) - -> Vec ((stX + n) + 1) a - -> Vec (n + 1) b -stencil1d stX f xs = map f (windows1d stX xs) -{-# INLINE stencil1d #-} - --- | 2-dimensional stencil computations --- --- \"'stencil2d' @stY stX f xss@\", where /xss/ is a matrix of /stY + m/ rows --- of /stX + n/ elements, applies the stencil computation /f/ on: --- /(m + 1) * (n + 1)/ overlapping (2D) windows of /stY/ rows of /stX/ elements, --- drawn from /xss/. The result matrix has /m + 1/ rows of /n + 1/ elements. --- --- >>> let xss = ((1:>2:>3:>4:>Nil):>(5:>6:>7:>8:>Nil):>(9:>10:>11:>12:>Nil):>(13:>14:>15:>16:>Nil):>Nil) --- >>> :t xss --- xss :: Num a => Vec 4 (Vec 4 a) --- >>> :t stencil2d d2 d2 (sum . map sum) xss --- stencil2d d2 d2 (sum . map sum) xss :: Num b => Vec 3 (Vec 3 b) --- >>> stencil2d d2 d2 (sum . map sum) xss --- <<14,18,22>,<30,34,38>,<46,50,54>> -stencil2d :: (KnownNat n, KnownNat m) - => SNat (stY + 1) -- ^ Window hight /stY/, at least size 1 - -> SNat (stX + 1) -- ^ Window width /stX/, at least size 1 - -> (Vec (stY + 1) (Vec (stX + 1) a) -> b) -- ^ The stencil (function) - -> Vec ((stY + m) + 1) (Vec ((stX + n) + 1) a) - -> Vec (m + 1) (Vec (n + 1) b) -stencil2d stY stX f xss = (map.map) f (windows2d stY stX xss) -{-# INLINE stencil2d #-} - --- | \"'windows1d' @stX xs@\", where the vector /xs/ has /stX + n/ elements, --- returns a vector of /n + 1/ overlapping (1D) windows of /xs/ of length /stX/. --- --- >>> let xs = (1:>2:>3:>4:>5:>6:>Nil) --- >>> :t xs --- xs :: Num a => Vec 6 a --- >>> :t windows1d d2 xs --- windows1d d2 xs :: Num a => Vec 5 (Vec 2 a) --- >>> windows1d d2 xs --- <<1,2>,<2,3>,<3,4>,<4,5>,<5,6>> -windows1d :: KnownNat n - => SNat (stX + 1) -- ^ Length of the window, at least size 1 - -> Vec ((stX + n) + 1) a - -> Vec (n + 1) (Vec (stX + 1) a) -windows1d stX xs = map (take stX) (rotations xs) - where - rotateL ys = tail ys :< head ys - rotations ys = iterateI rotateL ys -{-# INLINE windows1d #-} - --- | \"'windows2d' @stY stX xss@\", where matrix /xss/ has /stY + m/ rows of --- /stX + n/, returns a matrix of /m+1/ rows of /n+1/ elements. The elements --- of this new matrix are the overlapping (2D) windows of /xss/, where every --- window has /stY/ rows of /stX/ elements. --- --- >>> let xss = ((1:>2:>3:>4:>Nil):>(5:>6:>7:>8:>Nil):>(9:>10:>11:>12:>Nil):>(13:>14:>15:>16:>Nil):>Nil) --- >>> :t xss --- xss :: Num a => Vec 4 (Vec 4 a) --- >>> :t windows2d d2 d2 xss --- windows2d d2 d2 xss :: Num a => Vec 3 (Vec 3 (Vec 2 (Vec 2 a))) --- >>> windows2d d2 d2 xss --- <<<<1,2>,<5,6>>,<<2,3>,<6,7>>,<<3,4>,<7,8>>>,<<<5,6>,<9,10>>,<<6,7>,<10,11>>,<<7,8>,<11,12>>>,<<<9,10>,<13,14>>,<<10,11>,<14,15>>,<<11,12>,<15,16>>>> -windows2d :: (KnownNat n,KnownNat m) - => SNat (stY + 1) -- ^ Window hight /stY/, at least size 1 - -> SNat (stX + 1) -- ^ Window width /stX/, at least size 1 - -> Vec ((stY + m) + 1) (Vec (stX + n + 1) a) - -> Vec (m + 1) (Vec (n + 1) (Vec (stY + 1) (Vec (stX + 1) a))) -windows2d stY stX xss = map (transpose . (map (windows1d stX))) (windows1d stY xss) -{-# INLINE windows2d #-} - --- | Forward permutation specified by an index mapping, /ix/. The result vector --- is initialised by the given defaults, /def/, and an further values that are --- permuted into the result are added to the current value using the given --- combination function, /f/. --- --- The combination function must be /associative/ and /commutative/. -permute :: (Enum i, KnownNat n, KnownNat m) - => (a -> a -> a) -- ^ Combination function, /f/ - -> Vec n a -- ^ Default values, /def/ - -> Vec m i -- ^ Index mapping, /is/ - -> Vec (m + k) a -- ^ Vector to be permuted, /xs/ - -> Vec n a -permute f defs is xs = ys - where - ixs = zip is (takeI xs) - ys = foldl (\ks (i,x) -> let ki = ks!!i in replace i (f x ki) ks) defs ixs -{-# INLINE permute #-} - --- | Backwards permutation specified by an index mapping, /is/, from the --- destination vector specifying which element of the source vector /xs/ to --- read. --- --- \"'backpermute' @xs is@\" is equivalent to \"'map' @(xs '!!') is@\". --- --- For example: --- --- >>> let input = 1:>9:>6:>4:>4:>2:>0:>1:>2:>Nil --- >>> let from = 1:>3:>7:>2:>5:>3:>Nil --- >>> backpermute input from --- <9,4,1,6,2,4> -backpermute :: (Enum i, KnownNat n) - => Vec n a -- ^ Source vector, /xs/ - -> Vec m i -- ^ Index mapping, /is/ - -> Vec m a -backpermute xs = map (xs!!) -{-# INLINE backpermute #-} - --- | Copy elements from the source vector, /xs/, to the destination vector --- according to an index mapping /is/. This is a forward permute operation where --- a /to/ vector encodes an input to output index mapping. Output elements for --- indices that are not mapped assume the value in the default vector /def/. --- --- For example: --- --- >>> let defVec = 0:>0:>0:>0:>0:>0:>0:>0:>0:>Nil --- >>> let to = 1:>3:>7:>2:>5:>8:>Nil --- >>> let input = 1:>9:>6:>4:>4:>2:>5:>Nil --- >>> scatter defVec to input --- <0,1,4,9,0,4,0,6,2> --- --- __NB__: If the same index appears in the index mapping more than once, the --- latest mapping is chosen. -scatter :: (Enum i, KnownNat n, KnownNat m) - => Vec n a -- ^ Default values, /def/ - -> Vec m i -- ^ Index mapping, /is/ - -> Vec (m + k) a -- ^ Vector to be scattered, /xs/ - -> Vec n a -scatter = permute const -{-# INLINE scatter #-} - --- | Backwards permutation specified by an index mapping, /is/, from the --- destination vector specifying which element of the source vector /xs/ to --- read. --- --- \"'gather' @xs is@\" is equivalent to \"'map' @(xs '!!') is@\". --- --- For example: --- --- >>> let input = 1:>9:>6:>4:>4:>2:>0:>1:>2:>Nil --- >>> let from = 1:>3:>7:>2:>5:>3:>Nil --- >>> gather input from --- <9,4,1,6,2,4> -gather :: (Enum i, KnownNat n) - => Vec n a -- ^ Source vector, /xs/ - -> Vec m i -- ^ Index mapping, /is/ - -> Vec m a -gather xs = map (xs!!) -{-# INLINE gather #-} - --- | \"'interleave' @d xs@\" creates a vector: --- --- @ --- \ --- @ --- --- >>> let xs = 1 :> 2 :> 3 :> 4 :> 5 :> 6 :> 7 :> 8 :> 9 :> Nil --- >>> interleave d3 xs --- <1,4,7,2,5,8,3,6,9> -interleave :: (KnownNat n, KnownNat d) - => SNat d -- ^ Interleave step, /d/ - -> Vec (n * d) a - -> Vec (d * n) a -interleave d = concat . transpose . unconcat d -{-# INLINE interleave #-} - --- | /Dynamically/ rotate a 'Vec'tor to the left: --- --- >>> let xs = 1 :> 2 :> 3 :> 4 :> Nil --- >>> rotateLeft xs 1 --- <2,3,4,1> --- >>> rotateLeft xs 2 --- <3,4,1,2> --- >>> rotateLeft xs (-1) --- <4,1,2,3> --- --- __NB:__ use `rotateLeftS` if you want to rotate left by a /static/ amount. -rotateLeft :: (Enum i, KnownNat n) - => Vec n a - -> i - -> Vec n a -rotateLeft xs i = map ((xs !!) . (`mod` len)) (iterateI (+1) i') - where - i' = fromEnum i - len = length xs -{-# INLINE rotateLeft #-} - --- | /Dynamically/ rotate a 'Vec'tor to the right: --- --- >>> let xs = 1 :> 2 :> 3 :> 4 :> Nil --- >>> rotateRight xs 1 --- <4,1,2,3> --- >>> rotateRight xs 2 --- <3,4,1,2> --- >>> rotateRight xs (-1) --- <2,3,4,1> --- --- __NB:__ use `rotateRightS` if you want to rotate right by a /static/ amount. -rotateRight :: (Enum i, KnownNat n) - => Vec n a - -> i - -> Vec n a -rotateRight xs i = map ((xs !!) . (`mod` len)) (iterateI (+1) i') - where - i' = negate (fromEnum i) - len = length xs -{-# INLINE rotateRight #-} - --- | /Statically/ rotate a 'Vec'tor to the left: --- --- >>> let xs = 1 :> 2 :> 3 :> 4 :> Nil --- >>> rotateLeftS xs d1 --- <2,3,4,1> --- --- __NB:__ use `rotateLeft` if you want to rotate left by a /dynamic/ amount. -rotateLeftS :: KnownNat n - => Vec n a - -> SNat d - -> Vec n a -rotateLeftS xs d = go (snatToInteger d `mod` natVal (asNatProxy xs)) xs - where - go :: Integer -> Vec k a -> Vec k a - go _ Nil = Nil - go 0 ys = ys - go n (y `Cons` ys) = go (n-1) (ys :< y) -{-# NOINLINE rotateLeftS #-} - --- | /Statically/ rotate a 'Vec'tor to the right: --- --- >>> let xs = 1 :> 2 :> 3 :> 4 :> Nil --- >>> rotateRightS xs d1 --- <4,1,2,3> --- --- __NB:__ use `rotateRight` if you want to rotate right by a /dynamic/ amount. -rotateRightS :: KnownNat n - => Vec n a - -> SNat d - -> Vec n a -rotateRightS xs d = go (snatToInteger d `mod` natVal (asNatProxy xs)) xs - where - go _ Nil = Nil - go 0 ys = ys - go n ys@(Cons _ _) = go (n-1) (last ys :> init ys) -{-# NOINLINE rotateRightS #-} - --- | Convert a vector to a list. --- --- >>> toList (1:>2:>3:>Nil) --- [1,2,3] -toList :: Vec n a -> [a] -toList = foldr (:) [] -{-# INLINE toList #-} - --- | Create a vector literal from a list literal. --- --- > $(listToVecTH [1::Signed 8,2,3,4,5]) == (8:>2:>3:>4:>5:>Nil) :: Vec 5 (Signed 8) --- --- >>> [1 :: Signed 8,2,3,4,5] --- [1,2,3,4,5] --- >>> $(listToVecTH [1::Signed 8,2,3,4,5]) --- <1,2,3,4,5> -listToVecTH :: Lift a => [a] -> ExpQ -listToVecTH [] = [| Nil |] -listToVecTH (x:xs) = [| x :> $(listToVecTH xs) |] - -v :: Lift a => [a] -> ExpQ -v = listToVecTH -{-# DEPRECATED v "'v' will be removed in clash-prelude-1.0, use 'listToVecTH'" #-} - --- | 'Vec'tor as a 'Proxy' for 'Nat' -asNatProxy :: Vec n a -> Proxy n -asNatProxy _ = Proxy - --- | Length of a 'Vec'tor as an 'SNat' value -lengthS :: KnownNat n => Vec n a -> SNat n -lengthS _ = SNat -{-# INLINE lengthS #-} - --- | What you should use when your vector functions are too strict in their --- arguments. --- --- For example: --- --- @ --- -- Bubble sort for 1 iteration --- sortV xs = 'map' fst sorted ':<' (snd ('last' sorted)) --- where --- lefts = 'head' xs :> 'map' snd ('init' sorted) --- rights = 'tail' xs --- sorted = 'zipWith' compareSwapL lefts rights --- --- -- Compare and swap --- compareSwapL a b = if a < b then (a,b) --- else (b,a) --- @ --- --- Will not terminate because 'zipWith' is too strict in its second argument. --- --- In this case, adding 'lazyV' on 'zipWith's second argument: --- --- @ --- sortVL xs = 'map' fst sorted ':<' (snd ('last' sorted)) --- where --- lefts = 'head' xs :> map snd ('init' sorted) --- rights = 'tail' xs --- sorted = 'zipWith' compareSwapL ('lazyV' lefts) rights --- @ --- --- Results in a successful computation: --- --- >>> sortVL (4 :> 1 :> 2 :> 3 :> Nil) --- <1,2,3,4> --- --- __NB__: There is also a solution using 'flip', but it slightly obfuscates the --- meaning of the code: --- --- @ --- sortV_flip xs = 'map' fst sorted ':<' (snd ('last' sorted)) --- where --- lefts = 'head' xs :> 'map' snd ('init' sorted) --- rights = 'tail' xs --- sorted = 'zipWith' ('flip' compareSwapL) rights lefts --- @ --- --- >>> sortV_flip (4 :> 1 :> 2 :> 3 :> Nil) --- <1,2,3,4> -lazyV :: KnownNat n - => Vec n a - -> Vec n a -lazyV = lazyV' (repeat undefined) - where - lazyV' :: Vec n a -> Vec n a -> Vec n a - lazyV' Nil _ = Nil - lazyV' (_ `Cons` xs) ys = head ys `Cons` lazyV' xs (tail ys) -{-# NOINLINE lazyV #-} - --- | A /dependently/ typed fold. --- --- Using lists, we can define /append/ (a.k.a. @Data.List.@'Data.List.++') in --- terms of @Data.List.@'Data.List.foldr': --- --- >>> import qualified Data.List --- >>> let append xs ys = Data.List.foldr (:) ys xs --- >>> append [1,2] [3,4] --- [1,2,3,4] --- --- However, when we try to do the same for 'Vec', by defining /append'/ in terms --- of @CLaSH.Sized.Vector.@'foldr': --- --- @ --- append' xs ys = 'foldr' (:>) ys xs --- @ --- --- we get a type error: --- --- >>> let append' xs ys = foldr (:>) ys xs --- --- :... --- • Occurs check: cannot construct the infinite type: t ~ t + 1 --- Expected type: a -> Vec t a -> Vec t a --- Actual type: a -> Vec t a -> Vec (t + 1) a --- • In the first argument of ‘foldr’, namely ‘(:>)’ --- In the expression: foldr (:>) ys xs --- In an equation for ‘append'’: append' xs ys = foldr (:>) ys xs --- • Relevant bindings include --- ys :: Vec t a (bound at ...) --- append' :: Vec n a -> Vec t a -> Vec t a --- (bound at ...) --- --- The reason is that the type of 'foldr' is: --- --- >>> :t foldr --- foldr :: (a -> b -> b) -> b -> Vec n a -> b --- --- While the type of (':>') is: --- --- >>> :t (:>) --- (:>) :: a -> Vec n a -> Vec (n + 1) a --- --- We thus need a @fold@ function that can handle the growing vector type: --- 'dfold'. Compared to 'foldr', 'dfold' takes an extra parameter, called the --- /motive/, that allows the folded function to have an argument and result type --- that /depends/ on the current length of the vector. Using 'dfold', we can --- now correctly define /append'/: --- --- @ --- import Data.Singletons.Prelude --- import Data.Proxy --- --- data Append (m :: Nat) (a :: *) (f :: 'TyFun' Nat *) :: * --- type instance 'Apply' (Append m a) l = 'Vec' (l + m) a --- --- append' xs ys = 'dfold' (Proxy :: Proxy (Append m a)) (const (':>')) ys xs --- @ --- --- We now see that /append'/ has the appropriate type: --- --- >>> :t append' --- append' :: KnownNat k => Vec k a -> Vec m a -> Vec (k + m) a --- --- And that it works: --- --- >>> append' (1 :> 2 :> Nil) (3 :> 4 :> Nil) --- <1,2,3,4> --- --- __NB__: \"@'dfold' m f z xs@\" creates a linear structure, which has a depth, --- or delay, of O(@'length' xs@). Look at 'dtfold' for a /dependently/ typed --- fold that produces a structure with a depth of O(log_2(@'length' xs@)). -dfold :: forall p k a . KnownNat k - => Proxy (p :: TyFun Nat * -> *) -- ^ The /motive/ - -> (forall l . SNat l -> a -> (p @@ l) -> (p @@ (l + 1))) - -- ^ Function to fold. - -- - -- __NB__: The @SNat l@ is __not__ the index (see (`!!`)) to the - -- element /a/. @SNat l@ is the number of elements that occur to the - -- right of /a/. - -> (p @@ 0) -- ^ Initial element - -> Vec k a -- ^ Vector to fold over - -> (p @@ k) -dfold _ f z xs = go (snatProxy (asNatProxy xs)) xs - where - go :: SNat n -> Vec n a -> (p @@ n) - go _ Nil = z - go s (y `Cons` (ys :: Vec z a)) = - let s' = s `subSNat` d1 - in f s' y (go s' ys) -{-# NOINLINE dfold #-} - --- | A combination of 'dfold' and 'fold': a /dependently/ typed fold that --- reduces a vector in a tree-like structure. --- --- As an example of when you might want to use 'dtfold' we will build a --- population counter: a circuit that counts the number of bits set to '1' in --- a 'BitVector'. Given a vector of /n/ bits, we only need we need a data type --- that can represent the number /n/: 'Index' @(n+1)@. 'Index' @k@ has a range --- of @[0 .. k-1]@ (using @ceil(log2(k))@ bits), hence we need 'Index' @n+1@. --- As an initial attempt we will use 'sum', because it gives a nice (@log2(n)@) --- tree-structure of adders: --- --- @ --- populationCount :: (KnownNat (n+1), KnownNat (n+2)) --- => 'BitVector' (n+1) -> 'Index' (n+2) --- populationCount = sum . map fromIntegral . 'bv2v' --- @ --- --- The \"problem\" with this description is that all adders have the same --- bit-width, i.e. all adders are of the type: --- --- @ --- (+) :: 'Index' (n+2) -> 'Index' (n+2) -> 'Index' (n+2). --- @ --- --- This is a \"problem\" because we could have a more efficient structure: --- one where each layer of adders is /precisely/ wide enough to count the number --- of bits at that layer. That is, at height /d/ we want the adder to be of --- type: --- --- @ --- 'Index' ((2^d)+1) -> 'Index' ((2^d)+1) -> 'Index' ((2^(d+1))+1) --- @ --- --- We have such an adder in the form of the 'CLaSH.Class.Num.plus' function, as --- defined in the instance 'CLaSH.Class.Num.ExtendingNum' instance of 'Index'. --- However, we cannot simply use 'fold' to create a tree-structure of --- 'CLaSH.Class.Num.plus'es: --- --- >>> :{ --- let populationCount' :: (KnownNat (n+1), KnownNat (n+2)) --- => BitVector (n+1) -> Index (n+2) --- populationCount' = fold plus . map fromIntegral . bv2v --- :} --- --- :... --- • Couldn't match type ‘((n + 2) + (n + 2)) - 1’ with ‘n + 2’ --- Expected type: Index (n + 2) -> Index (n + 2) -> Index (n + 2) --- Actual type: Index (n + 2) --- -> Index (n + 2) -> AResult (Index (n + 2)) (Index (n + 2)) --- • In the first argument of ‘fold’, namely ‘plus’ --- In the first argument of ‘(.)’, namely ‘fold plus’ --- In the expression: fold plus . map fromIntegral . bv2v --- • Relevant bindings include --- populationCount' :: BitVector (n + 1) -> Index (n + 2) --- (bound at ...) --- --- because 'fold' expects a function of type \"@a -> a -> a@\", i.e. a function --- where the arguments and result all have exactly the same type. --- --- In order to accommodate the type of our 'CLaSH.Class.Num.plus', where the --- result is larger than the arguments, we must use a dependently typed fold in --- the the form of 'dtfold': --- --- @ --- {\-\# LANGUAGE UndecidableInstances \#-\} --- import Data.Singletons.Prelude --- import Data.Proxy --- --- data IIndex (f :: 'TyFun' Nat *) :: * --- type instance 'Apply' IIndex l = 'Index' ((2^l)+1) --- --- populationCount' :: (KnownNat k, KnownNat (2^k)) --- => BitVector (2^k) -> Index ((2^k)+1) --- populationCount' bv = 'dtfold' (Proxy @IIndex) --- fromIntegral --- (\\_ x y -> 'CLaSH.Class.Num.plus' x y) --- ('bv2v' bv) --- @ --- --- And we can test that it works: --- --- >>> :t populationCount' (7 :: BitVector 16) --- populationCount' (7 :: BitVector 16) :: Index 17 --- >>> populationCount' (7 :: BitVector 16) --- 3 --- --- Some final remarks: --- --- * By using 'dtfold' instead of 'fold', we had to restrict our 'BitVector' --- argument to have bit-width that is a power of 2. --- * Even though our original /populationCount/ function specified a structure --- where all adders had the same width. Most VHDL/(System)Verilog synthesis --- tools will create a more efficient circuit, i.e. one where the adders --- have an increasing bit-width for every layer, from the --- VHDL/(System)Verilog produced by the CLaSH compiler. --- --- __NB__: The depth, or delay, of the structure produced by --- \"@'dtfold' m f g xs@\" is O(log_2(@'length' xs@)). -dtfold :: forall p k a . KnownNat k - => Proxy (p :: TyFun Nat * -> *) -- ^ The /motive/ - -> (a -> (p @@ 0)) -- ^ Function to apply to every element - -> (forall l . SNat l -> (p @@ l) -> (p @@ l) -> (p @@ (l + 1))) - -- ^ Function to combine results. - -- - -- __NB__: The @SNat l@ indicates the depth/height of the node in the - -- tree that is created by applying this function. The leafs of the tree - -- have depth\/height /0/, and the root of the tree has height /k/. - -> Vec (2^k) a - -- ^ Vector to fold over. - -- - -- __NB__: Must have a length that is a power of 2. - -> (p @@ k) -dtfold _ f g = go (SNat :: SNat k) - where - go :: forall n . SNat n -> Vec (2^n) a -> (p @@ n) - go _ (x `Cons` Nil) = f x - go sn xs = - let sn' :: SNat (n - 1) - sn' = sn `subSNat` d1 - (xsL,xsR) = splitAt (pow2SNat sn') xs - in g sn' (go sn' xsL) (go sn' xsR) -{-# NOINLINE dtfold #-} - --- | To be used as the motive /p/ for 'dfold', when the /f/ in \"'dfold' @p f@\" --- is a variation on (':>'), e.g.: --- --- @ --- map' :: forall n a b . KnownNat n => (a -> b) -> Vec n a -> Vec n b --- map' f = 'dfold' (Proxy @('VCons' b)) (\_ x xs -> f x :> xs) --- @ -data VCons (a :: *) (f :: TyFun Nat *) :: * -type instance Apply (VCons a) l = Vec l a - --- | Specialised version of 'dfold' that builds a triangular computational --- structure. --- --- Example: --- --- @ --- compareSwap a b = if a > b then (a,b) else (b,a) --- insert y xs = let (y',xs') = 'mapAccumL' compareSwap y xs in xs' ':<' y' --- insertionSort = 'vfold' (const insert) --- @ --- --- Builds a triangular structure of compare and swaps to sort a row. --- --- >>> insertionSort (7 :> 3 :> 9 :> 1 :> Nil) --- <1,3,7,9> --- --- The circuit layout of @insertionSort@, build using 'vfold', is: --- --- <> -vfold :: forall k a b . KnownNat k - => (forall l . SNat l -> a -> Vec l b -> Vec (l + 1) b) - -> Vec k a - -> Vec k b -vfold f xs = dfold (Proxy @(VCons b)) f Nil xs -{-# INLINE vfold #-} - --- | Apply a function to every element of a vector and the element's position --- (as an 'SNat' value) in the vector. --- --- >>> let rotateMatrix = smap (flip rotateRightS) --- >>> let xss = (1:>2:>3:>Nil):>(1:>2:>3:>Nil):>(1:>2:>3:>Nil):>Nil --- >>> xss --- <<1,2,3>,<1,2,3>,<1,2,3>> --- >>> rotateMatrix xss --- <<1,2,3>,<3,1,2>,<2,3,1>> -smap :: forall k a b . KnownNat k => (forall l . SNat l -> a -> b) -> Vec k a -> Vec k b -smap f xs = reverse - $ dfold (Proxy @(VCons b)) - (\sn x xs' -> f sn x :> xs') - Nil (reverse xs) -{-# INLINE smap #-} - -instance (KnownNat n, KnownNat (BitSize a), BitPack a) => BitPack (Vec n a) where - type BitSize (Vec n a) = n * (BitSize a) - pack = concatBitVector# . map pack - unpack = map unpack . unconcatBitVector# - -concatBitVector# :: KnownNat m - => Vec n (BitVector m) - -> BitVector (n * m) -concatBitVector# = concatBitVector' . reverse - where - concatBitVector' :: KnownNat m - => Vec n (BitVector m) - -> BitVector (n * m) - concatBitVector' Nil = 0 - concatBitVector' (x `Cons` xs) = concatBitVector' xs ++# x -{-# NOINLINE concatBitVector# #-} - -unconcatBitVector# :: (KnownNat n, KnownNat m) - => BitVector (n * m) - -> Vec n (BitVector m) -unconcatBitVector# bv = withSNat (\s -> ucBV (toUNat s) bv) -{-# NOINLINE unconcatBitVector# #-} - -ucBV :: forall n m . KnownNat m - => UNat n -> BitVector (n * m) -> Vec n (BitVector m) -ucBV UZero _ = Nil -ucBV (USucc n) bv = let (bv',x :: BitVector m) = split# bv - in ucBV n bv' :< x -{-# INLINE ucBV #-} - --- | Convert a 'BitVector' to a 'Vec' of 'Bit's. --- --- >>> let x = 6 :: BitVector 8 --- >>> x --- 0000_0110 --- >>> bv2v x --- <0,0,0,0,0,1,1,0> -bv2v :: KnownNat n => BitVector n -> Vec n Bit -bv2v = unpack - --- | Convert a 'Vec' of 'Bit's to a 'BitVector'. --- --- >>> let x = (0:>0:>0:>1:>0:>0:>1:>0:>Nil) :: Vec 8 Bit --- >>> x --- <0,0,0,1,0,0,1,0> --- >>> v2bv x --- 0001_0010 -v2bv :: KnownNat n => Vec n Bit -> BitVector n -v2bv = pack - -instance Lift a => Lift (Vec n a) where - lift Nil = [| Nil |] - lift (x `Cons` xs) = [| x `Cons` $(lift xs) |] - -instance (KnownNat n, Arbitrary a) => Arbitrary (Vec n a) where - arbitrary = traverse# id $ repeat arbitrary - shrink = traverse# id . fmap shrink - -instance CoArbitrary a => CoArbitrary (Vec n a) where - coarbitrary = coarbitrary . toList - -type instance Lens.Index (Vec n a) = Index n -type instance Lens.IxValue (Vec n a) = a -instance KnownNat n => Lens.Ixed (Vec n a) where - ix i f xs = replace_int xs (fromEnum i) <$> f (index_int xs (fromEnum i)) diff --git a/src/CLaSH/Sized/Vector.hs-boot b/src/CLaSH/Sized/Vector.hs-boot deleted file mode 100644 --- a/src/CLaSH/Sized/Vector.hs-boot +++ /dev/null @@ -1,25 +0,0 @@ -{-| -Copyright : (C) 2015-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij --} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE TypeOperators #-} -module CLaSH.Sized.Vector where - -import GHC.TypeLits (KnownNat, Nat, type (+)) -import {-# SOURCE #-} CLaSH.Sized.Internal.BitVector (BitVector, Bit) - -type role Vec nominal representational -data Vec :: Nat -> * -> * - -instance (KnownNat m, (~) m ((+) n 1)) => Foldable (Vec m) - -bv2v :: KnownNat n => BitVector n -> Vec n Bit -map :: (a -> b) -> Vec n a -> Vec n b -foldr :: (a -> b -> b) -> b -> Vec n a -> b -foldl :: (b -> a -> b) -> b -> Vec n a -> b diff --git a/src/CLaSH/Tutorial.hs b/src/CLaSH/Tutorial.hs deleted file mode 100644 --- a/src/CLaSH/Tutorial.hs +++ /dev/null @@ -1,2019 +0,0 @@ -{-| -Copyright : © 2014-2016, Christiaan Baaij, 2017, QBayLogic -Licence : Creative Commons 4.0 (CC BY 4.0) (http://creativecommons.org/licenses/by/4.0/) --} - -{-# LANGUAGE NoImplicitPrelude, MagicHash #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} - -module CLaSH.Tutorial ( - -- * Introduction - -- $introduction - - -- * Installation - -- $installation - - -- * Working with this tutorial - -- $working - - -- * Your first circuit - -- $mac_example - - -- *** Sequential circuit - -- $mac2 - - -- *** Generating VHDL - -- $mac3 - - -- *** Circuit testbench - -- $mac4 - - -- *** Generating Verilog and SystemVerilog - -- $mac5 - - -- *** Alternative specifications - -- $mac6 - - -- * Higher-order functions - -- $higher_order - - -- * Composition of sequential circuits - -- $composition_sequential - - -- * TopEntity annotations: controlling the VHDL\/(System)Verilog generation. - -- $annotations - - -- * Multiple clock domains - -- $multiclock - - -- * Advanced: Primitives - -- $primitives - - -- *** Verilog primitives - -- $vprimitives - - -- *** SystemVerilog primitives - -- $svprimitives - - -- * Conclusion - -- $conclusion - - -- * Troubleshooting - -- $errorsandsolutions - - -- * Limitations of CλaSH - -- $limitations - - -- * CλaSH vs Lava - -- $vslava - ) -where - -import CLaSH.Prelude -import CLaSH.Prelude.Explicit -import CLaSH.Prelude.BlockRam -import Control.Monad.ST -import Data.Array -import Data.Char -import Data.Int -import GHC.Prim -import GHC.TypeLits -import GHC.Word -import Data.Default - -{- $setup ->>> :set -XTemplateHaskell ->>> :set -XDataKinds ->>> let ma acc (x,y) = acc + x * y ->>> :{ -let macT acc (x,y) = (acc',o) - where - acc' = ma acc (x,y) - o = acc -:} - ->>> :set -XFlexibleContexts ->>> :set -fplugin GHC.TypeLits.Normalise ->>> let compareSwapL a b = if a < b then (a,b) else (b,a) ->>> :{ -let sortV xs = map fst sorted :< (snd (last sorted)) - where - lefts = head xs :> map snd (init sorted) - rights = tail xs - sorted = zipWith compareSwapL lefts rights -:} - ->>> :{ -let sortVL xs = map fst sorted :< (snd (last sorted)) - where - lefts = head xs :> map snd (init sorted) - rights = tail xs - sorted = zipWith compareSwapL (lazyV lefts) rights -:} - ->>> let mac = mealy macT 0 ->>> let topEntity = mac :: Signal (Signed 9, Signed 9) -> Signal (Signed 9) ->>> let testInput = stimuliGenerator $(listToVecTH [(1,1) :: (Signed 9,Signed 9),(2,2),(3,3),(4,4)]) ->>> let expectedOutput = outputVerifier $(listToVecTH [0 :: Signed 9,1,5,14]) ->>> :{ -let fibR :: Unsigned 64 -> Unsigned 64 - fibR 0 = 0 - fibR 1 = 1 - fibR n = fibR (n-1) + fibR (n-2) -:} - ->>> :{ -let fibS :: Signal (Unsigned 64) - fibS = r - where r = register 0 r + register 0 (register 1 r) -:} - --} - -{- $introduction -CλaSH (pronounced ‘clash’) is a functional hardware description language that -borrows both its syntax and semantics from the functional programming language -Haskell. It provides a familiar structural design approach to both combination -and synchronous sequential circuits. The CλaSH compiler transforms these -high-level descriptions to low-level synthesizable VHDL, Verilog, or -SystemVerilog. - -Features of CλaSH: - - * Strongly typed, but with a very high degree of type inference, enabling - both safe and fast prototyping using concise descriptions. - * Interactive REPL: load your designs in an interpreter and easily test all - your component without needing to setup a test bench. - * Compile your designs for fast simulation. - * Higher-order functions, in combination with type inference, result in - designs that are fully parametric by default. - * Synchronous sequential circuit design based on streams of values, called - @Signal@s, lead to natural descriptions of feedback loops. - * Multiple clock domains, with type safe clock domain crossing. - * Template language for introducing new VHDL/(System)Verilog primitives. - -Although we say that CλaSH borrows the semantics of Haskell, that statement -should be taken with a grain of salt. What we mean to say is that the CλaSH -compiler views a circuit description as /structural/ description. This means, -in an academic handwavy way, that every function denotes a component and every -function application denotes an instantiation of said component. Now, this has -consequences on how we view /recursively/ defined functions: structurally, a -recursively defined function would denote an /infinitely/ deep / structured -component, something that cannot be turned into an actual circuit -(See also <#limitations Limitations of CλaSH>). - -On the other hand, Haskell's by-default non-strict evaluation works very well -for the simulation of the feedback loops, which are ubiquitous in digital -circuits. That is, when we take our structural view to circuit descriptions, -value-recursion corresponds directly to a feedback loop: - -@ -counter = s - where - s = 'register' 0 (s + 1) -@ - -The above definition, which uses value-recursion, /can/ be synthesized to a -circuit by the CλaSH compiler. - -Over time, you will get a better feeling for the consequences of taking a -/structural/ view on circuit descriptions. What is always important to -remember is that every applied functions results in an instantiated component, -and also that the compiler will /never/ infer / invent more logic than what is -specified in the circuit description. - -With that out of the way, let us continue with installing CλaSH and building -our first circuit. --} - -{- $installation -The CλaSH compiler and Prelude library for circuit design only work with the - Haskell compiler version 8.0 (lower versions of -GHC are not supported). - - (1) Install __GHC 8.0__ - - * Download and install . - Unix user can use @./configure prefix=\@ to set the installation - location. - - * Make sure that the @bin@ directory of __GHC__ is in your @PATH@. - - In case you cannot find what you are looking for on , - you can, /alternatively/, use the following instructions: - - * Ubuntu: - - * Run: @sudo add-apt-repository -y ppa:hvr/ghc@ - * Run: @sudo apt-get update@ - * Run: @sudo apt-get install cabal-install-1.24 ghc-8.0.2 libtinfo-dev@ - * Update your @PATH@ with: @\/opt\/ghc\/8.0.2\/bin@, @\/opt\/cabal\/1.24/bin@, and @\$HOME\/.cabal\/bin@ - * Run: @cabal update@ - * Skip step 2. - - * OS X: - - * Follow the instructions on: - to install the /minimal/ Haskell platform - * Run: @cabal update@ - * Skip step 2. - - * Windows: - - * Follow the instructions on: - to install the /minimal/ Haskell platform - * Run: @cabal update@ - * Skip step 2. - - (2) Install __Cabal (version 1.24 or higher)__ - - * Binary, when available: - - * Download the binary for - * Put the binary in a location mentioned in your @PATH@ - * Add @cabal@'s @bin@ directory to your @PATH@: - - * Windows: @%appdata%\\cabal\\bin@ - * Unix: @\$HOME\/.cabal\/bin@ - - * Source: - - * Download the sources for - * Unpack (@tar xf@) the archive and @cd@ to the directory - * Run: @sh bootstrap.sh@ - * Follow the instructions to add @cabal@ to your @PATH@ - - * Run @cabal update@ - - (2) Install __CλaSH__ - - * Run: - - * /i386/ Linux: @cabal install clash-ghc --enable-documentation --enable-executable-dynamic@ - * Other: @cabal install clash-ghc --enable-documentation@ - - * /This is going to take awhile, so have a refreshment/ - - (4) Verify that everything is working by: - - * Downloading the example - * Run: @clash --interactive FIR.hs@ - * Execute, in the interpreter, the @:vhdl@ command - * Execute, in the interpreter, the @:verilog@ command - * Execute, in the interpreter, the @:systemverilog@ command - * Exit the interpreter using @:q@ - * Examine the VHDL code in the @vhdl@ directory - * Examine the Verilog code in the @verilog@ directory - * Examine the SystemVerilog code in the @systemverilog@ directory - --} - -{- $working -This tutorial can be followed best whilst having the CλaSH interpreter running -at the same time. If you followed the installation instructions, you already -know how to start the CλaSH compiler in interpretive mode: - -@ -clash --interactive -@ - -For those familiar with Haskell/GHC, this is indeed just @GHCi@, with three -added commands (@:vhdl@, @:verilog@, and @:systemverilog@). You can load files -into the interpreter using the @:l \@ command. Now, depending on your -choice in editor, the following @edit-load-run@ cycle probably work best for you: - - * __Commandline (e.g. emacs, vim):__ - - * You can run system commands using @:!@, for example @:! touch \@ - * Set the /editor/ mode to your favourite editor using: @:set editor \@ - * You can load files using @:l@ as noted above. - * You can go into /editor/ mode using: @:e@ - * Leave the editor mode by quitting the editor (e.g. @:wq@ in @vim@) - - * __GUI (e.g. SublimeText, Notepad++):__ - - * Just create new files in your editor. - * Load the files using @:l@ as noted above. - * Once a file has been edited and saved, type @:r@ to reload the files in - the interpreter - -You are of course free to deviate from these suggestions as you see fit :-) It -is just recommended that you have the CλaSH interpreter open during this -tutorial. --} - -{- $mac_example -The very first circuit that we will build is the \"classic\" multiply-and-accumulate -(MAC) circuit. This circuit is as simple as it sounds, it multiplies its inputs -and accumulates them. Before we describe any logic, we must first create the -file we will be working on and input some preliminaries: - -* Create the file: - - @ - MAC.hs - @ - -* Write on the first line the module header: - - @ - module MAC where - @ - - Module names must always start with a __C__apital letter. Also make sure that - the file name corresponds to the module name. - -* Add the import statement for the CλaSH prelude library: - - @ - import CLaSH.Prelude - @ - - This imports all the necessary functions and datatypes for circuit description. - -We can now finally start describing the logic of our circuit, starting with just -the multiplication and addition: - -@ -ma acc (x,y) = acc + x * y -@ - -If you followed the instructions of running the interpreter side-by-side, you -can already test this function: - ->>> ma 4 (8,9) -76 ->>> ma 2 (3,4) -14 - -We can also examine the inferred type of @ma@ in the interpreter: - ->>> :t ma -ma :: Num a => a -> (a, a) -> a - -Talking about /types/ also brings us to one of the most important parts of this -tutorial: /types/ and /synchronous sequential logic/. Especially how we can -always determine, through the types of a specification, if it describes -combinational logic or (synchronous) sequential logic. We do this by examining -the type of one of the sequential primitives, the @'register'@ function: - -@ -register :: a -> 'Signal' a -> 'Signal' a -register i s = ... -@ - -Where we see that the second argument and the result are not just of the -/polymorphic/ @a@ type, but of the type: @'Signal' a@. All (synchronous) -sequential circuits work on values of type @'Signal' a@. Combinational -circuits always work on values of, well, not of type @'Signal' a@. A 'Signal' -is an (infinite) list of samples, where the samples correspond to the values -of the 'Signal' at discrete, consecutive, ticks of the /clock/. All (sequential) -components in the circuit are synchronized to this global /clock/. For the -rest of this tutorial, and probably at any moment where you will be working with -CλaSH, you should probably not actively think about 'Signal's as infinite lists -of samples, but just as values that are manipulated by sequential circuits. To -make this even easier, it actually not possible to manipulate the underlying -representation directly: you can only modify 'Signal' values through a set of -primitives such as the 'register' function above. - -Now, let us get back to the functionality of the 'register' function: it is -a simple @latch@ that only changes state at the tick of the global /clock/, and -it has an initial value @a@ which is its output at time 0. We can further -examine the 'register' function by taking a look at the first 4 samples of the -'register' functions applied to a constant signal with the value 8: - ->>> sampleN 4 (register 0 (signal 8)) -[0,8,8,8] - -Where we see that the initial value of the signal is the specified 0 value, -followed by 8's. --} - -{- $mac2 -The 'register' function is our primary sequential building block to capture -/state/. It is used internally by one of the "CLaSH.Prelude" function that we -will use to describe our MAC circuit. Note that the following paragraphs will -only show one of many ways to specify a sequential circuit, at the section we -will show a couple more. - -A principled way to describe a sequential circuit is to use one of the classic -machine models, within the CλaSH prelude library offer standard function to -support the . -To improve sharing, we will combine the transition function and output function -into one. This gives rise to the following Mealy specification of the MAC -circuit: - -@ -macT acc (x,y) = (acc',o) - where - acc' = ma acc (x,y) - o = acc -@ - -Note that the @where@ clause and explicit tuple are just for demonstrative -purposes, without loss of sharing we could've also written: - -@ -macT acc inp = (ma acc inp,acc) -@ - -Going back to the original specification we note the following: - - * 'acc' is the current /state/ of the circuit. - * '(x,y)' is its input. - * 'acc'' is the updated, or next, /state/. - * 'o' is the output. - -When we examine the type of 'macT' we see that is still completely combinational: - ->>> :t macT -macT :: Num t => t -> (t, t) -> (t, t) - -The "CLaSH.Prelude" library contains a function that creates a sequential -circuit from a combinational circuit that has the same Mealy machine type / -shape of @macT@: - -@ -mealy :: (s -> i -> (s,o)) - -> s - -> ('Signal' i -> 'Signal' o) -mealy f initS = ... -@ - -The complete sequential MAC circuit can now be specified as: - -@ -mac = 'mealy' macT 0 -@ - -Where the first argument of @'mealy'@ is our @macT@ function, and the second -argument is the initial state, in this case 0. We can see it is functioning -correctly in our interpreter: - ->>> import qualified Data.List as L ->>> L.take 4 $ simulate mac [(1,1),(2,2),(3,3),(4,4)] -[0,1,5,14] - -Where we simulate our sequential circuit over a list of input samples and take -the first 4 output samples. We have now completed our first sequential circuit -and have made an initial confirmation that it is working as expected. --} - -{- $mac3 -We are now almost at the point that we can create actual hardware, in the form -of a netlist, from our sequential -circuit specification. The first thing we have to do is create a function -called 'topEntity' and ensure that it has a __monomorphic__ type. In our case -that means that we have to give it an explicit type annotation. It might not -always be needed, you can always check the type with the @:t@ command and see -if the function is monomorphic: - -@ -topEntity :: 'Signal' ('Signed' 9, 'Signed' 9) -> 'Signal' ('Signed' 9) -topEntity = mac -@ - -Which makes our circuit work on 9-bit signed integers. Including the above -definition, our complete @MAC.hs@ should now have the following content: - -@ -module MAC where - -import CLaSH.Prelude - -ma acc (x,y) = acc + x * y - -macT acc (x,y) = (acc',o) - where - acc' = ma acc (x,y) - o = acc - -mac = 'mealy' macT 0 - -topEntity :: 'Signal' ('Signed' 9, 'Signed' 9) -> 'Signal' ('Signed' 9) -topEntity = mac -@ - -The 'topEntity' function is the starting point for the CλaSH compiler to -transform your circuit description into a VHDL netlist. It must meet the -following restrictions in order for the CλaSH compiler to work: - - * It must be completely monomorphic - * It must be completely first-order - -Our 'topEntity' meets those restrictions, and so we can convert it successfully -to VHDL by executing the @:vhdl@ command in the interpreter. This will create -a directory called 'vhdl', which contains a directory called @MAC@, which -ultimately contains all the generated VHDL files. You can now load these files -into your favourite VHDL synthesis tool, marking @MAC_topEntity.vhdl@ as the file -containing the top level entity. --} - -{- $mac4 -There are multiple reasons as to why might you want to create a so-called -/testbench/ for the VHDL: - - * You want to compare post-synthesis / post-place&route behaviour to that of - the behaviour of the original VHDL. - * Need representative stimuli for your dynamic power calculations - * Verify that the VHDL output of the CλaSH compiler has the same behaviour as - the Haskell / CλaSH specification. - -For these purposes, you can have CλaSH compiler generate a @MAC_testbench.vhdl@ -file which contains a stimulus generator and an expected output verifier. The -CλaSH compiler looks for the following functions to generate these to aspects: - - 1. @testInput@ for the stimulus generator. - 2. @expectedOutput@ for the output verification. - -Given a @topEntity@ with the type: - -@ -__topEntity__ :: 'Signal' a -> 'Signal' b -@ - -Where @a@ and @b@ are placeholders for monomorphic types: the 'topEntity' is -not allowed to be polymorphic. So given the above type for the 'topEntity', the -type of 'testInput' should be: - -@ -__testInput__ :: 'Signal' a -@ - -And the type of @expectedOutput@ should be: - -@ -__expectedOutput__ :: 'Signal' b -> 'Signal' Bool -@ - -Where the 'expectedOutput' function should assert to 'True' once it has verified -all expected values. The "CLaSH.Prelude" module contains two standard functions -to serve the above purpose, but a user is free to use any CλaSH specification -to describe these two functions. For this tutorial we will be using the -functions specified in the "CLaSH.Prelude" module, which are @'stimuliGenerator'@ -and @'outputVerifier'@: - -@ -testInput :: 'Signal' ('Signed' 9,'Signed' 9) -testInput = 'stimuliGenerator' $('listToVecTH' [(1,1) :: ('Signed' 9,'Signed' 9),(2,2),(3,3),(4,4)]) - -expectedOutput :: 'Signal' ('Signed' 9) -> 'Signal' Bool -expectedOutput = 'outputVerifier' $('listToVecTH' [0 :: 'Signed' 9,1,5,14]) -@ - -This will create a stimulus generator that creates the same inputs as we used -earlier for the simulation of the circuit, and creates an output verifier that -compares against the results we got from our earlier simulation. We can even -simulate the behaviour of the /testbench/: - ->>> sampleN 7 $ expectedOutput (topEntity testInput) -[False,False,False,False -cycle(system1000): 4, outputVerifier -expected value: 14, not equal to actual value: 30 -,True -cycle(system1000): 5, outputVerifier -expected value: 14, not equal to actual value: 46 -,True -cycle(system1000): 6, outputVerifier -expected value: 14, not equal to actual value: 62 -,True] - -We can see that for the first 4 samples, everything is working as expected, -after which warnings are being reported. The reason is that 'stimuliGenerator' -will keep on producing the last sample, (4,4), while the 'outputVerifier' will -keep on expecting the last sample, 14. In the VHDL testbench these errors won't -show, as the the global clock will be stopped after 4 ticks. - -You should now again run @:vhdl@ in the interpreter; this time the compiler -will take a bit longer to generate all the circuits. After it is finished you -can load all the files in your favourite VHDL simulation tool. Once all files -are loaded into the VHDL simulator, run the simulation on the @testbench@ entity. -On questasim / modelsim: doing a @run -all@ will finish once the output verifier -will assert its output to @true@. The generated testbench, modulo the clock -signal generator(s), is completely synthesizable. This means that if you want to -test your circuit on an FPGA, you will only have to replace the clock signal -generator(s) by actual clock sources, such as an onboard PLL. --} - -{- $mac5 -Aside from being to generate VHDL, the CλaSH compiler can also generate Verilog -and SystemVerilog. You can repeat the previous two parts of the tutorial, but -instead of executing the @:vhdl@ command, you execute the @:verilog@ or -@:sytemverilog@ command in the interpreter. This will create a directory called -@verilog@, respectively @systemverilog@, which contains a directory called @MAC@, -which ultimately contains all the generated Verilog and SystemVerilog files. -Verilog files end in the file extension @v@, while SystemVerilog files end in -the file extension @sv@. - -This concludes the main part of this section on \"Your first circuit\", read on -for alternative specifications for the same 'mac' circuit, or just skip to the -next section where we will describe another DSP classic: an FIR filter -structure. --} - -{- $mac6 -* __'Num' instance for 'Signal'__: - - @'Signal' a@ is also also considered a 'Num'eric type as long as the value - type /a/ is also 'Num'eric. This means that we can also use the standard - numeric operators, such as ('*') and ('+'), directly on signals. An - alternative specification of the 'mac' circuit will also use the 'register' - function directly: - - @ - macN (x,y) = acc - where - acc = 'register' 0 (acc + x * y) - @ - -* __'Applicative' instance for 'Signal'__: - - We can also mix the combinational 'ma' function, with the sequential - 'register' function, by lifting the 'ma' function to the sequential 'Signal' - domain using the operators ('<$>' and '<*>') of the 'Applicative' type - class: - - @ - macA (x,y) = acc - where - acc = 'register' 0 acc' - acc' = ma '<$>' acc '<*>' 'bundle' (x,y) - @ - -* __'Control.Monad.State.Lazy.State' Monad__ - - We can also implement the original @macT@ function as a - @'Control.Monad.State.Lazy.State'@ - monadic computation. First we must an extra import statement, right after - the import of "CLaSH.Prelude": - - @ - import Control.Monad.State - @ - - We can then implement macT as follows: - - @ - macTS (x,y) = do - acc <- 'Control.Monad.State.Lazy.get' - 'Control.Monad.State.Lazy.put' (acc + x * y) - return acc - @ - - We can use the 'mealy' function again, although we will have to change - position of the arguments and result: - - @ - asStateM :: (i -> 'Control.Monad.State.Lazy.State' s o) - -> s - -> ('Signal' i -> 'Signal' o) - asStateM f i = 'mealy' g i - where - g s x = let (o,s') = 'Control.Monad.State.Lazy.runState' (f x) s - in (s',o) - @ - - We can then create the complete 'mac' circuit as: - - @ - macS = asStateM macTS 0 - @ --} - -{- $higher_order -An FIR filter is defined as: the dot-product of a set of filter coefficients and -a window over the input, where the size of the window matches the number -of coefficients. - -@ -dotp as bs = 'sum' ('zipWith' (*) as bs) - -fir coeffs x_t = y_t - where - y_t = dotp coeffs xs - xs = 'window' x_t - -topEntity :: 'Signal' ('Signed' 16) -> 'Signal' ('Signed' 16) -topEntity = fir (0 ':>' 1 ':>' 2 ':>' 3 ':>' 'Nil') -@ - -Here we can see that, although the CλaSH compiler handles recursive function -definitions poorly, many of the regular patterns that we often encounter in -circuit design are already captured by the higher-order functions that are -present for the 'Vec'tor type. --} - -{- $composition_sequential -Given a function @f@ of type: - -@ -__f__ :: Int -> (Bool, Int) -> (Int, (Int, Bool)) -@ - -When we want to make compositions of @f@ in @g@ using 'mealy', we have to -write: - -@ -g a b c = (b1,b2,i2) - where - (i1,b1) = 'unbundle' ('mealy' f 0 ('bundle' (a,b))) - (i2,b2) = 'unbundle' ('mealy' f 3 ('bundle' (i1,c))) -@ - -Why do we need these 'bundle', and 'unbundle' functions you might ask? When we -look at the type of 'mealy': - -@ -__mealy__ :: (s -> i -> (s,o)) - -> s - -> ('Signal' i -> 'Signal' o) -@ - -we see that the resulting function has an input of type @'Signal' i@, and an -output of @'Signal' o@. However, the type of @(a,b)@ in the definition of @g@ is: -@('Signal' Bool, 'Signal' Int)@. And the type of @(i1,b1)@ is of type -@('Signal' Int, 'Signal' Bool)@. - -Syntactically, @'Signal' (Bool,Int)@ and @('Signal' Bool, 'Signal' Int)@ are /unequal/. -So we need to make a conversion between the two, that is what 'bundle' and -'unbundle' are for. In the above case 'bundle' gets the type: - -@ -__bundle__ :: ('Signal' Bool, 'Signal' Int) -> 'Signal' (Bool,Int) -@ - -and 'unbundle': - -@ -__unbundle__ :: 'Signal' (Int,Bool) -> ('Signal' Int, 'Signal' Bool) -@ - -The /true/ types of these two functions are, however: - -@ -__bundle__ :: 'Bundle' a => 'Unbundled' a -> 'Signal' a -__unbundle__ :: 'Bundle' a => 'Signal' a -> 'Unbundled' a -@ - -'Unbundled' is an -belonging to the 'Bundle' , -which, together with 'bundle' and 'unbundle' defines the isomorphism between a -product type of 'Signal's and a 'Signal' of a product type. That is, while -@(Signal a, Signal b)@ and @Signal (a,b)@ are not equal, they are /isomorphic/ -and can be converted from, or to, the other using 'bundle' and 'unbundle'. - -Instances of this 'Bundle' type-class are defined as /isomorphisms/ for: - - * All tuples until and including 8-tuples - * The 'Vec'tor type - -But they are defined as /identities/ for: - - * All elementary / primitive types such as: 'Bit', 'Bool', @'Signed' n@, etc. - -That is: - -@ -instance 'Bundle' (a,b) where - type 'Unbundled'' clk (a,b) = ('Signal'' clk a, 'Signal'' clk b) - bundle (a,b) = (,) '<$>' a '<*>' b - unbundle tup = (fst '<$>' tup, snd '<*>' tup) -@ - -but, - -@ -instance 'Bundle' Bool where - type 'Unbundled'' clk Bool = 'Signal'' clk Bool - bundle s = s - unbundle s = s -@ - -What you need take away from the above is that a product type (e.g. a tuple) of -'Signal's is not syntactically equal to a 'Signal' of a product type, but that -the functions of the 'Bundle' type class allow easy conversion between the two. - -As a final note on this section we also want to mention the 'mealyB' function, -which does the bundling and unbundling for us: - -@ -mealyB :: ('Bundle' i, 'Bundle' o) - => (s -> i -> (s,o)) - -> s - -> ('Unbundled' i -> 'Unbundled' o) -@ - -Using 'mealyB' we can define @g@ as: - -@ -g a b c = (b1,b2,i2) - where - (i1,b1) = 'mealyB' f 0 (a,b) - (i2,b2) = 'mealyB' f 3 (i1,c) -@ - -The general rule of thumb is: always use 'mealy', unless you do pattern matching -or construction of product types, then use 'mealyB'. --} - -{- $annotations -The 'TopEntity' annotations described in this section make it easier to put your -CλaSH design on an FPGA. - -We can exert some control how the top level function is created by the CλaSH -compiler by annotating the @topEntity@ function with a 'TopEntity' annotation. -You apply these annotations using the @ANN@ pragma like so: - -@ -{\-\# ANN topEntity (TopEntity {t_name = ..., ... }) \#-\} -topEntity x = ... -@ - -For example, given the following specification: - -@ -topEntity :: Signal Bit -> Signal (BitVector 8) -topEntity key1 = leds - where - key1R = isRising 1 key1 - leds = mealy blinkerT (1,False,0) key1R - -blinkerT (leds,mode,cntr) key1R = ((leds',mode',cntr'),leds) - where - -- clock frequency = 50e6 (50 MHz) - -- led update rate = 333e-3 (every 333ms) - cnt_max = 16650000 -- 50e6 * 333e-3 - - cntr' | cntr == cnt_max = 0 - | otherwise = cntr + 1 - - mode' | key1R = not mode - | otherwise = mode - - leds' | cntr == 0 = if mode then complement leds - else rotateL leds 1 - | otherwise = leds -@ - -The CλaSH compiler will normally generate the following @Blinker_topEntity.vhdl@ file: - -@ --- Automatically generated VHDL -library IEEE; -use IEEE.STD_LOGIC_1164.ALL; -use IEEE.NUMERIC_STD.ALL; -use IEEE.MATH_REAL.ALL; -use work.all; -use work.Blinker_types.all; - -entity Blinker_topEntity is - port(input_0 : in std_logic_vector(0 downto 0); - -- clock - system1000 : in std_logic; - -- asynchronous reset: active low - system1000_rstn : in std_logic; - output_0 : out std_logic_vector(7 downto 0)); -end; - -architecture structural of Blinker_topEntity is -begin - Blinker_topEntity_0_inst : entity Blinker_topEntity_0 - port map - (key1_i1 => input_0 - ,system1000 => system1000 - ,system1000_rstn => system1000_rstn - ,topLet_o => output_0); -end; -@ - -However, if we add the following 'TopEntity' annotation in the file: - -@ -{\-\# ANN topEntity - ('defTop' - { t_name = "blinker" - , t_inputs = [\"KEY1\"] - , t_outputs = [\"LED\"] - , t_extraIn = [ (\"CLOCK_50\", 1) - , (\"KEY0\" , 1) - ] - , t_clocks = [ 'altpll' "altpll50" "CLOCK_50(0)" "not KEY0(0)" ] - }) \#-\} -@ - -The CλaSH compiler will generate the following @blinker.vhdl@ file instead: - -@ --- Automatically generated VHDL -library IEEE; -use IEEE.STD_LOGIC_1164.ALL; -use IEEE.NUMERIC_STD.ALL; -use IEEE.MATH_REAL.ALL; -use work.all; -use work.Blinker_types.all; - -entity blinker is - port(KEY1 : in std_logic_vector(0 downto 0); - CLOCK_50 : in std_logic_vector(0 downto 0); - KEY0 : in std_logic_vector(0 downto 0); - LED : out std_logic_vector(7 downto 0)); -end; - -architecture structural of blinker is - signal system1000 : std_logic; - signal system1000_rstn : std_logic; - signal altpll50_locked : std_logic; -begin - altpll50_inst : entity altpll50 - port map - (inclk0 => CLOCK_50(0) - ,c0 => system1000 - ,areset => not KEY0(0) - ,locked => altpll50_locked); - - -- reset system1000_rstn is asynchronously asserted, but synchronously de-asserted - resetSync_n_0 : block - signal n_1 : std_logic; - signal n_2 : std_logic; - begin - process(system1000,altpll50_locked) - begin - if altpll50_locked = '0' then - n_1 <= '0'; - n_2 <= '0'; - elsif rising_edge(system1000) then - n_1 <= '1'; - n_2 <= n_1; - end if; - end process; - - system1000_rstn <= n_2; - end block; - - Blinker_topEntity_0_inst : entity Blinker_topEntity_0 - port map - (key1_i1 => KEY1 - ,system1000 => system1000 - ,system1000_rstn => system1000_rstn - ,topLet_o => LED); -end; -@ - -Where we now have: - -* A top-level component that is called @blinker@. -* Inputs and outputs that have a /user/-chosen name: @KEY1@, @LED@, etc. -* An instantiated - component providing a stable clock signal from the free-running clock pin - @CLOCK_50@. -* A reset that is /asynchronously/ asserted by the @lock@ signal originating from - the PLL, meaning that your design is kept in reset until the PLL is - providing a stable clock. - The reset is additionally /synchronously/ de-asserted to prevent - - of your design due to unlucky timing of the de-assertion of the reset. - -See the documentation of 'TopEntity' for the meaning of all its fields. --} - -{- $primitives -There are times when you already have an existing piece of IP, or there are -times where you need the VHDL to have a specific shape so that the VHDL -synthesis tool can infer a specific component. In these specific cases you can -resort to defining your own VHDL primitives. Actually, most of the primitives -in CλaSH are specified in the same way as you will read about in this section. -There are perhaps 10 (at most) functions which are truly hard-coded into the -CλaSH compiler. You can take a look at the files in - -(or -for the Verilog primitives or -for the SystemVerilog primitives) if you want to know which functions are defined -as \"regular\" primitives. The compiler looks for primitives in two locations: - -* The official install location: e.g. - * @$CABAL_DIR\/share\/\\/clash-vhdl\-\/primitives@ - * @$CABAL_DIR\/share\/\\/clash-verilog\-\/primitives@ - * @$CABAL_DIR\/share\/\\/clash-systemverilog\-\/primitives@ -* The current directory (the location given by @pwd@) - -Where redefined primitives in the current directory will overwrite those in -the official install location. For now, files containing primitive definitions -must end in the @.json@ file-extension. - -CλaSH differentiates between two types of primitives, /expression/ primitives -and /declaration/ primitives, corresponding to whether the primitive is a VHDL -/expression/ or a VHDL /declaration/. We will first explore /expression/ -primitives, using 'Signed' multiplication ('*') as an example. The -"CLaSH.Sized.Internal.Signed" module specifies multiplication as follows: - -@ -(*#) :: 'GHC.TypeLits.KnownNat' n => 'Signed' n -> 'Signed' n -> 'Signed' n -(S a) *# (S b) = fromInteger_INLINE (a * b) -{\-\# NOINLINE (*#) \#-\} -@ - -For which the VHDL /expression/ primitive is: - -@ -{ \"BlackBox\" : - { "name" : "CLaSH.Sized.Internal.Signed.*#" - , "templateE" : "resize(~ARG[1] * ~ARG[2], ~LIT[0])" - } -} -@ - -The @name@ of the primitive is the /fully qualified/ name of the function you -are creating the primitive for. Because we are creating an /expression/ -primitive we define a @template__E__@ field. As the name suggest, it is a VHDL -/template/, meaning that the compiler must fill in the holes heralded by the -tilde (~). Here: - - * @~ARG[1]@ denotes the second argument given to the @(*#)@ function, which - corresponds to the LHS of the ('*') operator. - * @~ARG[2]@ denotes the third argument given to the @(*#)@ function, which - corresponds to the RHS of the ('*') operator. - * @~LIT[0]@ denotes the first argument given to the @(*#)@ function, with - the extra condition that it must be a @LIT@eral. If for some reason this - first argument does not turn out to be a literal then the compiler will - raise an error. This first arguments corresponds to the \"@'KnownNat' n@\" - class constraint. - -An extensive list with all of the template holes will be given the end of this -section. What we immediately notice is that class constraints are counted as -normal arguments in the primitive definition. This is because these class -constraints are actually represented by ordinary record types, with fields -corresponding to the methods of the type class. In the above case, 'KnownNat' -is actually just like a @newtype@ wrapper for 'Integer'. - -The second kind of primitive that we will explore is the /declaration/ primitive. -We will use 'blockRam#' as an example, for which the Haskell/CλaSH code is: - -@ --- | blockRAM primitive -blockRam# :: 'KnownNat' n - => 'SClock' clk -- ^ 'Clock' to synchronize to - -> 'Vec' n a -- ^ Initial content of the BRAM, also - -- determines the size, @n@, of the BRAM. - -- - -- __NB__: __MUST__ be a constant. - -> 'Signal'' clk Int -- ^ Read address @r@ - -> 'Signal'' clk Bool -- ^ Write enable - -> 'Signal'' clk Int -- ^ Write address @w@ - -> 'Signal'' clk a -- ^ Value to write (at address @w@) - -> 'Signal'' clk a - -- ^ Value of the @blockRAM@ at address @r@ from the previous clock - -- cycle -blockRam# clk content rd en wr din = - 'register'' clk ('errorX' "blockRam#: intial value undefined") dout - where - szI = 'length' content - dout = runST $ do - arr <- newListArray (0,szI-1) ('toList' content) - traverse (ramT arr) ('bundle' (rd,en,wr,din)) - - ramT :: STArray s Int e -> (Int,Bool,Int,e) -> ST s e - ramT ram (r,e,w,d) = do - -- reading from address using an 'X' exception results in an 'X' result - r' <- unsafeIOToST $ - catch (evaluate r >>= (return . Right)) - (\(err :: XException) -> return (Left (throw err))) - d' <- case r' of - Right r2 -> readArray ram r2 - Left err -> return err - -- writing to an address using an 'X' exception makes everything 'X' - when e (writeArray ram w d) - return d' -{\-\# NOINLINE blockRam# \#-\} -@ - -And for which the /declaration/ primitive is: - -@ -{ \"BlackBox\" : - { "name" : "CLaSH.Prelude.BlockRam.blockRam#" - , "type" : -"blockRam# :: KnownNat n -- ARG[0] - => SClock clk -- clk, ARG[1] - -> Vec n a -- init, ARG[2] - -> Signal' clk Int -- rd, ARG[3] - -> Signal' clk Bool -- wren, ARG[4] - -> Signal' clk Int -- wr, ARG[5] - -> Signal' clk a -- din, ARG[6] - -> Signal' clk a" - , "templateD" : -"-- blockRam begin -~GENSYM[~COMPNAME_blockRam][0] : block - signal ~GENSYM[RAM][1] : ~TYP[2] := ~LIT[2];~IF ~VIVADO ~THEN - signal ~GENSYM[dout][2] : std_logic_vector(~SIZE[~TYP[6]]-1 downto 0);~ELSE - signal ~SYM[2] : ~TYP[6];~FI - signal ~GENSYM[rd][3] : integer range 0 to ~LIT[0] - 1; - signal ~GENSYM[wr][4] : integer range 0 to ~LIT[0] - 1; -begin - ~SYM[3] <= to_integer(~ARG[3]) - -- pragma translate_off - mod ~LIT[0] - -- pragma translate_on - ; - - ~SYM[4] <= to_integer(~ARG[5]) - -- pragma translate_off - mod ~LIT[0] - -- pragma translate_on - ; - - ~GENSYM[blockRam_sync][5] : process(~CLK[1]) - begin - if rising_edge(~CLK[1]) then - if ~ARG[4] then~IF ~VIVADO ~THEN - ~SYM[1](~SYM[4]) <= ~TOBV[~ARG[6]][~TYP[6]];~ELSE - ~SYM[1](~SYM[4]) <= ~ARG[6];~FI - end if; - ~SYM[2] <= ~SYM[1](~SYM[3]); - end if; - end process;~IF ~VIVADO ~THEN - ~RESULT <= ~FROMBV[~SYM[2]][~TYPO];~ELSE - ~RESULT <= ~SYM[2];~FI -end block; --- blockRam end" - } -} -@ - -Again, the @name@ of the primitive is the fully qualified name of the function -you are creating the primitive for. Because we are creating a /declaration/ -primitive we define a @template__D__@ field. Instead of discussing what the -individual template holes mean in the above context, we will instead just give -a general listing of the available template holes: - -* @~RESULT@: VHDL signal to which the result of a primitive must be assigned - to. NB: Only used in a /declaration/ primitive. -* @~ARG[N]@: @(N+1)@'th argument to the function. -* @~LIT[N]@: @(N+1)@'th argument to the function An extra condition that must - hold is that this @(N+1)@'th argument is an (integer) literal. -* @~CLK[N]@: Clock signal to which the @(N+1)@'th argument is synchronized to. -* @~CLKO@: Clock signal to which the result is synchronized to. -* @~RST[N]@: Asynchronous reset signal to the clock to which the @(N+1)@'th - argument is synchronized to. -* @~RSTO@: Asynchronous reset signal to the clock to which the result is - synchronized to. -* @~TYP[N]@: VHDL type of the @(N+1)@'th argument. -* @~TYPO@: VHDL type of the result. -* @~TYPM[N]@: VHDL type/name/ of the @(N+1)@'th argument; used in /type/ - /qualification/. -* @~TYPM@: VHDL type/name/ of the result; used in /type qualification/. -* @~ERROR[N]@: Error value for the VHDL type of the @(N+1)@'th argument. -* @~ERRORO@: Error value for the VHDL type of the result. -* @~GENSYM[\][N]@: Create a unique name, trying to stay as close to - the given @\@ as possible. This unique symbol can be referred to in - other places using @~SYM[N]@. -* @~SYM[N]@: a reference to the unique symbol created by @~GENSYM[\][N]@. -* @~SIGD[\][N]@: Create a signal declaration, using @\@ as the name - of the signal, and the type of the @(N+1)@'th argument. -* @~SIGDO[\]@: Create a signal declaration, using @\@ as the name - of the signal, and the type of the result. -* @~TYPELEM[\]@: The element type of the vector type represented by @\@. - The content of @\@ must either be: @TYPM[N]@, @TYPO@, or @TYPELEM[\]@. -* @~COMPNAME@: The name of the component in which the primitive is instantiated. -* @~LENGTH[\]@: The vector length of the type represented by @\@. -* @~DEPTH[\]@: The tree depth of the type represented by @\@. - The content of @\@ must either be: @TYPM[N]@, @TYPO@, or @TYPELEM[\]@. -* @~SIZE[\]@: The number of bits needed to encode the type represented by @\@. - The content of @\@ must either be: @TYPM[N]@, @TYPO@, or @TYPELEM[\]@. -* @~IF \ ~THEN \ ~ELSE \ ~FI@: renders the \ - part when \ evaluates to /0/, and renders the \ in all - other cases. Valid @\@s are @~LENGTH[\]@, @~SIZE[\]@, - @~DEPTH[\]@, and @~VIVADO@. -* @~VIVADO@: /1/ when CλaSH compiler is invoked with the @-clash-xilinx@ or - @-clash-vivado@ flag. To be used with in an @~IF .. ~THEN .. ~ElSE .. ~FI@ - statement. -* @~FROMBV[\][\]@: create conversion code that so that the - expression in @\@ is converted to a bit vector (@std_logic_vector@). - The @\@ hole indicates the type of the expression and must be either - @~TYP[N]@, @~TYPO@, or @~TYPELEM[\]@. -* @~TOBV[\][\]@: create conversion code that so that the - expression in @\@, which has a bit vector (@std_logic_vector@) type, is - converted to type indicated by @\@. The @\@ hole indicates the - must be either @~TYP[N]@, @~TYPO@, or @~TYPELEM[\]@. - -Some final remarks to end this section: VHDL primitives are there to instruct the -CλaSH compiler to use the given VHDL template, instead of trying to do normal -synthesis. As a consequence you can use constructs inside the Haskell -definitions that are normally not synthesizable by the CλaSH compiler. However, -VHDL primitives do not give us /co-simulation/: where you would be able to -simulate VHDL and Haskell in a /single/ environment. If you still want to -simulate your design in Haskell, you will have to describe, in a cycle- and -bit-accurate way, the behaviour of that (potentially complex) IP you are trying -to include in your design. - -Perhaps in the future, someone will figure out how to connect the two simulation -worlds, using e.g. VHDL's foreign function interface VHPI. --} - -{- $vprimitives -For those who are interested, the equivalent Verilog primitives are: - -@ -{ \"BlackBox\" : - { "name" : "CLaSH.Sized.Internal.Signed.*#" - , "templateE" : "~ARG[1] * ~ARG[2]" - } -} -@ - -and - -@ -{ \"BlackBox\" : - { "name" : "CLaSH.Prelude.BlockRam.blockRam#" - , "type" : -"blockRam# :: KnownNat n -- ARG[0] - => SClock clk -- clk, ARG[1] - -> Vec n a -- init, ARG[2] - -> Signal' clk Int -- rd, ARG[3] - -> Signal' clk Bool -- wren, ARG[4] - -> Signal' clk Int -- wr, ARG[5] - -> Signal' clk a -- din, ARG[6] - -> Signal' clk a" - , "templateD" : -"// blockRam begin -reg ~TYPO ~GENSYM[RAM][0] [0:~LIT[0]-1]; -reg ~TYPO ~GENSYM[dout][1]; - -reg ~TYP[2] ~GENSYM[ram_init][2]; -integer ~GENSYM[i][3]; -initial begin - ~SYM[2] = ~ARG[2]; - for (~SYM[3]=0; ~SYM[3] < ~LIT[0]; ~SYM[3] = ~SYM[3] + 1) begin - ~SYM[0][~LIT[0]-1-~SYM[3]] = ~SYM[2][~SYM[3]*~SIZE[~TYPO]+:~SIZE[~TYPO]]; - end -end - -always @(posedge ~CLK[1]) begin : ~GENSYM[~COMPNAME_blockRam][4] - if (~ARG[4]) begin - ~SYM[0][~ARG[5]] <= ~ARG[6]; - end - ~SYM[1] <= ~SYM[0][~ARG[3]]; -end - -assign ~RESULT = ~SYM[1]; -// blockRam end" - } -} -@ - --} - -{- $svprimitives -And the equivalent SystemVerilog primitives are: - -@ -{ \"BlackBox\" : - { "name" : "CLaSH.Sized.Internal.Signed.*#" - , "templateE" : "~ARG[1] * ~ARG[2]" - } -} -@ - -and - -@ -{ \"BlackBox\" : - { "name" : "CLaSH.Prelude.BlockRam.blockRam#" - , "type" : -"blockRam# :: KnownNat n -- ARG[0] - => SClock clk -- clk, ARG[1] - -> Vec n a -- init, ARG[2] - -> Signal' clk Int -- rd, ARG[3] - -> Signal' clk Bool -- wren, ARG[4] - -> Signal' clk Int -- wr, ARG[5] - -> Signal' clk a -- din, ARG[6] - -> Signal' clk a" - , "templateD" : -"// blockRam begin -~SIGD[~GENSYM[RAM][0]][2]; -logic [~SIZE[~TYP[6]]-1:0] ~GENSYM[dout][1]; -initial begin - ~SYM[0] = ~LIT[2]; -end -always @(posedge ~CLK[1]) begin : ~GENSYM[~COMPNAME_blockRam][2] - if (~ARG[4]) begin - ~SYM[0][~ARG[5]] <= ~TOBV[~ARG[6]][~TYP[6]]; - end - ~SYM[1] <= ~SYM[0][~ARG[3]]; -end -assign ~RESULT = ~FROMBV[~SYM[1]][~TYP[6]]; -// blockRam end" - } - } -@ - --} - -{- $multiclock #multiclock# -CλaSH supports multi-clock designs, though perhaps in a slightly limited form. -What is possible is: - -* Explicitly assign clocks to memory primitives. -* Synchronise between differently-clocked parts of your design in a type-safe - way. - -What is /not/ possible is: - -* Generate a clock signal in module A, and assign this clock signal to a memory - primitive in module B. - -What this means is that when CλaSH converts your design to VHDL/(System)Verilog, -you end up with a top-level module/entity with multiple clock and reset ports -for the different clock domains. If you're targeting an FPGA, you can use e.g. a - or - -to provide the clock signals. - -== Building a FIFO synchroniser - -This part of the tutorial assumes you know what -is, and how it can never truly be avoided in any asynchronous circuit. Also -it assumes that you are familiar with the design of synchronizer circuits, and -why a dual flip-flop synchroniser only works for bit-synchronisation and not -word-synchronisation. -The explicitly clocked versions of all synchronous functions and primitives can -be found in "CLaSH.Prelude.Explicit", which also re-exports the functions in -"CLaSH.Signal.Explicit". We will use those functions to create a FIFO where -the read and write port are synchronised to different clocks. Below you can find -the code to build the FIFO synchroniser based on the design described in: - - -We start with enable a few options that will make writing the type-signatures for -our components a bit easier. We'll also import the standard "CLaSH.Prelude" -module, and the "CLaSH.Prelude.Explicit" module for our explicitly clocked -synchronous functions: - -@ -{\-\# LANGUAGE PartialTypeSignatures \#-\} -{\-\# OPTIONS_GHC -fno-warn-partial-type-signatures \#-\} -module MultiClockFifo where - -import CLaSH.Prelude -import CLaSH.Prelude.Explicit -import Data.Maybe (isJust) -@ - -Then we'll start with the /heart/ of the FIFO synchroniser, an asynchronous RAM -in the form of 'asyncRam''. It's called an asynchronous RAM because the read -port is not synchronised to any clock (though the write port is). Note that in -CλaSH we don't really have asynchronous logic, there is only combinational and -synchronous logic. As a consequence, we see in the type signature of 'asyncRam'': - -@ -__asyncRam'__ - :: _ - => SClock wclk -- ^ Clock to which to synchronise the write port of the RAM - -> SClock rclk -- ^ Clock to which the read address signal __r__ is synchronised - -> SNat n -- ^ Size __n__ of the RAM - -> Signal' rclk addr -- ^ Read address __r__ - -> Signal' wclk (Maybe (addr,a)) -- ^ (write address @w@, value to write) - -> Signal' rclk a -- ^ Value of the RAM at address __r__ -@ - -that the signal containing the read address __r__ is synchronised to a different -clock. That is, there is __no__ such thing as an @AsyncSignal@ in CλaSH. - -We continue by instantiating the 'asyncRam'': - -@ -fifoMem wclk rclk addrSize wfull raddr wdataM = - 'asyncRam'' wclk rclk - ('pow2SNat' addrSize) - raddr - ('mux' (not \<$\> wfull) - wdataM - (pure Nothing)) -@ - -We see that we give it @2^addrSize@ elements, where @addrSize@ is the bit-size -of the address. Also, we only write new values to the RAM when a new write is -requested, indicated by @wdataM@ having a $Just$ value, and the buffer is not -full, indicated by @wfull@. - -The next part of the design calculates the read and write address for the -asynchronous RAM, and creates the flags indicating whether the FIFO is full -or empty. The address and flag generator is given in 'mealy' machine style: - -@ -ptrCompareT addrSize flagGen (bin,ptr,flag) (s_ptr,inc) = - ((bin',ptr',flag') - ,(flag,addr,ptr)) - where - -- GRAYSTYLE2 pointer - bin' = bin + 'boolToBV' (inc && not flag) - ptr' = (bin' \`shiftR\` 1) \`xor\` bin' - addr = 'slice' (addrSize ``subSNat`` d1) d0 bin - - flag' = flagGen ptr' s_ptr -@ - -It is parametrised in both address size, @addrSize@, and status flag generator, -@flagGen@. It has two inputs, @s_ptr@, the synchronised pointer from the other -clock domain, and @inc@, which indicates we want to perform a write or read of -the FIFO. It creates three outputs: @flag@, the full or empty flag, @addr@, the -read or write address into the RAM, and @ptr@, the Gray-encoded version of the -read or write address which will be synchronised between the two clock domains. - -Next follow the initial states of address generators, and the flag generators -for the empty and full flags: - -@ --- FIFO empty: when next pntr == synchronized wptr or on reset -isEmpty = (==) -rptrEmptyInit = (0,0,True) - --- FIFO full: when next pntr == synchronized {~wptr[addrSize:addrSize-1],wptr[addrSize-2:0]} -isFull addrSize ptr s_ptr = - ptr == 'complement' ('slice' addrSize (addrSize ``subSNat`` d1) s_ptr) '++#' - 'slice' (addrSize ``subSNat`` d2) d0 s_ptr - -wptrFullInit = (0,0,False) -@ - -We create a dual flip-flop synchroniser to be used to synchronise the -Gray-encoded pointers between the two clock domains: - -@ -ptrSync clk1 clk2 = 'register'' clk2 0 - . 'register'' clk2 0 - . 'unsafeSynchronizer' clk1 clk2 -@ - -It uses the 'unsafeSynchroniser' primitive, which is needed to go from one clock -domain to the other. All synchronizers are specified in terms of -'unsafeSynchronizer' (see for example the ). -The 'unsafeSynchronizer' primitive is turned into a (bundle of) wire(s) by the -CλaSH compiler, so developers must ensure that it is only used as part of a -proper synchronizer. - -Finally we combine all the component in: - -@ -fifo - :: _ - => SNat (addrSize + 2) - -> SClock wclk - -> SClock rclk - -> Signal' rclk Bool - -> Signal' wclk (Maybe a) - -> (Signal' rclk a, Signal' rclk Bool, Signal' wclk Bool) -fifo addrSize wclk rclk rinc wdataM = (rdata,rempty,wfull) - where - s_rptr = ptrSync rclk wclk rptr - s_wptr = ptrSync wclk rclk wptr - - rdata = fifoMem wclk rclk addrSize wfull raddr - (liftA2 (,) \<$\> (Just \<$\> waddr) \<*\> wdataM) - - (rempty,raddr,rptr) = 'mealyB'' rclk (ptrCompareT addrSize isEmpty) rptrEmptyInit - (s_wptr,rinc) - - (wfull,waddr,wptr) = 'mealyB'' wclk (ptrCompareT addrSize (isFull addrSize)) - wptrFullInit (s_rptr,isJust \<$\> wdataM) -@ - -where we first specify the synchronisation of the read and the write pointers, -instantiate the asynchronous RAM, and instantiate the read address \/ pointer \/ -flag generator and write address \/ pointer \/ flag generator. - -Ultimately, the whole file containing our FIFO design will look like this: - -@ -{\-\# LANGUAGE PartialTypeSignatures \#-\} -{\-\# OPTIONS_GHC -fno-warn-partial-type-signatures \#-\} -module MultiClockFifo where - -import CLaSH.Prelude -import CLaSH.Prelude.Explicit -import Data.Maybe (isJust) - -fifoMem wclk rclk addrSize wfull raddr wdataM = - 'asyncRam'' wclk rclk - ('pow2SNat' addrSize) - raddr - ('mux' (not \<$\> wfull) - wdataM - (pure Nothing)) - -ptrCompareT addrSize flagGen (bin,ptr,flag) (s_ptr,inc) = - ((bin',ptr',flag') - ,(flag,addr,ptr)) - where - -- GRAYSTYLE2 pointer - bin' = bin + 'boolToBV' (inc && not flag) - ptr' = (bin' \`shiftR\` 1) \`xor\` bin' - addr = 'slice' (addrSize ``subSNat`` d1) d0 bin - - flag' = flagGen ptr' s_ptr - --- FIFO empty: when next pntr == synchronized wptr or on reset -isEmpty = (==) -rptrEmptyInit = (0,0,True) - --- FIFO full: when next pntr == synchronized {~wptr[addrSize:addrSize-1],wptr[addrSize-2:0]} -isFull addrSize ptr s_ptr = - ptr == 'complement' ('slice' addrSize (addrSize ``subSNat`` d1) s_ptr) '++#' - 'slice' (addrSize ``subSNat`` d2) d0 s_ptr - -wptrFullInit = (0,0,False) - --- Dual flip-flop synchroniser -ptrSync clk1 clk2 = 'register'' clk2 0 - . 'register'' clk2 0 - . 'unsafeSynchronizer' clk1 clk2 - --- Async FIFO synchroniser -fifo - :: _ - => SNat (addrSize + 2) - -> SClock wclk - -> SClock rclk - -> Signal' rclk Bool - -> Signal' wclk (Maybe a) - -> (Signal' rclk a, Signal' rclk Bool, Signal' wclk Bool) -fifo addrSize wclk rclk rinc wdataM = (rdata,rempty,wfull) - where - s_rptr = ptrSync rclk wclk rptr - s_wptr = ptrSync wclk rclk wptr - - rdata = fifoMem wclk rclk addrSize wfull raddr - (liftA2 (,) \<$\> (Just \<$\> waddr) \<*\> wdataM) - - (rempty,raddr,rptr) = 'mealyB'' rclk (ptrCompareT addrSize isEmpty) rptrEmptyInit - (s_wptr,rinc) - - (wfull,waddr,wptr) = 'mealyB'' wclk (ptrCompareT addrSize (isFull addrSize)) - wptrFullInit (s_rptr,isJust \<$\> wdataM) -@ - -== Instantiating a FIFO synchroniser - -Having finished our FIFO synchroniser it's time to instantiate with concrete -clock domains. Let us assume we have part of our system connected to an ADC -which runs at 20 MHz, and we have created an FFT component running at only 9 MHz, -while the rest of our system runs at 50 MHz. What we want to do connect part -of our design connected to the ADC, and running at 20 MHz, to part of our design -connected to the FFT running at 9 MHz. - -First, we must calculate the relative clock periods using 'freqCalc': - ->>> freqCalc [20,9,50] -[45,100,18] - -We can then create the clocks: - -@ -type ClkADC = 'Clk \"ADC\" 45 -type ClkFFT = 'Clk \"FFT\" 100 -type ClkSys = 'Clk \"System\" 18 - -clkADC :: SClock ClkADC -clkADC = sclock - -clkFFT :: SClock ClkFFT -clkFFT = sclock - -clkSys :: SClock ClkSys -clkSys = sclock -@ - -and subsequently a 256-space FIFO synchroniser that safely bridges the ADC clock -domain and to the FFT clock domain: - -@ -adcToFFT - :: Signal' ClkFFT Bool - -> Signal' ClkADC (Maybe (SFixed 8 8)) - -> (Signal' ClkFFT (SFixed 8 8), Signal' ClkFFT Bool, Signal' ClkADC Bool) -adcToFFT = fifo d8 clkADC clkFFT -@ - --} - -{- $conclusion -For now, this is the end of this tutorial. We will be adding updates over time, -so check back from time to time. For now, we recommend that you continue with -exploring the "CLaSH.Prelude" module, and get a better understanding of the -capabilities of CλaSH in the process. --} - -{- $errorsandsolutions -A list of often encountered errors and their solutions: - -* __Type error: Couldn't match expected type @'Signal' (a,b)@ with actual type__ - __@('Signal' a, 'Signal' b)@__: - - Signals of product types and product types (to which tuples belong) of - signals are __isomorphic__ due to synchronisity principle, but are not - (structurally) equal. Use the 'bundle' function to convert from a product type - to the signal type. So if your code which gives the error looks like: - - @ - ... = f a b (c,d) - @ - - add the 'bundle'' function like so: - - @ - ... = f a b ('bundle' (c,d)) - @ - - Product types supported by 'bundle' are: - - * All tuples until and including 8-tuples - * The 'Vec'tor type - - NB: Use 'bundle'' when you are using explicitly clocked @'Signal''@s - -* __Type error: Couldn't match expected type @('Signal' a, 'Signal' b)@ with__ - __ actual type @'Signal' (a,b)@__: - - Product types (to which tuples belong) of signals and signals of product - types are __isomorphic__ due to synchronicity principle, but are not - (structurally) equal. Use the 'unbundle' function to convert from a signal - type to the product type. So if your code which gives the error looks like: - - @ - (c,d) = f a b - @ - - add the 'unbundle' function like so: - - @ - (c,d) = 'unbundle' (f a b) - @ - - Product types supported by 'unbundle' are: - - * All tuples until and including 8-tuples - * The 'Vec'tor type - - NB: Use 'unbundle'' when you are using explicitly clocked @'Signal''@s - -* __CLaSH.Netlist(..): Not in normal form: \: \__: - - A function could not be transformed into the expected normal form. This - usually means one of the following: - - * The @topEntity@ has residual polymorphism. - * The @topEntity@ has higher-order arguments, or a higher-order result. - * You are using types which cannot be represented in hardware. - - The solution for all the above listed reasons is quite simple: remove them. - That is, make sure that the @topEntity@ is completely monomorphic and - first-order. Also remove any variables and constants/literals that have a - non-representable type, see <#unsupported Unsupported Haskell features> to - find out which types are not representable. - -* __CLaSH.Normalize(94): Expr belonging to bndr: \ remains__ - __recursive after normalization__: - - * If you actually wrote a recursive function, rewrite it to a non-recursive - one using e.g. one of the higher-order functions in "CLaSH.Sized.Vector" :-) - - * You defined a recursively defined value, but left it polymorphic: - - @ - topEntity x y = acc - where - acc = 'register' 3 (acc + x * y) - @ - - The above function, works for any number-like type. This means that @acc@ is - a recursively defined __polymorphic__ value. Adding a monomorphic type - annotation makes the error go away: - - @ - topEntity :: 'Signal' ('Signed' 8) -> 'Signal' ('Signed' 8) -> 'Signal' ('Signed' 8) - topEntity x y = acc - where - acc = 'register' 3 (acc + x * y) - @ - - Or, alternatively: - - @ - topEntity x y = acc - where - acc = 'register' (3 :: 'Signed' 8) (acc + x * y) - @ - -* __CLaSH.Normalize.Transformations(155): InlineNonRep: \ already__ - __inlined 100 times in:\, \__: - - You left the @topEntity@ function polymorphic or higher-order: use - @:t topEntity@ to check if the type is indeed polymorphic or higher-order. - If it is, add a monomorphic type signature, and / or supply higher-order - arguments. - -* __Can't make testbench for: \__: - - * Don't worry, it's actually only a warning. - - * The @topEntity@ function does __not__ have exactly 1 argument. If your - @topEntity@ has no arguments, you're out of luck for now. If it has - multiple arguments, consider bundling them in a tuple. - -* __\<*** Exception: \<\\>__ or "blinking cursor" - - You are using value-recursion, but one of the 'Vec'tor functions that you - are using is too /strict/ in one of the recursive arguments. For example: - - @ - -- Bubble sort for 1 iteration - sortV xs = 'map' fst sorted ':<' (snd ('last' sorted)) - where - lefts = 'head' xs :> 'map' snd ('init' sorted) - rights = 'tail' xs - sorted = 'zipWith' compareSwapL lefts rights - - -- Compare and swap - compareSwapL a b = if a < b then (a,b) - else (b,a) - @ - - Will not terminate because 'zipWith' is too strict in its second argument. - - In this case, adding 'lazyV' on 'zipWith's second argument: - - @ - sortVL xs = 'map' fst sorted ':<' (snd ('last' sorted)) - where - lefts = 'head' xs :> map snd ('init' sorted) - rights = 'tail' xs - sorted = 'zipWith' compareSwapL ('lazyV' lefts) rights - @ - - Results in a successful computation: - - >>> sortVL (4 :> 1 :> 2 :> 3 :> Nil) - <1,2,3,4> --} - -{- $limitations #limitations# -Here is a list of Haskell features for which the CλaSH compiler has only -/limited/ support (for now): - -* __Recursively defined functions__ - - At first hand, it seems rather bad that a compiler for a functional language - cannot synthesize recursively defined functions to circuits. However, when - viewing your functions as a /structural/ specification of a circuit, this - /feature/ of the CλaSH compiler makes sense. Also, only certain types of - recursion are considered non-synthesisable; recursively defined values are - for example synthesisable: they are (often) synthesized to feedback loops. - - Let us distinguish between three variants of recursion: - - * __Dynamic data-dependent recursion__ - - As demonstrated in this definition of a function that calculates the - n'th Fibbonacci number: - - @ - fibR 0 = 0 - fibR 1 = 1 - fibR n = fibR (n-1) + fibR (n-2) - @ - - To get the first 10 numbers, we do the following: - - >>> import qualified Data.List as L - >>> L.map fibR [0..9] - [0,1,1,2,3,5,8,13,21,34] - - The @fibR@ function is not synthesizable by the CλaSH compiler, because, - when we take a /structural/ view, @fibR@ describes an infinitely deep - structure. - - In principal, descriptions like the above could be synthesized to a - circuit, but it would have to be a /sequential/ circuit. Where the most - general synthesis would then require a stack. Such a synthesis approach - is also known as /behavioural/ synthesis, something which the CλaSH - compiler simply does not do. One reason that CλaSH does not do this is - because it does not fit the paradigm that only functions working on - values of type 'Signal' result in sequential circuits, and all other - (non higher-order) functions result in combinational circuits. This - paradigm gives the designer the most straightforward mapping from the - original Haskell description to generated circuit, and thus the greatest - control over the eventual size of the circuit and longest propagation - delay. - - * __Value-recursion__ - - As demonstrated in this definition of a function that calculates the - n'th Fibbonaci number on the n'th clock cycle: - - @ - fibS = r - where r = 'register' 0 r + 'register' 0 ('register' 1 r) - @ - - To get the first 10 numbers, we do the following: - - >>> sampleN 10 fibS - [0,1,1,2,3,5,8,13,21,34] - - Unlike the @fibR@ function, the above @fibS@ function /is/ synthesisable - by the CλaSH compiler. Where the recursively defined (non-function) - value /r/ is synthesized to a feedback loop containing three registers - and one adder. - - Note that not all recursively defined values result in a feedback loop. - An example that uses recursively defined values which does not result - in a feedback loop is the following function that performs one iteration - of bubble sort: - - @ - sortV xs = 'map' fst sorted :< (snd ('last' sorted)) - where - lefts = 'head' xs :> 'map' snd ('init' sorted) - rights = 'tail' xs - sorted = 'zipWith' compareSwapL lefts rights - @ - - Where we can clearly see that 'lefts' and 'sorted' are defined in terms - of each other. Also the above @sortV@ function /is/ synthesisable. - - * __Static/Structure-dependent recursion__ - - Static, or, structure-dependent recursion is a rather /vague/ concept. - What we mean by this concept are recursive definitions where a user can - sensibly imagine that the recursive definition can be completely - unfolded (all recursion is eliminated) at compile-time in a finite - amount of time. - - Such definitions would e.g. be: - - @ - mapV :: (a -> b) -> Vec n a -> Vec n b - mapV _ Nil = Nil - mapV f (Cons x xs) = Cons (f x) (mapV f xs) - - topEntity :: Vec 4 Int -> Vec 4 Int - topEntity = mapV (+1) - @ - - Where one can imagine that a compiler can unroll the definition of - @mapV@ four times, knowing that the @topEntity@ function applies @mapV@ - to a 'Vec' of length 4. Sadly, the compile-time evaluation mechanisms in - the CλaSH compiler are very poor, and a user-defined function such as - the @mapV@ function defined above, is /currently/ not synthesisable. - We /do/ plan to add support for this in the future. In the mean time, - this poor support for user-defined recursive functions is amortized by - the fact that the CλaSH compiler has built-in support for the - higher-order functions defined in "CLaSH.Sized.Vector". Most regular - design patterns often encountered in circuit design are captured by the - higher-order functions in "CLaSH.Sized.Vector". - -* __Recursive datatypes__ - - The CλaSH compiler needs to be able to determine a bit-size for any value - that will be represented in the eventual circuit. More specifically, we need - to know the maximum number of bits needed to represent a value. While this - is trivial for values of the elementary types, sum types, and product types, - putting a fixed upper bound on recursive types is not (always) feasible. - This means that the ubiquitous list type is unsupported! The only recursive - type that is currently supported by the CλaSH compiler is the 'Vec'tor type, - for which the compiler has hard-coded knowledge. - - For \"easy\" 'Vec'tor literals you should use Template Haskell splices and - the 'listToVecTH' /meta/-function that as we have seen earlier in this tutorial. - -* __GADT pattern matching__ - - While pattern matching for regular ADTs is supported, pattern matching for - GADTs is __not__. The constructors 'Cons' and 'Nil' of the 'Vec'tor type, - which is also a GADT, are __no__ exception! However, you can use the - convenient ':>' pattern synonym. - -* __Floating point types__ - - There is no support for the 'Float' and 'Double' types, if you need numbers - with a /fractional/ part you can use the 'Fixed' point type. - - As to why there is no support for these floating point types: - - 1. In order to achieve reasonable operating frequencies, arithmetic - circuits for floating point data types must be pipelined. - 2. Haskell's primitive arithmetic operators on floating point data types, - such as 'plusFloat#' - - @ - __plusFloat#__ :: 'Float#' -> 'Float#' -> 'Float#' - @ - - which underlie @'Float'@'s 'Num' instance, must be implemented as - purely combinational circuits according to their type. Remember, - sequential circuits operate on values of type \"@'Signal' a@\". - - Although it is possible to implement purely combinational (not pipelined) - arithmetic circuits for floating point data types, the circuit would be - unreasonable slow. And so, without synthesis possibilities for the basic - arithmetic operations, there is no point in supporting the floating point - data types. - -* __Haskell primitive types__ - - Only the following primitive Haskell types are supported: - - * 'Integer' - * 'Int' - * 'Int8' - * 'Int16' - * 'Int32' - * 'Int64' (not available when compiling with @-clash-intwidth=32@ on a 64-bit machine) - * 'Word' - * 'Word8' - * 'Word16' - * 'Word32' - * 'Word64' (not available when compiling with @-clash-intwidth=32@ on a 64-bit machine) - * 'Char' - - There are several aspects of which you should take note: - - * 'Int' and 'Word' are represented by the same number of bits as is - native for the architecture of the computer on which the CλaSH - compiler is executed. This means that if you are working on a 64-bit - machine, 'Int' and 'Word' will be 64-bit. This might be problematic - when you are working in a team, and one designer has a 32-bit - machine, and the other has a 64-bit machine. In general, you should - be avoiding 'Int' in such cases, but as a band-aid solution, you can - force the CλaSH compiler to use a specific bit-width for `Int` and - `Word` using the @-clash-intwidth=N@ flag, where /N/ must either be - /32/ or /64/. - - * When you use the @-clash-intwidth=32@ flag on a /64-bit/ machine, - the 'Word64' and 'Int64' types /cannot/ be translated. This - restriction does /not/ apply to the other three combinations of - @-clash-intwidth@ flag and machine type. - - * The translation of 'Integer' is not meaning-preserving. 'Integer' in - Haskell is an arbitrary precision integer, something that cannot - be represented in a statically known number of bits. In the CλaSH - compiler, we chose to represent 'Integer' by the same number of bits - as we do for 'Int' and 'Word'. As you have read in a previous - bullet point, this number of bits is either 32 or 64, depending on - the architecture of the machine the CλaSH compiler is running on, or - the setting of the @-clash-intwidth@ flag. - - Consequently, you should use `Integer` with due diligence; be - especially careful when using `fromIntegral` as it does a conversion - via 'Integer'. For example: - - > signedToUnsigned :: Signed 128 -> Unsigned 128 - > signedToUnsigned = fromIntegral - - can either lose the top 64 or 96 bits depending on whether 'Integer' - is represented by 64 or 32 bits. Instead, when doing such conversions, - you should use 'bitCoerce': - - > signedToUnsigned :: Signed 128 -> Unsigned 128 - > signedToUnsigned = bitCoerce - -* __Side-effects: 'IO', 'ST', etc.__ - - There is no support for side-effecting computations such as those in the - 'IO' or 'ST' monad. There is also no support for Haskell's - . --} - -{- $vslava -In Haskell land the most well-known way of describing digital circuits is the -Lava family of languages: - -* -* -* -* - -The big difference between CλaSH and Lava is that CλaSH uses a \"standard\" -compiler (static analysis) approach towards synthesis, where Lava is an -embedded domain specific language. One downside of static analysis vs. the -embedded language approach is already clearly visible: synthesis of recursive -descriptions does not come for \"free\". This will be implemented in CλaSH in -due time, but that doesn't help the circuit designer right now. As already -mentioned earlier, the poor support for recursive functions is amortized by -the built-in support for the higher-order in "CLaSH.Sized.Vector". - -The big upside of CλaSH and its static analysis approach is that CλaSH can -do synthesis of \"normal\" functions: there is no forced encasing datatype (often -called /Signal/ in Lava) on all the arguments and results of a synthesizable -function. This enables the following features not available to Lava: - -* Automatic synthesis for user-defined ADTs -* Synthesis of all choice constructs (pattern matching, guards, etc.) -* 'Applicative' instance for the 'Signal' type -* Working with \"normal\" functions permits the use of e.g. the - 'Control.Monad.State.Lazy.State' monad to describe the functionality of a - circuit. - -Although there are Lava alternatives to some of the above features (e.g. -first-class patterns to replace pattern matching) they are not as \"beautiful\" -and / or easy to use as the standard Haskell features. --} diff --git a/src/CLaSH/XException.hs b/src/CLaSH/XException.hs deleted file mode 100644 --- a/src/CLaSH/XException.hs +++ /dev/null @@ -1,337 +0,0 @@ -{-| -Copyright : (C) 2016, University of Twente, 2017, QBayLogic -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij - -'X': An exception for uninitialized values - ->>> show (errorX "undefined" :: Integer, 4 :: Int) -"(*** Exception: X: undefined -CallStack (from HasCallStack): -... ->>> showX (errorX "undefined" :: Integer, 4 :: Int) -"(X,4)" --} - -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeOperators #-} - -{-# LANGUAGE Trustworthy #-} - -{-# OPTIONS_GHC -Wno-orphans #-} - -module CLaSH.XException - ( -- * 'X': An exception for uninitialized values - XException, errorX - -- * Printing 'X' exceptions as \"X\" - , ShowX (..), showsX, printX, showsPrecXWith - -- * Strict evaluation - , seqX - ) -where - -import Control.Exception (Exception, catch, evaluate, throw) -import Data.Complex (Complex) -import Data.Int (Int8,Int16,Int32,Int64) -import Data.Ratio (Ratio) -import Data.Word (Word8,Word16,Word32,Word64) -import GHC.Exts (Char (C#), Double (D#), Float (F#), Int (I#), Word (W#)) -import GHC.Generics -import GHC.Show (appPrec) -import GHC.Stack (HasCallStack, callStack, prettyCallStack) -import System.IO.Unsafe (unsafeDupablePerformIO) - --- | An exception representing an \"uninitialised\" value. -newtype XException = XException String - -instance Show XException where - show (XException s) = s - -instance Exception XException - --- | Like 'error', but throwing an 'XException' instead of an 'ErrorCall' --- --- The 'ShowX' methods print these error-values as \"X\"; instead of error'ing --- out with an exception. -errorX :: HasCallStack => String -> a -errorX msg = throw (XException ("X: " ++ msg ++ "\n" ++ prettyCallStack callStack)) - --- | Like 'seq', however, whereas 'seq' will always do: --- --- > seq _|_ b = _|_ --- --- 'seqX' will do: --- --- > seqX (XException msg) b = b --- > seqX _|_ b = _|_ -seqX :: a -> b -> b -seqX a b = unsafeDupablePerformIO - (catch (evaluate a >> return b) (\(XException _) -> return b)) -{-# NOINLINE seqX #-} -infixr 0 `seqX` - -showXWith :: (a -> ShowS) -> a -> ShowS -showXWith f x = - \s -> unsafeDupablePerformIO (catch (f <$> evaluate x <*> pure s) - (\(XException _) -> return ('X': s))) - --- | Use when you want to create a 'ShowX' instance where: --- --- - There is no 'Generic' instance for your data type --- - The 'Generic' derived ShowX method would traverse into the (hidden) --- implementation details of your data type, and you just want to show the --- entire value as \"X\". --- --- Can be used like: --- --- > data T = ... --- > --- > instance Show T where ... --- > --- > instance ShowX T where --- > showsPrecX = showsPrecXWith showsPrec -showsPrecXWith :: (Int -> a -> ShowS) -> Int -> a -> ShowS -showsPrecXWith f n = showXWith (f n) - --- | Like 'shows', but values that normally throw an 'X' exception are --- converted to \"X\", instead of error'ing out with an exception. -showsX :: ShowX a => a -> ShowS -showsX = showsPrecX 0 - --- | Like 'print', but values that normally throw an 'X' exception are --- converted to \"X\", instead of error'ing out with an exception -printX :: ShowX a => a -> IO () -printX x = putStrLn $ showX x - --- | Like the 'Show' class, but values that normally throw an 'X' exception are --- converted to \"X\", instead of error'ing out with an exception. --- --- >>> show (errorX "undefined" :: Integer, 4 :: Int) --- "(*** Exception: X: undefined --- CallStack (from HasCallStack): --- ... --- >>> showX (errorX "undefined" :: Integer, 4 :: Int) --- "(X,4)" --- --- Can be derived using 'GHC.Generics': --- --- > {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} --- > --- > import CLaSH.Prelude --- > import GHC.Generics --- > --- > data T = MkTA Int | MkTB Bool --- > deriving (Show,Generic,ShowX) -class ShowX a where - -- | Like 'showsPrec', but values that normally throw an 'X' exception are - -- converted to \"X\", instead of error'ing out with an exception. - showsPrecX :: Int -> a -> ShowS - - -- | Like 'show', but values that normally throw an 'X' exception are - -- converted to \"X\", instead of error'ing out with an exception. - showX :: a -> String - showX x = showsX x "" - - -- | Like 'showList', but values that normally throw an 'X' exception are - -- converted to \"X\", instead of error'ing out with an exception. - showListX :: [a] -> ShowS - showListX ls s = showListX__ showsX ls s - - default showsPrecX :: (Generic a, GShowX (Rep a)) => Int -> a -> ShowS - showsPrecX = genericShowsPrecX - -showListX__ :: (a -> ShowS) -> [a] -> ShowS -showListX__ showx = showXWith go - where - go [] s = "[]" ++ s - go (x:xs) s = '[' : showx x (showl xs) - where - showl [] = ']':s - showl (y:ys) = ',' : showx y (showl ys) - -data ShowType = Rec -- Record - | Tup -- Tuple - | Pref -- Prefix - | Inf String -- Infix - -genericShowsPrecX :: (Generic a, GShowX (Rep a)) => Int -> a -> ShowS -genericShowsPrecX n = gshowsPrecX Pref n . from - -instance ShowX () -instance (ShowX a, ShowX b) => ShowX (a,b) -instance (ShowX a, ShowX b, ShowX c) => ShowX (a,b,c) -instance (ShowX a, ShowX b, ShowX c, ShowX d) => ShowX (a,b,c,d) -instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e) => ShowX (a,b,c,d,e) -instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f) => ShowX (a,b,c,d,e,f) -instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g) => ShowX (a,b,c,d,e,f,g) - --- Show is defined up to 15-tuples, but GHC.Generics only has Generic instances --- up to 7-tuples, hence we need these orphan instances. -deriving instance Generic ((,,,,,,,) a b c d e f g h) -deriving instance Generic ((,,,,,,,,) a b c d e f g h i) -deriving instance Generic ((,,,,,,,,,) a b c d e f g h i j) -deriving instance Generic ((,,,,,,,,,,) a b c d e f g h i j k) -deriving instance Generic ((,,,,,,,,,,,) a b c d e f g h i j k l) -deriving instance Generic ((,,,,,,,,,,,,) a b c d e f g h i j k l m) -deriving instance Generic ((,,,,,,,,,,,,,) a b c d e f g h i j k l m n) -deriving instance Generic ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o) - -instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h) => ShowX (a,b,c,d,e,f,g,h) -instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i) => ShowX (a,b,c,d,e,f,g,h,i) -instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j) - => ShowX (a,b,c,d,e,f,g,h,i,j) -instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j, ShowX k) - => ShowX (a,b,c,d,e,f,g,h,i,j,k) -instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j, ShowX k, ShowX l) - => ShowX (a,b,c,d,e,f,g,h,i,j,k,l) -instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j, ShowX k, ShowX l - ,ShowX m) - => ShowX (a,b,c,d,e,f,g,h,i,j,k,l,m) -instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j, ShowX k, ShowX l - ,ShowX m, ShowX n) - => ShowX (a,b,c,d,e,f,g,h,i,j,k,l,m,n) -instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j, ShowX k, ShowX l - ,ShowX m, ShowX n, ShowX o) - => ShowX (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) - -instance {-# OVERLAPPABLE #-} ShowX a => ShowX [a] where - showsPrecX _ = showListX - -instance ShowX Bool - -instance ShowX Double where - showsPrecX = showsPrecXWith showsPrec - -instance (ShowX a, ShowX b) => ShowX (Either a b) - -instance ShowX Float where - showsPrecX = showsPrecXWith showsPrec - -instance ShowX Int where - showsPrecX = showsPrecXWith showsPrec - -instance ShowX Int8 where - showsPrecX = showsPrecXWith showsPrec - -instance ShowX Int16 where - showsPrecX = showsPrecXWith showsPrec - -instance ShowX Int32 where - showsPrecX = showsPrecXWith showsPrec - -instance ShowX Int64 where - showsPrecX = showsPrecXWith showsPrec - -instance ShowX Integer where - showsPrecX = showsPrecXWith showsPrec - -instance ShowX Word where - showsPrecX = showsPrecXWith showsPrec - -instance ShowX Word8 where - showsPrecX = showsPrecXWith showsPrec - -instance ShowX Word16 where - showsPrecX = showsPrecXWith showsPrec - -instance ShowX Word32 where - showsPrecX = showsPrecXWith showsPrec - -instance ShowX Word64 where - showsPrecX = showsPrecXWith showsPrec - -instance ShowX a => ShowX (Maybe a) - -instance ShowX a => ShowX (Ratio a) where - showsPrecX = showsPrecXWith showsPrecX - -instance ShowX a => ShowX (Complex a) - -instance {-# OVERLAPPING #-} ShowX String where - showsPrecX = showsPrecXWith showsPrec - -class GShowX f where - gshowsPrecX :: ShowType -> Int -> f a -> ShowS - isNullary :: f a -> Bool - isNullary = error "generic showX (isNullary): unnecessary case" - -instance GShowX U1 where - gshowsPrecX _ _ U1 = id - isNullary _ = True - -instance (ShowX c) => GShowX (K1 i c) where - gshowsPrecX _ n (K1 a) = showsPrecX n a - isNullary _ = False - -instance (GShowX a, Constructor c) => GShowX (M1 C c a) where - gshowsPrecX _ n c@(M1 x) = - case fixity of - Prefix -> - showParen (n > appPrec && not (isNullary x)) - ( (if conIsTuple c then id else showString (conName c)) - . (if isNullary x || conIsTuple c then id else showString " ") - . showBraces t (gshowsPrecX t appPrec x)) - Infix _ m -> showParen (n > m) (showBraces t (gshowsPrecX t m x)) - where fixity = conFixity c - t = if conIsRecord c then Rec else - case conIsTuple c of - True -> Tup - False -> case fixity of - Prefix -> Pref - Infix _ _ -> Inf (show (conName c)) - showBraces :: ShowType -> ShowS -> ShowS - showBraces Rec p = showChar '{' . p . showChar '}' - showBraces Tup p = showChar '(' . p . showChar ')' - showBraces Pref p = p - showBraces (Inf _) p = p - - conIsTuple :: C1 c f p -> Bool - conIsTuple y = tupleName (conName y) where - tupleName ('(':',':_) = True - tupleName _ = False - -instance (Selector s, GShowX a) => GShowX (M1 S s a) where - gshowsPrecX t n s@(M1 x) | selName s == "" = gshowsPrecX t n x - | otherwise = showString (selName s) - . showString " = " - . gshowsPrecX t 0 x - isNullary (M1 x) = isNullary x - -instance (GShowX a) => GShowX (M1 D d a) where - gshowsPrecX t = showsPrecXWith go - where go n (M1 x) = gshowsPrecX t n x - -instance (GShowX a, GShowX b) => GShowX (a :+: b) where - gshowsPrecX t n (L1 x) = gshowsPrecX t n x - gshowsPrecX t n (R1 x) = gshowsPrecX t n x - -instance (GShowX a, GShowX b) => GShowX (a :*: b) where - gshowsPrecX t@Rec n (a :*: b) = - gshowsPrecX t n a . showString ", " . gshowsPrecX t n b - gshowsPrecX t@(Inf s) n (a :*: b) = - gshowsPrecX t n a . showString s . gshowsPrecX t n b - gshowsPrecX t@Tup n (a :*: b) = - gshowsPrecX t n a . showChar ',' . gshowsPrecX t n b - gshowsPrecX t@Pref n (a :*: b) = - gshowsPrecX t (n+1) a . showChar ' ' . gshowsPrecX t (n+1) b - - -- If we have a product then it is not a nullary constructor - isNullary _ = False - --- Unboxed types -instance GShowX UChar where - gshowsPrecX _ _ (UChar c) = showsPrec 0 (C# c) . showChar '#' -instance GShowX UDouble where - gshowsPrecX _ _ (UDouble d) = showsPrec 0 (D# d) . showString "##" -instance GShowX UFloat where - gshowsPrecX _ _ (UFloat f) = showsPrec 0 (F# f) . showChar '#' -instance GShowX UInt where - gshowsPrecX _ _ (UInt i) = showsPrec 0 (I# i) . showChar '#' -instance GShowX UWord where - gshowsPrecX _ _ (UWord w) = showsPrec 0 (W# w) . showString "##" diff --git a/src/Clash/Annotations/Primitive.hs b/src/Clash/Annotations/Primitive.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Annotations/Primitive.hs @@ -0,0 +1,75 @@ +{-| +Copyright : (C) 2017, Myrtle Software, QBayLogic +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij + +Instruct the clash compiler to look for primitive HDL templates in the +indicated directory. For distribution of new packages with primitive HDL +templates. +-} + +{-# LANGUAGE DeriveDataTypeable #-} + +{-# LANGUAGE Safe #-} + +{-# OPTIONS_HADDOCK show-extensions #-} + +module Clash.Annotations.Primitive where + +import Data.Data + +data HDL + = SystemVerilog + | Verilog + | VHDL + deriving (Eq, Show, Read, Data) + +-- | Instruct the clash compiler to look for primitive HDL templates in the +-- indicated directory. For distribution of new packages with primitive HDL +-- templates. +-- +-- === Example +-- +-- You have some existing IP written in one of HDLs supported by Clash, and +-- you want to distribute some bindings so that the IP can be easily instantiated +-- from Clash. +-- +-- You create a package which has a @myfancyip.cabal@ file with the following stanza: +-- +-- @ +-- data-files: path\/to\/MyFancyIP.json +-- cpp-options: -DCABAL +-- @ +-- +-- and a @MyFancyIP.hs@ module with the simulation definition and primitive. +-- +-- @ +-- module MyFancyIP where +-- +-- import Clash.Prelude +-- +-- myFancyIP :: ... +-- myFancyIP = ... +-- {\-\# NOINLINE myFancyIP \#-\} +-- @ +-- +-- The @NOINLINE@ pragma is needed so that GHC will never inline the definition. +-- +-- Now you need to add the following imports and @ANN@ pragma: +-- +-- @ +-- \#ifdef CABAL +-- import Clash.Annotations.Primitive +-- import System.FilePath +-- import qualified Paths_myfancyip +-- import System.IO.Unsafe +-- +-- {\-\# ANN module (Primitive VHDL (unsafePerformIO Paths_myfancyip.getDataDir \<\/\> "path" \<\/\> "to")) \#-\} +-- \#endif +-- @ +-- +-- Add more files to the @data-files@ stanza in your @.cabal@ files and more +-- @ANN@ pragma's if you want to add more primitive templates for other HDLs +data Primitive + = Primitive HDL FilePath + deriving (Show, Read, Data) diff --git a/src/Clash/Annotations/TopEntity.hs b/src/Clash/Annotations/TopEntity.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Annotations/TopEntity.hs @@ -0,0 +1,356 @@ +{-| +Copyright : (C) 2015-2016, University of Twente, + 2017 , Google Inc. +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij + +'TopEntity' annotations allow us to control hierarchy and naming aspects of the +CλaSH compiler. We have the 'Synthesize' and 'TestBench' annotation. + +=== 'Synthesize' annotation + +The 'Synthesize' annotation allows us to: + + * Assign names to entities (VHDL) \/ modules ((System)Verilog), and their + ports. + * Put generated HDL files of a logical (sub)entity in their own directory. + * Use cached versions of generated HDL, i.e., prevent recompilation of + (sub)entities that have not changed since the last run. Caching is based + on a @.manifest@ which is generated alongside the HDL; deleting this file + means deleting the cache; changing this file will result in /undefined/ + behaviour. + +Functions with a 'Synthesize' annotation do must adhere to the following +restrictions: + + * Although functions with a 'Synthesize' annotation can of course depend + on functions with another 'Synthesize' annotation, they must not be + mutually recursive. + * Functions with a 'Synthesize' annotation must be completely /monomorphic/ + and /first-order/, and cannot have any /non-representable/ arguments or + result. + +Also take the following into account when using 'Synthesize' annotations. + + * The CλaSH compiler is based on the GHC Haskell compiler, and the GHC + machinery does not understand 'Synthesize' annotations and it might + subsequently decide to inline those functions. You should therefor also + add a @{\-\# NOINLINE f \#-\}@ pragma to the functions which you give + a 'Synthesize' functions. + * Functions with a 'Synthesize' annotation will not be specialised + on constants. + +Finally, the root module, the module which you pass as an argument to the +CλaSH compiler must either have: + + * A function with a 'Synthesize' annotation. + * A function called /topEntity/. + +You apply 'Synthesize' annotations to functions using an @ANN@ pragma: + +@ +{\-\# ANN f (Synthesize {t_name = ..., ... }) \#-\} +f x = ... +@ + +For example, given the following specification: + +@ +module Blinker where + +import Clash.Prelude +import Clash.Intel.ClockGen + +type Dom50 = Dom \"System\" 20000 + +topEntity + :: Clock Dom50 Source + -> Reset Dom50 Asynchronous + -> Signal Dom50 Bit + -> Signal Dom50 (BitVector 8) +topEntity clk rst key1 = + let (pllOut,pllStable) = 'Clash.Intel.ClockGen.altpll' (SSymbol @ "altpll50") clk rst + rstSync = 'Clash.Signal.resetSynchronizer' pllOut ('Clash.Signal.unsafeToAsyncReset' pllStable) + in 'Clash.Signal.exposeClockReset' leds pllOut rstSync + where + key1R = 'Clash.Prelude.isRising' 1 key1 + leds = 'Clash.Prelude.mealy' blinkerT (1,False,0) key1R + +blinkerT (leds,mode,cntr) key1R = ((leds',mode',cntr'),leds) + where + -- clock frequency = 50e6 (50 MHz) + -- led update rate = 333e-3 (every 333ms) + cnt_max = 16650000 -- 50e6 * 333e-3 + + cntr' | cntr == cnt_max = 0 + | otherwise = cntr + 1 + + mode' | key1R = not mode + | otherwise = mode + + leds' | cntr == 0 = if mode then complement leds + else rotateL leds 1 + | otherwise = leds +@ + +The CλaSH compiler would normally generate the following +@blinker_topentity.vhdl@ file: + +@ +-- Automatically generated VHDL-93 +library IEEE; +use IEEE.STD_LOGIC_1164.ALL; +use IEEE.NUMERIC_STD.ALL; +use IEEE.MATH_REAL.ALL; +use std.textio.all; +use work.all; +use work.blinker_types.all; + +entity blinker_topentity is + port(-- clock + input_0 : in std_logic; + -- asynchronous reset: active high + input_1 : in std_logic; + input_2 : in std_logic_vector(0 downto 0); + output_0 : out std_logic_vector(7 downto 0)); +end; + +architecture structural of blinker_topentity is +begin + blinker_topentity_0_inst : entity blinker_topentity_0 + port map + (clk => input_0 + ,rst => input_1 + ,key1 => input_2 + ,result => output_0); +end; +@ + +However, if we add the following 'Synthesize' annotation in the file: + +@ +{\-\# ANN topEntity + ('Synthesize' + { t_name = "blinker" + , t_inputs = [ PortName \"CLOCK_50\" + , PortName \"KEY0\" + , PortName \"KEY1\" ] + , t_output = PortName \"LED\" + }) \#-\} +@ + +The CλaSH compiler will generate the following @blinker.vhdl@ file instead: + +@ +-- Automatically generated VHDL-93 +library IEEE; +use IEEE.STD_LOGIC_1164.ALL; +use IEEE.NUMERIC_STD.ALL; +use IEEE.MATH_REAL.ALL; +use std.textio.all; +use work.all; +use work.blinker_types.all; + +entity blinker is + port(-- clock + CLOCK_50 : in std_logic; + -- asynchronous reset: active high + KEY0 : in std_logic; + KEY1 : in std_logic_vector(0 downto 0); + LED : out std_logic_vector(7 downto 0)); +end; + +architecture structural of blinker is +begin + blinker_topentity_inst : entity blinker_topentity + port map + (clk => CLOCK_50 + ,rst => KEY0 + ,key1 => KEY1 + ,result => LED); +end; +@ + +Where we now have: + +* A top-level component that is called @blinker@. +* Inputs and outputs that have a /user/-chosen name: @CLOCK_50@, @KEY0@, @KEY1@, @LED@, etc. + +See the documentation of 'Synthesize' for the meaning of all its fields. + +=== 'TestBench' annotation + +Tell what binder is the 'TestBench' for a 'Synthesize'-annotated binder. + +So in the following example, /f/ has a 'Synthesize' annotation, and /g/ is +the HDL test bench for /f/. + +@ +f :: Bool -> Bool +f = ... +{\-\# ANN f (defSyn "f") \#-\} +{\-\# ANN f (TestBench \'g) \#-\} + +g :: Signal Bool +g = ... +@ + +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +{-# LANGUAGE Safe #-} + +{-# OPTIONS_HADDOCK show-extensions #-} + +module Clash.Annotations.TopEntity + ( -- * Data types + TopEntity (..) + , PortName (..) + -- * Convenience functions + , defSyn + ) +where + +import GHC.Generics +import qualified Language.Haskell.TH as TH +import Data.Data + +-- | TopEntity annotation +data TopEntity + -- | Instruct the Clash compiler to use this top-level function as a separately + -- synthesizable component. + = Synthesize + { t_name :: String + -- ^ The name the top-level component should have, put in a correspondingly + -- named file. + , t_inputs :: [PortName] + -- ^ List of names that are assigned in-order to the inputs of the component. + , t_output :: PortName + -- ^ Name assigned in-order to the outputs of the component. As a Haskell + -- function can only truly return a single value -- with multiple values + -- \"wrapped\" by a tuple -- this field is not a list, but a single + -- @'PortName'@. Use @'PortProduct'@ to give names to the individual components + -- of the output tuple. + } + -- | Tell what binder is the 'TestBench' for a 'Synthesize'-annotated binder. + -- + -- So in the following example, /f/ has a 'Synthesize' annotation, and /g/ is + -- the HDL test bench for /f/. + -- + -- @ + -- f :: Bool -> Bool + -- f = ... + -- {\-\# ANN f (defSyn "f") \#-\} + -- {\-\# ANN f (TestBench \'g) \#-\} + -- + -- g :: Signal Bool + -- g = ... + -- @ + | TestBench TH.Name + deriving (Data,Show,Generic) + +-- | Give port names for arguments/results. +-- +-- Give a data type and function: +-- +-- @ +-- data T = MkT Int Bool +-- +-- {\-\# ANN topEntity (defSyn "f") \#-\} +-- f :: Int -> T -> (T,Bool) +-- f a b = ... +-- @ +-- +-- Clash would normally generate the following VHDL entity: +-- +-- @ +-- entity f is +-- port(input_0 : in signed(63 downto 0); +-- input_1_0 : in signed(63 downto 0); +-- input_1_1 : in boolean; +-- output_0_0_0 : out signed(63 downto 0); +-- output_0_0_1 : out boolean; +-- output_0_1 : out boolean); +-- end; +-- @ +-- +-- However, we can change this by using 'PortName's. So by: +-- +-- @ +-- {\-\# ANN topEntity +-- (Synthesize +-- { t_name = "f" +-- , t_inputs = [ PortName \"a\" +-- , PortName \"b\" ] +-- , t_output = PortName \"res\" }) \#-\} +-- f :: Int -> T -> (T,Bool) +-- f a b = ... +-- @ +-- +-- we get: +-- +-- @ +-- entity f is +-- port(a : in signed(63 downto 0); +-- b : in f_types.t; +-- res : out f_types.tup2); +-- end; +-- @ +-- +-- If we want to name fields for tuples/records we have to use 'PortProduct' +-- +-- @ +-- {\-\# ANN topEntity +-- (Synthesize +-- { t_name = "f" +-- , t_inputs = [ PortName \"a\" +-- , PortProduct \"\" [ PortName \"b\", PortName \"c\" ] ] +-- , t_output = PortProduct \"res\" [PortName \"q\"] }) \#-\} +-- f :: Int -> T -> (T,Bool) +-- f a b = ... +-- @ +-- +-- So that we get: +-- +-- @ +-- entity f is +-- port(a : in signed(63 downto 0); +-- b : in signed(63 downto 0); +-- c : in boolean; +-- q : out f_types.t; +-- res_1 : out boolean); +-- end; +-- @ +-- +-- Notice how we didn't name the second field of the result, and the second +-- output port got 'PortProduct' name, \"res\", as a prefix for its name. +data PortName + = PortName String + -- ^ You want a port, with the given name, for the entire argument\/type + -- + -- You can use an empty String ,\"\" , in case you want an auto-generated name. + | PortProduct String [PortName] + -- ^ You want to assign ports to fields of a product argument\/type + -- + -- The first argument of 'PortProduct' is the name of: + -- + -- 1. The signal/wire to which the individual ports are aggregated. + -- + -- 2. The prefix for any unnamed ports below the 'PortProduct' + -- + -- You can use an empty String ,\"\" , in case you want an auto-generated name. + deriving (Data,Show,Generic) + +-- | Default 'Synthesize' annotation which has no specified names for the input +-- and output ports. +-- +-- >>> defSyn "foo" +-- Synthesize {t_name = "foo", t_inputs = [], t_output = PortName ""} +defSyn :: String -> TopEntity +defSyn name = Synthesize + { t_name = name + , t_inputs = [] + , t_output = PortName "" + } diff --git a/src/Clash/Class/BitPack.hs b/src/Clash/Class/BitPack.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Class/BitPack.hs @@ -0,0 +1,311 @@ +{-| +Copyright : (C) 2013-2016, University of Twente, + 2016-2017, Myrtle Software Ltd +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +{-# LANGUAGE Trustworthy #-} + +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} +{-# OPTIONS_HADDOCK show-extensions #-} + +#include "MachDeps.h" + +module Clash.Class.BitPack + ( BitPack (..) + , bitCoerce + , boolToBV + , boolToBit + , bitToBool + ) +where + +import Data.Binary.IEEE754 (doubleToWord, floatToWord, wordToDouble, + wordToFloat) +import Data.Int +import Data.Word +import Foreign.C.Types (CUShort) +import GHC.TypeLits (KnownNat, Nat, type (+)) +import Numeric.Half (Half (..)) +import GHC.Generics +import Prelude hiding (map) + +import Clash.Class.Resize (zeroExtend) +import Clash.Sized.BitVector + (Bit, BitVector, (++#), high, low) +import Clash.Sized.Internal.BitVector (pack#, split#, unpack#, unsafeToInteger) + +{- $setup +>>> :set -XDataKinds +>>> import Clash.Prelude +-} + +-- | Convert to and from a 'BitVector' +class BitPack a where + -- | Number of 'Clash.Sized.BitVector.Bit's needed to represents elements + -- of type @a@ + -- + -- Can be derived using `GHC.Generics`: + -- + -- > {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} + -- > + -- > import Clash.Prelude + -- > import GHC.Generics + -- > + -- > data MyProductType = MyProductType { a :: Int, b :: Bool } + -- > deriving (Generic, BitPack) + type BitSize a :: Nat + type BitSize a = GBitSize (Rep a) + -- | Convert element of type @a@ to a 'BitVector' + -- + -- >>> pack (-5 :: Signed 6) + -- 11_1011 + pack :: a -> BitVector (BitSize a) + default pack + :: (Generic a, GBitPack (Rep a), GBitSize (Rep a) ~ BitSize a) + => a -> BitVector (BitSize a) + pack = gpack . from + -- | Convert a 'BitVector' to an element of type @a@ + -- + -- >>> pack (-5 :: Signed 6) + -- 11_1011 + -- >>> let x = pack (-5 :: Signed 6) + -- >>> unpack x :: Unsigned 6 + -- 59 + -- >>> pack (59 :: Unsigned 6) + -- 11_1011 + unpack :: BitVector (BitSize a) -> a + default unpack + :: (Generic a, GBitPack (Rep a), GBitSize (Rep a) ~ BitSize a) + => BitVector (BitSize a) -> a + unpack = to . gunpack + +{-# INLINE bitCoerce #-} +-- | Coerce a value from one type to another through its bit representation. +-- +-- >>> pack (-5 :: Signed 6) +-- 11_1011 +-- >>> bitCoerce (-5 :: Signed 6) :: Unsigned 6 +-- 59 +-- >>> pack (59 :: Unsigned 6) +-- 11_1011 +bitCoerce :: (BitPack a, BitPack b, BitSize a ~ BitSize b) + => a + -> b +bitCoerce = unpack . pack + +instance BitPack Bool where + type BitSize Bool = 1 + pack True = 1 + pack False = 0 + + unpack bv = if bv == 1 then True else False + +instance BitPack (BitVector n) where + type BitSize (BitVector n) = n + pack v = v + unpack v = v + +instance BitPack Bit where + type BitSize Bit = 1 + pack = pack# + unpack = unpack# + +instance BitPack Int where + type BitSize Int = WORD_SIZE_IN_BITS + pack = fromIntegral + unpack = fromIntegral + +instance BitPack Int8 where + type BitSize Int8 = 8 + pack = fromIntegral + unpack = fromIntegral + +instance BitPack Int16 where + type BitSize Int16 = 16 + pack = fromIntegral + unpack = fromIntegral + +instance BitPack Int32 where + type BitSize Int32 = 32 + pack = fromIntegral + unpack = fromIntegral + +#if WORD_SIZE_IN_BITS >= 64 +instance BitPack Int64 where + type BitSize Int64 = 64 + pack = fromIntegral + unpack = fromIntegral +#endif + +instance BitPack Word where + type BitSize Word = WORD_SIZE_IN_BITS + pack = fromIntegral + unpack = fromIntegral + +instance BitPack Word8 where + type BitSize Word8 = 8 + pack = fromIntegral + unpack = fromIntegral + +instance BitPack Word16 where + type BitSize Word16 = 16 + pack = fromIntegral + unpack = fromIntegral + +instance BitPack Word32 where + type BitSize Word32 = 32 + pack = fromIntegral + unpack = fromIntegral + +#if WORD_SIZE_IN_BITS >= 64 +instance BitPack Word64 where + type BitSize Word64 = 64 + pack = fromIntegral + unpack = fromIntegral +#endif + +instance BitPack Float where + type BitSize Float = 32 + pack = packFloat# + unpack = unpackFloat# + +packFloat# :: Float -> BitVector 32 +packFloat# = fromIntegral . floatToWord +{-# NOINLINE packFloat# #-} + +unpackFloat# :: BitVector 32 -> Float +unpackFloat# = wordToFloat . fromInteger . unsafeToInteger +{-# NOINLINE unpackFloat# #-} + +instance BitPack Double where + type BitSize Double = 64 + pack = packDouble# + unpack = unpackDouble# + +packDouble# :: Double -> BitVector 64 +packDouble# = fromIntegral . doubleToWord +{-# NOINLINE packDouble# #-} + +unpackDouble# :: BitVector 64 -> Double +unpackDouble# = wordToDouble . fromInteger . unsafeToInteger +{-# NOINLINE unpackDouble# #-} + +instance BitPack CUShort where + type BitSize CUShort = 16 + pack = fromIntegral + unpack = fromIntegral + +instance BitPack Half where + type BitSize Half = 16 + pack (Half x) = pack x + unpack x = Half (unpack x) + +instance BitPack () where + type BitSize () = 0 + pack _ = minBound + unpack _ = () + +instance (KnownNat (BitSize b), BitPack a, BitPack b) => + BitPack (a,b) where + type BitSize (a,b) = BitSize a + BitSize b + pack (a,b) = pack a ++# pack b + unpack ab = let (a,b) = split# ab in (unpack a, unpack b) + +instance (KnownNat (BitSize c), BitPack (a,b), BitPack c) => + BitPack (a,b,c) where + type BitSize (a,b,c) = BitSize (a,b) + BitSize c + pack (a,b,c) = pack (a,b) ++# pack c + unpack (unpack -> ((a,b), c)) = (a,b,c) + +instance (KnownNat (BitSize d), BitPack (a,b,c), BitPack d) => + BitPack (a,b,c,d) where + type BitSize (a,b,c,d) = BitSize (a,b,c) + BitSize d + pack (a,b,c,d) = pack (a,b,c) ++# pack d + unpack (unpack -> ((a,b,c), d)) = (a,b,c,d) + +instance (KnownNat (BitSize e), BitPack (a,b,c,d), BitPack e) => + BitPack (a,b,c,d,e) where + type BitSize (a,b,c,d,e) = BitSize (a,b,c,d) + BitSize e + pack (a,b,c,d,e) = pack (a,b,c,d) ++# pack e + unpack (unpack -> ((a,b,c,d), e)) = (a,b,c,d,e) + +instance (KnownNat (BitSize f), BitPack (a,b,c,d,e), BitPack f) => + BitPack (a,b,c,d,e,f) where + type BitSize (a,b,c,d,e,f) = BitSize (a,b,c,d,e) + BitSize f + pack (a,b,c,d,e,f) = pack (a,b,c,d,e) ++# pack f + unpack (unpack -> ((a,b,c,d,e), f)) = (a,b,c,d,e,f) + +instance (KnownNat (BitSize g), BitPack (a,b,c,d,e,f), BitPack g) => + BitPack (a,b,c,d,e,f,g) where + type BitSize (a,b,c,d,e,f,g) = BitSize (a,b,c,d,e,f) + BitSize g + pack (a,b,c,d,e,f,g) = pack (a,b,c,d,e,f) ++# pack g + unpack (unpack -> ((a,b,c,d,e,f), g)) = (a,b,c,d,e,f,g) + +instance (KnownNat (BitSize h), BitPack (a,b,c,d,e,f,g), BitPack h) => + BitPack (a,b,c,d,e,f,g,h) where + type BitSize (a,b,c,d,e,f,g,h) = BitSize (a,b,c,d,e,f,g) + BitSize h + pack (a,b,c,d,e,f,g,h) = pack (a,b,c,d,e,f,g) ++# pack h + unpack (unpack -> ((a,b,c,d,e,f,g), h)) = (a,b,c,d,e,f,g,h) + +instance (BitPack a, KnownNat (BitSize a)) => BitPack (Maybe a) where + type BitSize (Maybe a) = 1 + BitSize a + pack Nothing = pack# low ++# 0 + -- We cannot do `low ++# undefined`, because `BitVector`s underlying + -- representation is `Integer`, so `low ++# undefined` would make the + -- entire `BitVector` undefined. + pack (Just x) = pack# high ++# pack x + unpack x = case split# x of + (c,rest) | unpack# c == low -> Nothing + | otherwise -> Just (unpack rest) + +class GBitPack f where + type GBitSize f :: Nat + gpack :: f a -> BitVector (GBitSize f) + gunpack :: BitVector (GBitSize f) -> f a + +instance (GBitPack a) => GBitPack (M1 m d a) where + type GBitSize (M1 m d a) = GBitSize a + gpack (M1 m1) = gpack m1 + gunpack b = M1 (gunpack b) + +instance (KnownNat (GBitSize g), GBitPack f, GBitPack g) => GBitPack (f :*: g) where + type GBitSize (f :*: g) = GBitSize f + GBitSize g + gpack (m :*: ms) = gpack m ++# gpack ms + gunpack b = gunpack front :*: gunpack back + where + (front, back) = split# b + +instance (BitPack c) => GBitPack (K1 i c) where + type GBitSize (K1 i c) = BitSize c + gpack (K1 i) = pack i + gunpack b = K1 (unpack b) + +-- | Zero-extend a 'Bool'ean value to a 'BitVector' of the appropriate size. +-- +-- >>> boolToBV True :: BitVector 6 +-- 00_0001 +-- >>> boolToBV False :: BitVector 6 +-- 00_0000 +boolToBV :: KnownNat n => Bool -> BitVector (n + 1) +boolToBV = zeroExtend . pack + +-- | Convert a Bool to a Bit +boolToBit :: Bool -> Bit +boolToBit = bitCoerce + +-- | Convert a Bool to a Bit +bitToBool :: Bit -> Bool +bitToBool = bitCoerce diff --git a/src/Clash/Class/Num.hs b/src/Clash/Class/Num.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Class/Num.hs @@ -0,0 +1,83 @@ +{-| +Copyright : (C) 2013-2016, University of Twente +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +{-# LANGUAGE Safe #-} + +{-# OPTIONS_HADDOCK show-extensions #-} + +module Clash.Class.Num + ( -- * Arithmetic functions for arguments and results of different precision + ExtendingNum (..) + -- * Saturating arithmetic functions + , SaturationMode (..) + , SaturatingNum (..) + , boundedPlus + , boundedMin + , boundedMult + ) +where + +-- * Arithmetic functions for arguments and results of different precision + +-- | Adding, subtracting, and multiplying values of two different (sub-)types. +class ExtendingNum a b where + -- | Type of the result of the addition or subtraction + type AResult a b + -- | Add values of different (sub-)types, return a value of a (sub-)type + -- that is potentially different from either argument. + plus :: a -> b -> AResult a b + -- | Subtract values of different (sub-)types, return a value of a (sub-)type + -- that is potentially different from either argument. + minus :: a -> b -> AResult a b + -- | Type of the result of the multiplication + type MResult a b + -- | Multiply values of different (sub-)types, return a value of a (sub-)type + -- that is potentially different from either argument. + times :: a -> b -> MResult a b + +-- * Saturating arithmetic functions + +-- | Determine how overflow and underflow are handled by the functions in +-- 'SaturatingNum' +data SaturationMode + = SatWrap -- ^ Wrap around on overflow and underflow + | SatBound -- ^ Become 'maxBound' on overflow, and 'minBound' on underflow + | SatZero -- ^ Become @0@ on overflow and underflow + | SatSymmetric -- ^ Become 'maxBound' on overflow, and (@'minBound' + 1@) on + -- underflow for signed numbers, and 'minBound' for unsigned + -- numbers. + deriving Eq + +-- | 'Num' operators in which overflow and underflow behaviour can be specified +-- using 'SaturationMode'. +class (Bounded a, Num a) => SaturatingNum a where + -- | Addition with parametrisable over- and underflow behaviour + satPlus :: SaturationMode -> a -> a -> a + -- | Subtraction with parametrisable over- and underflow behaviour + satMin :: SaturationMode -> a -> a -> a + -- | Multiplication with parametrisable over- and underflow behaviour + satMult :: SaturationMode -> a -> a -> a + +{-# INLINE boundedPlus #-} +-- | Addition that clips to 'maxBound' on overflow, and 'minBound' on underflow +boundedPlus :: SaturatingNum a => a -> a -> a +boundedPlus = satPlus SatBound + +{-# INLINE boundedMin #-} +-- | Subtraction that clips to 'maxBound' on overflow, and 'minBound' on +-- underflow +boundedMin :: SaturatingNum a => a -> a -> a +boundedMin = satMin SatBound + +{-# INLINE boundedMult #-} +-- | Multiplication that clips to 'maxBound' on overflow, and 'minBound' on +-- underflow +boundedMult :: SaturatingNum a => a -> a -> a +boundedMult = satMult SatBound diff --git a/src/Clash/Class/Resize.hs b/src/Clash/Class/Resize.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Class/Resize.hs @@ -0,0 +1,42 @@ +{-| +Copyright : (C) 2013-2016, University of Twente +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} + +{-# LANGUAGE Safe #-} + +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} +{-# OPTIONS_HADDOCK show-extensions #-} + +module Clash.Class.Resize where + +import GHC.TypeLits (Nat, KnownNat, type (+)) + +-- | Coerce a value to be represented by a different number of bits +class Resize (f :: Nat -> *) where + -- | A sign-preserving resize operation + -- + -- * For signed datatypes: Increasing the size of the number replicates the + -- sign bit to the left. Truncating a number to length L keeps the sign bit + -- and the rightmost L-1 bits. + -- + -- * For unsigned datatypes: Increasing the size of the number extends with + -- zeros to the left. Truncating a number of length N to a length L just + -- removes the left (most significant) N-L bits. + resize :: (KnownNat a, KnownNat b) => f a -> f b + -- | Perform a 'zeroExtend' for unsigned datatypes, and 'signExtend' for a + -- signed datatypes + extend :: (KnownNat a, KnownNat b) => f a -> f (b + a) + extend = resize + -- | Add extra zero bits in front of the MSB + zeroExtend :: (KnownNat a, KnownNat b) => f a -> f (b + a) + -- | Add extra sign bits in front of the MSB + signExtend :: (KnownNat a, KnownNat b) => f a -> f (b + a) + signExtend = resize + -- | Remove bits from the MSB + truncateB :: KnownNat a => f (a + b) -> f a diff --git a/src/Clash/Examples.hs b/src/Clash/Examples.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Examples.hs @@ -0,0 +1,656 @@ +{-| +Copyright : © 2015-2016, Christiaan Baaij, + 2017 , Google Inc. +Licence : Creative Commons 4.0 (CC BY 4.0) (http://creativecommons.org/licenses/by/4.0/) +-} + +{-# LANGUAGE NoImplicitPrelude, CPP, TemplateHaskell, DataKinds, BinaryLiterals, + FlexibleContexts, GADTs, TypeOperators, TypeApplications, + RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} + +module Clash.Examples ( + -- * Decoders and Encoders + -- $decoders_and_encoders + + -- * Counters + -- $counters + + -- * Parity and CRC + -- $parity_and_crc + + -- * UART model + -- $uart + ) +where + +import Clash.Prelude hiding (feedback) +import Control.Lens +import Control.Monad +import Control.Monad.Trans.State + +decoderCase :: Bool -> BitVector 4 -> BitVector 16 +decoderCase enable binaryIn | enable = + case binaryIn of + 0x0 -> 0x0001 + 0x1 -> 0x0002 + 0x2 -> 0x0004 + 0x3 -> 0x0008 + 0x4 -> 0x0010 + 0x5 -> 0x0020 + 0x6 -> 0x0040 + 0x7 -> 0x0080 + 0x8 -> 0x0100 + 0x9 -> 0x0200 + 0xA -> 0x0400 + 0xB -> 0x0800 + 0xC -> 0x1000 + 0xD -> 0x2000 + 0xE -> 0x4000 + 0xF -> 0x8000 +decoderCase _ _ = 0 + +decoderShift :: Bool -> BitVector 4 -> BitVector 16 +decoderShift enable binaryIn = + if enable + then 1 `shiftL` (fromIntegral binaryIn) + else 0 + +encoderCase :: Bool -> BitVector 16 -> BitVector 4 +encoderCase enable binaryIn | enable = + case binaryIn of + 0x0001 -> 0x0 + 0x0002 -> 0x1 + 0x0004 -> 0x2 + 0x0008 -> 0x3 + 0x0010 -> 0x4 + 0x0020 -> 0x5 + 0x0040 -> 0x6 + 0x0080 -> 0x7 + 0x0100 -> 0x8 + 0x0200 -> 0x9 + 0x0400 -> 0xA + 0x0800 -> 0xB + 0x1000 -> 0xC + 0x2000 -> 0xD + 0x4000 -> 0xE + 0x8000 -> 0xF +encoderCase _ _ = 0 + +upCounter :: HiddenClockReset domain gated synchronous + => Signal domain Bool -> Signal domain (Unsigned 8) +upCounter enable = s + where + s = register 0 (mux enable (s + 1) s) + +upCounterLdT + :: Num a => a -> (Bool, Bool, a) -> (a,a) +upCounterLdT s (ld,en,dIn) = (s',s) + where + s' | ld = dIn + | en = s + 1 + | otherwise = s + +upCounterLd :: HiddenClockReset domain gated synchronous + => Signal domain (Bool,Bool,Unsigned 8) -> Signal domain (Unsigned 8) +upCounterLd = mealy upCounterLdT 0 + +upDownCounter :: HiddenClockReset domain gated synchronous + => Signal domain Bool -> Signal domain (Unsigned 8) +upDownCounter upDown = s + where + s = register 0 (mux upDown (s + 1) (s - 1)) + +lfsrF' :: BitVector 16 -> BitVector 16 +lfsrF' s = pack feedback ++# slice d15 d1 s + where + feedback = s!5 `xor` s!3 `xor` s!2 `xor` s!0 + +lfsrF :: HiddenClockReset domain gated synchronous + => BitVector 16 -> Signal domain Bit +lfsrF seed = msb <$> r + where r = register seed (lfsrF' <$> r) + +lfsrGP + :: (KnownNat (n + 1), Bits a) + => Vec (n + 1) Bool + -> Vec (n + 1) a + -> Vec (n + 1) a +lfsrGP taps regs = zipWith xorM taps (fb +>> regs) + where + fb = last regs + xorM i x | i = x `xor` fb + | otherwise = x + +lfsrG :: HiddenClockReset domain gated synchronous => BitVector 16 -> Signal domain Bit +lfsrG seed = last (unbundle r) + where r = register (unpack seed) (lfsrGP (unpack 0b0011010000000000) <$> r) + +grayCounter :: HiddenClockReset domain gated synchronous + => Signal domain Bool -> Signal domain (BitVector 8) +grayCounter en = gray <$> upCounter en + where gray xs = pack (msb xs) ++# xor (slice d7 d1 xs) (slice d6 d0 xs) + +oneHotCounter :: HiddenClockReset domain gated synchronous + => Signal domain Bool -> Signal domain (BitVector 8) +oneHotCounter enable = s + where + s = register 1 (mux enable (rotateL <$> s <*> 1) s) + +crcT + :: (Bits a, KnownNat (BitSize a), BitPack a) + => a -> Bit -> a +crcT bv dIn = replaceBit 0 dInXor + $ replaceBit 5 (bv!4 `xor` dInXor) + $ replaceBit 12 (bv!11 `xor` dInXor) + rotated + where + dInXor = dIn `xor` fb + rotated = rotateL bv 1 + fb = msb bv + +crc :: HiddenClockReset domain gated synchronous + => Signal domain Bool -> Signal domain Bool -> Signal domain Bit -> Signal domain (BitVector 16) +crc enable ld dIn = s + where + s = register 0xFFFF (mux enable (mux ld 0xFFFF (crcT <$> s <*> dIn)) s) + +data RxReg + = RxReg + { _rx_reg :: BitVector 8 + , _rx_data :: BitVector 8 + , _rx_sample_cnt :: Unsigned 4 + , _rx_cnt :: Unsigned 4 + , _rx_frame_err :: Bool + , _rx_over_run :: Bool + , _rx_empty :: Bool + , _rx_d1 :: Bit + , _rx_d2 :: Bit + , _rx_busy :: Bool + } + +makeLenses ''RxReg + +data TxReg + = TxReg + { _tx_reg :: BitVector 8 + , _tx_empty :: Bool + , _tx_over_run :: Bool + , _tx_out :: Bit + , _tx_cnt :: Unsigned 4 + } + +makeLenses ''TxReg + +uartTX t@(TxReg {..}) ld_tx_data tx_data tx_enable = flip execState t $ do + when ld_tx_data $ do + if not _tx_empty then + tx_over_run .= False + else do + tx_reg .= tx_data + tx_empty .= False + when (tx_enable && not _tx_empty) $ do + tx_cnt += 1 + when (_tx_cnt == 0) $ + tx_out .= 0 + when (_tx_cnt > 0 && _tx_cnt < 9) $ + tx_out .= _tx_reg ! (_tx_cnt - 1) + when (_tx_cnt == 9) $ do + tx_out .= 1 + tx_cnt .= 0 + tx_empty .= True + unless tx_enable $ + tx_cnt .= 0 + +uartRX r@(RxReg {..}) rx_in uld_rx_data rx_enable = flip execState r $ do + -- Synchronise the async signal + rx_d1 .= rx_in + rx_d2 .= _rx_d1 + -- Uload the rx data + when uld_rx_data $ do + rx_data .= _rx_reg + rx_empty .= True + -- Receive data only when rx is enabled + if rx_enable then do + -- Check if just received start of frame + when (not _rx_busy && _rx_d2 == 0) $ do + rx_busy .= True + rx_sample_cnt .= 1 + rx_cnt .= 0 + -- Star of frame detected, Proceed with rest of data + when _rx_busy $ do + rx_sample_cnt += 1 + -- Logic to sample at middle of data + when (_rx_sample_cnt == 7) $ do + if _rx_d1 == 1 && _rx_cnt == 0 then + rx_busy .= False + else do + rx_cnt += 1 + -- start storing the rx data + when (_rx_cnt > 0 && _rx_cnt < 9) $ do + rx_reg %= replaceBit (_rx_cnt - 1) _rx_d2 + when (_rx_cnt == 9) $ do + rx_busy .= False + -- Check if End of frame received correctly + if _rx_d2 == 0 then + rx_frame_err .= True + else do + rx_empty .= False + rx_frame_err .= False + -- Check if last rx data was not unloaded + rx_over_run .= not _rx_empty + else do + rx_busy .= False + +uart ld_tx_data tx_data tx_enable rx_in uld_rx_data rx_enable = + ( _tx_out <$> txReg + , _tx_empty <$> txReg + , _rx_data <$> rxReg + , _rx_empty <$> rxReg + ) + where + rxReg = register rxRegInit (uartRX <$> rxReg <*> rx_in <*> uld_rx_data + <*> rx_enable) + rxRegInit = RxReg { _rx_reg = 0 + , _rx_data = 0 + , _rx_sample_cnt = 0 + , _rx_cnt = 0 + , _rx_frame_err = False + , _rx_over_run = False + , _rx_empty = True + , _rx_d1 = 1 + , _rx_d2 = 1 + , _rx_busy = False + } + txReg = register txRegInit (uartTX <$> txReg <*> ld_tx_data <*> tx_data + <*> tx_enable) + txRegInit = TxReg { _tx_reg = 0 + , _tx_empty = True + , _tx_over_run = False + , _tx_out = 1 + , _tx_cnt = 0 + } + +{- $setup +>>> :set -XDataKinds +>>> import Clash.Prelude +>>> import Test.QuickCheck +-} + +{- $decoders_and_encoders += Decoder + +Using a @case@ statement: + +@ +decoderCase :: Bool -> BitVector 4 -> BitVector 16 +decoderCase enable binaryIn | enable = + case binaryIn of + 0x0 -> 0x0001 + 0x1 -> 0x0002 + 0x2 -> 0x0004 + 0x3 -> 0x0008 + 0x4 -> 0x0010 + 0x5 -> 0x0020 + 0x6 -> 0x0040 + 0x7 -> 0x0080 + 0x8 -> 0x0100 + 0x9 -> 0x0200 + 0xA -> 0x0400 + 0xB -> 0x0800 + 0xC -> 0x1000 + 0xD -> 0x2000 + 0xE -> 0x4000 + 0xF -> 0x8000 +decoderCase _ _ = 0 +@ + +Using the `shiftL` function: + +@ +decoderShift :: Bool -> BitVector 4 -> BitVector 16 +decoderShift enable binaryIn = + if enable + then 1 ``shiftL`` ('fromIntegral' binaryIn) + else 0 +@ + +Examples: + +>>> decoderCase True 3 +0000_0000_0000_1000 +>>> decoderShift True 7 +0000_0000_1000_0000 + +The following property holds: + +prop> \enable binaryIn -> decoderShift enable binaryIn === decoderCase enable binaryIn + += Encoder + +Using a @case@ statement: + +@ +encoderCase :: Bool -> BitVector 16 -> BitVector 4 +encoderCase enable binaryIn | enable = + case binaryIn of + 0x0001 -> 0x0 + 0x0002 -> 0x1 + 0x0004 -> 0x2 + 0x0008 -> 0x3 + 0x0010 -> 0x4 + 0x0020 -> 0x5 + 0x0040 -> 0x6 + 0x0080 -> 0x7 + 0x0100 -> 0x8 + 0x0200 -> 0x9 + 0x0400 -> 0xA + 0x0800 -> 0xB + 0x1000 -> 0xC + 0x2000 -> 0xD + 0x4000 -> 0xE + 0x8000 -> 0xF +encoderCase _ _ = 0 +@ + +The following property holds: + +prop> \en decIn -> en ==> (encoderCase en (decoderCase en decIn) === decIn) +-} + +{- $counters += 8-bit Simple Up Counter + +Using `register`: + +@ +upCounter + :: HiddenClockReset domain gated synchronous + => Signal domain Bool + -> Signal domain (Unsigned 8) +upCounter enable = s + where + s = `register` 0 (`mux` enable (s + 1) s) +@ + += 8-bit Up Counter With Load + +Using `mealy`: + +@ +upCounterLd + :: HiddenClockReset domain gated synchronous + => Signal domain (Bool,Bool,Unsigned 8) + -> Signal domain (Unsigned 8) +upCounterLd = `mealy` upCounterLdT 0 + +upCounterLdT s (ld,en,dIn) = (s',s) + where + s' | ld = dIn + | en = s + 1 + | otherwise = s +@ + += 8-bit Up-Down counter + +Using `register` and `mux`: + +@ +upDownCounter + :: HiddenClockReset domain gated synchronous + => Signal domain Bool + -> Signal domain (Unsigned 8) +upDownCounter upDown = s + where + s = `register` 0 (`mux` upDown (s + 1) (s - 1)) +@ + +The following property holds: + +prop> \en -> en ==> testFor 1000 (upCounter (pure en) .==. upDownCounter (pure en)) + += LFSR + +External/Fibonacci LFSR, for @n=16@ and using the primitive polynominal @1 + x^11 + x^13 + x^14 + x^16@ + +@ +lfsrF' :: BitVector 16 -> BitVector 16 +lfsrF' s = 'pack' feedback '++#' 'slice' d15 d1 s + where + feedback = s'!'5 ``xor`` s'!'3 ``xor`` s'!'2 ``xor`` s'!'0 + +lfsrF + :: HiddenClockReset domain gated synchronous + => BitVector 16 + -> Signal domain Bit +lfsrF seed = 'msb' '<$>' r + where r = 'register' seed (lfsrF' '<$>' r) +@ + +We can also build a internal/Galois LFSR which has better timing characteristics. +We first define a Galois LFSR parametrizable in its filter taps: + +@ +lfsrGP taps regs = 'zipWith' xorM taps (fb '+>>' regs) + where + fb = 'last' regs + xorM i x | i = x ``xor`` fb + | otherwise = x +@ + +Then we can instantiate a 16-bit LFSR as follows: + +@ +lfsrG :: HiddenClockReset domain gated synchronous => BitVector 16 -> Signal domain Bit +lfsrG seed = 'last' ('unbundle' r) + where r = 'register' ('unpack' seed) (lfsrGP ('unpack' 0b0011010000000000) '<$>' r) +@ + +The following property holds: + +prop> testFor 100 (lfsrF 0xACE1 .==. lfsrG 0x4645) + += Gray counter + +Using the previously defined @upCounter@: + +@ +grayCounter + :: HiddenClockReset domain gated synchronous + => Signal domain Bool + -> Signal domain (BitVector 8) +grayCounter en = gray '<$>' upCounter en + where gray xs = 'pack' ('msb' xs) '++#' 'xor' ('slice' d7 d1 xs) ('slice' d6 d0 xs) +@ + += One-hot counter + +Basically a barrel-shifter: + +@ +oneHotCounter + :: HiddenClockReset domain gated synchronous + => Signal domain Bool + -> Signal domain (BitVector 8) +oneHotCounter enable = s + where + s = 'register' 1 ('mux' enable ('rotateL' '<$>' s '<*>' 1) s) +@ +-} + +{- $parity_and_crc += Parity + +Just 'reduceXor': + +@ +parity :: Unsigned 8 -> Bit +parity data_in = `reduceXor` data_in +@ + += Serial CRC + +* Width = 16 bits +* Truncated polynomial = 0x1021 +* Initial value = 0xFFFF +* Input data is NOT reflected +* Output CRC is NOT reflected +* No XOR is performed on the output CRC + +@ +crcT bv dIn = 'replaceBit' 0 dInXor + $ 'replaceBit' 5 (bv'!'4 ``xor`` dInXor) + $ 'replaceBit' 12 (bv'!'11 ``xor`` dInXor) + rotated + where + dInXor = dIn ``xor`` fb + rotated = 'rotateL' bv 1 + fb = 'msb' bv + +crc + :: HiddenClockReset domain gated synchronous + => Signal domain Bool + -> Signal domain Bool + -> Signal domain Bit + -> Signal domain (BitVector 16) +crc enable ld dIn = s + where + s = 'register' 0xFFFF ('mux' enable ('mux' ld 0xFFFF (crcT '<$>' s '<*>' dIn)) s) +@ +-} + +{- $uart +@ +{\-\# LANGUAGE RecordWildCards \#-\} +module UART (uart) where + +import Clash.Prelude +import Control.Lens +import Control.Monad +import Control.Monad.Trans.State + +-- UART RX Logic +data RxReg + = RxReg + { _rx_reg :: BitVector 8 + , _rx_data :: BitVector 8 + , _rx_sample_cnt :: Unsigned 4 + , _rx_cnt :: Unsigned 4 + , _rx_frame_err :: Bool + , _rx_over_run :: Bool + , _rx_empty :: Bool + , _rx_d1 :: Bit + , _rx_d2 :: Bit + , _rx_busy :: Bool + } + +makeLenses ''RxReg + +uartRX r\@(RxReg {..}) rx_in uld_rx_data rx_enable = 'flip' 'execState' r $ do + -- Synchronise the async signal + rx_d1 '.=' rx_in + rx_d2 '.=' _rx_d1 + -- Uload the rx data + 'when' uld_rx_data $ do + rx_data '.=' _rx_reg + rx_empty '.=' True + -- Receive data only when rx is enabled + if rx_enable then do + -- Check if just received start of frame + 'when' (not _rx_busy && _rx_d2 == 0) $ do + rx_busy '.=' True + rx_sample_cnt '.=' 1 + rx_cnt '.=' 0 + -- Star of frame detected, Proceed with rest of data + 'when' _rx_busy $ do + rx_sample_cnt '+=' 1 + -- Logic to sample at middle of data + 'when' (_rx_sample_cnt == 7) $ do + if _rx_d1 == 1 && _rx_cnt == 0 then + rx_busy '.=' False + else do + rx_cnt '+=' 1 + -- start storing the rx data + 'when' (_rx_cnt > 0 && _rx_cnt < 9) $ do + rx_reg '%=' 'replaceBit' (_rx_cnt - 1) _rx_d2 + 'when' (_rx_cnt == 9) $ do + rx_busy .= False + -- Check if End of frame received correctly + if _rx_d2 == 0 then + rx_frame_err '.=' True + else do + rx_empty '.=' False + rx_frame_err '.=' False + -- Check if last rx data was not unloaded + rx_over_run '.=' not _rx_empty + else do + rx_busy .= False + +-- UART TX Logic +data TxReg + = TxReg + { _tx_reg :: BitVector 8 + , _tx_empty :: Bool + , _tx_over_run :: Bool + , _tx_out :: Bit + , _tx_cnt :: Unsigned 4 + } + +makeLenses ''TxReg + +uartTX t\@(TxReg {..}) ld_tx_data tx_data tx_enable = 'flip' 'execState' t $ do + 'when' ld_tx_data $ do + if not _tx_empty then + tx_over_run '.=' False + else do + tx_reg '.=' tx_data + tx_empty '.=' False + 'when' (tx_enable && not _tx_empty) $ do + tx_cnt '+=' 1 + 'when' (_tx_cnt == 0) $ + tx_out '.=' 0 + 'when' (_tx_cnt > 0 && _tx_cnt < 9) $ + tx_out '.=' _tx_reg '!' (_tx_cnt - 1) + 'when' (_tx_cnt == 9) $ do + tx_out '.=' 1 + tx_cnt '.=' 0 + tx_empty '.=' True + 'unless' tx_enable $ + tx_cnt '.=' 0 + +-- Combine RX and TX logic +uart ld_tx_data tx_data tx_enable rx_in uld_rx_data rx_enable = + ( _tx_out '<$>' txReg + , _tx_empty '<$>' txReg + , _rx_data '<$>' rxReg + , _rx_empty '<$>' rxReg + ) + where + rxReg = register rxRegInit (uartRX '<$>' rxReg '<*>' rx_in '<*>' uld_rx_data + '<*>' rx_enable) + rxRegInit = RxReg { _rx_reg = 0 + , _rx_data = 0 + , _rx_sample_cnt = 0 + , _rx_cnt = 0 + , _rx_frame_err = False + , _rx_over_run = False + , _rx_empty = True + , _rx_d1 = 1 + , _rx_d2 = 1 + , _rx_busy = False + } + + txReg = register txRegInit (uartTX '<$>' txReg '<*>' ld_tx_data '<*>' tx_data + '<*>' tx_enable) + txRegInit = TxReg { _tx_reg = 0 + , _tx_empty = True + , _tx_over_run = False + , _tx_out = 1 + , _tx_cnt = 0 + } +@ +-} diff --git a/src/Clash/Explicit/BlockRam.hs b/src/Clash/Explicit/BlockRam.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Explicit/BlockRam.hs @@ -0,0 +1,800 @@ +{-| +Copyright : (C) 2013-2016, University of Twente, + 2016-2017, Myrtle Software Ltd, + 2017 , Google Inc. +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij + +BlockRAM primitives + += Using RAMs #usingrams# + +We will show a rather elaborate example on how you can, and why you might want +to use 'blockRam's. We will build a \"small\" CPU+Memory+Program ROM where we +will slowly evolve to using blockRams. Note that the code is /not/ meant as a +de-facto standard on how to do CPU design in CλaSH. + +We start with the definition of the Instructions, Register names and machine +codes: + +@ +{\-\# LANGUAGE RecordWildCards, TupleSections \#-\} +module CPU where + +import Clash.Explicit.Prelude + +type InstrAddr = Unsigned 8 +type MemAddr = Unsigned 5 +type Value = Signed 8 + +data Instruction + = Compute Operator Reg Reg Reg + | Branch Reg Value + | Jump Value + | Load MemAddr Reg + | Store Reg MemAddr + | Nop + deriving (Eq,Show) + +data Reg + = Zero + | PC + | RegA + | RegB + | RegC + | RegD + | RegE + deriving (Eq,Show,Enum) + +data Operator = Add | Sub | Incr | Imm | CmpGt + deriving (Eq,Show) + +data MachCode + = MachCode + { inputX :: Reg + , inputY :: Reg + , result :: Reg + , aluCode :: Operator + , ldReg :: Reg + , rdAddr :: MemAddr + , wrAddrM :: Maybe MemAddr + , jmpM :: Maybe Value + } + +nullCode = MachCode { inputX = Zero, inputY = Zero, result = Zero, aluCode = Imm + , ldReg = Zero, rdAddr = 0, wrAddrM = Nothing + , jmpM = Nothing + } +@ + +Next we define the CPU and its ALU: + +@ +cpu + :: Vec 7 Value + -- ^ Register bank + -> (Value,Instruction) + -- ^ (Memory output, Current instruction) + -> ( Vec 7 Value + , (MemAddr, Maybe (MemAddr,Value), InstrAddr) + ) +cpu regbank (memOut,instr) = (regbank',(rdAddr,(,aluOut) '<$>' wrAddrM,fromIntegral ipntr)) + where + -- Current instruction pointer + ipntr = regbank '!!' PC + + -- Decoder + (MachCode {..}) = case instr of + Compute op rx ry res -> nullCode {inputX=rx,inputY=ry,result=res,aluCode=op} + Branch cr a -> nullCode {inputX=cr,jmpM=Just a} + Jump a -> nullCode {aluCode=Incr,jmpM=Just a} + Load a r -> nullCode {ldReg=r,rdAddr=a} + Store r a -> nullCode {inputX=r,wrAddrM=Just a} + Nop -> nullCode + + -- ALU + regX = regbank '!!' inputX + regY = regbank '!!' inputY + aluOut = alu aluCode regX regY + + -- next instruction + nextPC = case jmpM of + Just a | aluOut /= 0 -> ipntr + a + _ -> ipntr + 1 + + -- update registers + regbank' = 'replace' Zero 0 + $ 'replace' PC nextPC + $ 'replace' result aluOut + $ 'replace' ldReg memOut + $ regbank + +alu Add x y = x + y +alu Sub x y = x - y +alu Incr x _ = x + 1 +alu Imm x _ = x +alu CmpGt x y = if x > y then 1 else 0 +@ + +We initially create a memory out of simple registers: + +@ +dataMem + :: Clock domain gated + -> Reset domain synchronous + -> Signal domain MemAddr + -- ^ Read address + -> Signal domain (Maybe (MemAddr,Value)) + -- ^ (write address, data in) + -> Signal domain Value + -- ^ data out +dataMem clk rst rd wrM = 'Clash.Explicit.Mealy.mealy' clk rst dataMemT ('Clash.Sized.Vector.replicate' d32 0) (bundle (rd,wrM)) + where + dataMemT mem (rd,wrM) = (mem',dout) + where + dout = mem '!!' rd + mem' = case wrM of + Just (wr,din) -> 'replace' wr din mem + _ -> mem +@ + +And then connect everything: + +@ +system + :: KnownNat n + => Vec n Instruction + -> Clock domain gated + -> Reset domain synchronous + -> Signal domain Value +system instrs clk rst = memOut + where + memOut = dataMem clk rst rdAddr dout + (rdAddr,dout,ipntr) = 'Clash.Explicit.Mealy.mealyB' clk rst cpu ('Clash.Sized.Vector.replicate' d7 0) (memOut,instr) + instr = 'Clash.Explicit.Prelude.asyncRom' instrs '<$>' ipntr +@ + +Create a simple program that calculates the GCD of 4 and 6: + +@ +-- Compute GCD of 4 and 6 +prog = -- 0 := 4 + Compute Incr Zero RegA RegA :> + replicate d3 (Compute Incr RegA Zero RegA) ++ + Store RegA 0 :> + -- 1 := 6 + Compute Incr Zero RegA RegA :> + replicate d5 (Compute Incr RegA Zero RegA) ++ + Store RegA 1 :> + -- A := 4 + Load 0 RegA :> + -- B := 6 + Load 1 RegB :> + -- start + Compute CmpGt RegA RegB RegC :> + Branch RegC 4 :> + Compute CmpGt RegB RegA RegC :> + Branch RegC 4 :> + Jump 5 :> + -- (a > b) + Compute Sub RegA RegB RegA :> + Jump (-6) :> + -- (b > a) + Compute Sub RegB RegA RegB :> + Jump (-8) :> + -- end + Store RegA 2 :> + Load 2 RegC :> + Nil +@ + +And test our system: + +@ +>>> sampleN 31 $ system prog systemClockGen systemResetGen +[0,0,0,0,0,4,4,4,4,4,4,4,4,6,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,2] + +@ + +to see that our system indeed calculates that the GCD of 6 and 4 is 2. + +=== Improvement 1: using @asyncRam@ + +As you can see, it's fairly straightforward to build a memory using registers +and read ('!!') and write ('replace') logic. This might however not result in +the most efficient hardware structure, especially when building an ASIC. + +Instead it is preferable to use the 'Clash.Prelude.RAM.asyncRam' function which +has the potential to be translated to a more efficient structure: + +@ +system2 + :: KnownNat n + => Vec n Instruction + -> Clock domain gated + -> Reset domain synchronous + -> Signal domain Value +system2 instrs clk rst = memOut + where + memOut = 'Clash.Explicit.RAM.asyncRam' clk clk d32 rdAddr dout + (rdAddr,dout,ipntr) = 'mealyB' clk rst cpu ('Clash.Sized.Vector.replicate' d7 0) (memOut,instr) + instr = 'Clash.Prelude.ROM.asyncRom' instrs '<$>' ipntr +@ + +Again, we can simulate our system and see that it works. This time however, +we need to disregard the first few output samples, because the initial content of an +'Clash.Prelude.RAM.asyncRam' is 'undefined', and consequently, the first few +output samples are also 'undefined'. We use the utility function 'printX' to conveniently +filter out the undefinedness and replace it with the string "X" in the few leading outputs. + +@ +>>> printX $ sampleN 31 $ system2 prog systemClockGen systemResetGen +[X,X,X,X,X,4,4,4,4,4,4,4,4,6,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,2] + +@ + +=== Improvement 2: using @blockRam@ + +Finally we get to using 'blockRam'. On FPGAs, 'Clash.Prelude.RAM.asyncRam' will +be implemented in terms of LUTs, and therefore take up logic resources. FPGAs +also have large(r) memory structures called /Block RAMs/, which are preferred, +especially as the memories we need for our application get bigger. The +'blockRam' function will be translated to such a /Block RAM/. + +One important aspect of Block RAMs have a /synchronous/ read port, meaning that, +unlike the behaviour of 'Clash.Prelude.RAM.asyncRam', given a read address @r@ +at time @t@, the value @v@ in the RAM at address @r@ is only available at time +@t+1@. + +For us that means we need to change the design of our CPU. Right now, upon a +load instruction we generate a read address for the memory, and the value at +that read address is immediately available to be put in the register bank. +Because we will be using a BlockRAM, the value is delayed until the next cycle. +We hence need to also delay the register address to which the memory address +is loaded: + +@ +cpu2 + :: (Vec 7 Value,Reg) + -- ^ (Register bank, Load reg addr) + -> (Value,Instruction) + -- ^ (Memory output, Current instruction) + -> ( (Vec 7 Value,Reg) + , (MemAddr, Maybe (MemAddr,Value), InstrAddr) + ) +cpu2 (regbank,ldRegD) (memOut,instr) = ((regbank',ldRegD'),(rdAddr,(,aluOut) '<$>' wrAddrM,fromIntegral ipntr)) + where + -- Current instruction pointer + ipntr = regbank '!!' PC + + -- Decoder + (MachCode {..}) = case instr of + Compute op rx ry res -> nullCode {inputX=rx,inputY=ry,result=res,aluCode=op} + Branch cr a -> nullCode {inputX=cr,jmpM=Just a} + Jump a -> nullCode {aluCode=Incr,jmpM=Just a} + Load a r -> nullCode {ldReg=r,rdAddr=a} + Store r a -> nullCode {inputX=r,wrAddrM=Just a} + Nop -> nullCode + + -- ALU + regX = regbank '!!' inputX + regY = regbank '!!' inputY + aluOut = alu aluCode regX regY + + -- next instruction + nextPC = case jmpM of + Just a | aluOut /= 0 -> ipntr + a + _ -> ipntr + 1 + + -- update registers + ldRegD' = ldReg -- Delay the ldReg by 1 cycle + regbank' = 'replace' Zero 0 + $ 'replace' PC nextPC + $ 'replace' result aluOut + $ 'replace' ldRegD memOut + $ regbank +@ + +We can now finally instantiate our system with a 'blockRam': + +@ +system3 + :: KnownNat n + => Vec n Instruction + -> Clock domain gated + -> Reset domain synchronous + -> Signal domain Value +system3 instrs clk rst = memOut + where + memOut = 'blockRam' clk (replicate d32 0) rdAddr dout + (rdAddr,dout,ipntr) = 'mealyB' clk rst cpu2 (('Clash.Sized.Vector.replicate' d7 0),Zero) (memOut,instr) + instr = 'Clash.Explicit.Prelude.asyncRom' instrs '<$>' ipntr +@ + +We are, however, not done. We will also need to update our program. The reason +being that values that we try to load in our registers won't be loaded into the +register until the next cycle. This is a problem when the next instruction +immediately depended on this memory value. In our case, this was only the case +when the loaded the value @6@, which was stored at address @1@, into @RegB@. +Our updated program is thus: + +@ +prog2 = -- 0 := 4 + Compute Incr Zero RegA RegA :> + replicate d3 (Compute Incr RegA Zero RegA) ++ + Store RegA 0 :> + -- 1 := 6 + Compute Incr Zero RegA RegA :> + replicate d5 (Compute Incr RegA Zero RegA) ++ + Store RegA 1 :> + -- A := 4 + Load 0 RegA :> + -- B := 6 + Load 1 RegB :> + Nop :> -- Extra NOP + -- start + Compute CmpGt RegA RegB RegC :> + Branch RegC 4 :> + Compute CmpGt RegB RegA RegC :> + Branch RegC 4 :> + Jump 5 :> + -- (a > b) + Compute Sub RegA RegB RegA :> + Jump (-6) :> + -- (b > a) + Compute Sub RegB RegA RegB :> + Jump (-8) :> + -- end + Store RegA 2 :> + Load 2 RegC :> + Nil +@ + +When we simulate our system we see that it works. This time again, +we need to disregard the first sample, because the initial output of a +'blockRam' is 'undefined'. We use the utility function 'printX' to conveniently +filter out the undefinedness and replace it with the string "X". + +@ +>>> printX $ sampleN 33 $ system3 prog2 systemClockGen systemResetGen +[X,0,0,0,0,0,4,4,4,4,4,4,4,4,6,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,2] + +@ + +This concludes the short introduction to using 'blockRam'. + +-} + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +{-# LANGUAGE Trustworthy #-} + +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} +{-# OPTIONS_HADDOCK show-extensions #-} + +-- See: https://github.com/clash-lang/clash-compiler/commit/721fcfa9198925661cd836668705f817bddaae3c +-- as to why we need this. +{-# OPTIONS_GHC -fno-cpr-anal #-} + +module Clash.Explicit.BlockRam + ( -- * BlockRAM synchronised to the system clock + blockRam + , blockRamPow2 + -- * Read/Write conflict resolution + , readNew + -- * Internal + , blockRam# + ) +where + +import Data.Maybe (fromJust, isJust) +import qualified Data.Vector as V +import GHC.Stack (HasCallStack, withFrozenCallStack) +import GHC.TypeLits (KnownNat, type (^)) +import Prelude hiding (length) + +import Clash.Signal.Internal + (Clock, Reset, Signal (..), (.&&.), clockEnable, mux, register#) +import Clash.Signal.Bundle (unbundle) +import Clash.Sized.Unsigned (Unsigned) +import Clash.Sized.Vector (Vec, toList) +import Clash.XException (errorX, seqX) + +{- $setup +>>> import Clash.Explicit.Prelude as C +>>> import qualified Data.List as L +>>> :set -XDataKinds -XRecordWildCards -XTupleSections +>>> type InstrAddr = Unsigned 8 +>>> type MemAddr = Unsigned 5 +>>> type Value = Signed 8 +>>> :{ +data Reg + = Zero + | PC + | RegA + | RegB + | RegC + | RegD + | RegE + deriving (Eq,Show,Enum) +:} + +>>> :{ +data Operator = Add | Sub | Incr | Imm | CmpGt + deriving (Eq,Show) +:} + +>>> :{ +data Instruction + = Compute Operator Reg Reg Reg + | Branch Reg Value + | Jump Value + | Load MemAddr Reg + | Store Reg MemAddr + | Nop + deriving (Eq,Show) +:} + +>>> :{ +data MachCode + = MachCode + { inputX :: Reg + , inputY :: Reg + , result :: Reg + , aluCode :: Operator + , ldReg :: Reg + , rdAddr :: MemAddr + , wrAddrM :: Maybe MemAddr + , jmpM :: Maybe Value + } +:} + +>>> :{ +nullCode = MachCode { inputX = Zero, inputY = Zero, result = Zero, aluCode = Imm + , ldReg = Zero, rdAddr = 0, wrAddrM = Nothing + , jmpM = Nothing + } +:} + +>>> :{ +alu Add x y = x + y +alu Sub x y = x - y +alu Incr x _ = x + 1 +alu Imm x _ = x +alu CmpGt x y = if x > y then 1 else 0 +:} + +>>> :{ +cpu :: Vec 7 Value -- ^ Register bank + -> (Value,Instruction) -- ^ (Memory output, Current instruction) + -> ( Vec 7 Value + , (MemAddr,Maybe (MemAddr,Value),InstrAddr) + ) +cpu regbank (memOut,instr) = (regbank',(rdAddr,(,aluOut) <$> wrAddrM,fromIntegral ipntr)) + where + -- Current instruction pointer + ipntr = regbank C.!! PC + -- Decoder + (MachCode {..}) = case instr of + Compute op rx ry res -> nullCode {inputX=rx,inputY=ry,result=res,aluCode=op} + Branch cr a -> nullCode {inputX=cr,jmpM=Just a} + Jump a -> nullCode {aluCode=Incr,jmpM=Just a} + Load a r -> nullCode {ldReg=r,rdAddr=a} + Store r a -> nullCode {inputX=r,wrAddrM=Just a} + Nop -> nullCode + -- ALU + regX = regbank C.!! inputX + regY = regbank C.!! inputY + aluOut = alu aluCode regX regY + -- next instruction + nextPC = case jmpM of + Just a | aluOut /= 0 -> ipntr + a + _ -> ipntr + 1 + -- update registers + regbank' = replace Zero 0 + $ replace PC nextPC + $ replace result aluOut + $ replace ldReg memOut + $ regbank +:} + +>>> :{ +dataMem + :: Clock domain gated + -> Reset domain synchronous + -> Signal domain MemAddr + -> Signal domain (Maybe (MemAddr,Value)) + -> Signal domain Value +dataMem clk rst rd wrM = mealy clk rst dataMemT (C.replicate d32 0) (bundle (rd,wrM)) + where + dataMemT mem (rd,wrM) = (mem',dout) + where + dout = mem C.!! rd + mem' = case wrM of + Just (wr,din) -> replace wr din mem + Nothing -> mem +:} + +>>> :{ +system + :: KnownNat n + => Vec n Instruction + -> Clock domain gated + -> Reset domain synchronous + -> Signal domain Value +system instrs clk rst = memOut + where + memOut = dataMem clk rst rdAddr dout + (rdAddr,dout,ipntr) = mealyB clk rst cpu (C.replicate d7 0) (memOut,instr) + instr = asyncRom instrs <$> ipntr +:} + +>>> :{ +-- Compute GCD of 4 and 6 +prog = -- 0 := 4 + Compute Incr Zero RegA RegA :> + C.replicate d3 (Compute Incr RegA Zero RegA) C.++ + Store RegA 0 :> + -- 1 := 6 + Compute Incr Zero RegA RegA :> + C.replicate d5 (Compute Incr RegA Zero RegA) C.++ + Store RegA 1 :> + -- A := 4 + Load 0 RegA :> + -- B := 6 + Load 1 RegB :> + -- start + Compute CmpGt RegA RegB RegC :> + Branch RegC 4 :> + Compute CmpGt RegB RegA RegC :> + Branch RegC 4 :> + Jump 5 :> + -- (a > b) + Compute Sub RegA RegB RegA :> + Jump (-6) :> + -- (b > a) + Compute Sub RegB RegA RegB :> + Jump (-8) :> + -- end + Store RegA 2 :> + Load 2 RegC :> + Nil +:} + +>>> :{ +system2 + :: KnownNat n + => Vec n Instruction + -> Clock domain gated + -> Reset domain synchronous + -> Signal domain Value +system2 instrs clk rst = memOut + where + memOut = asyncRam clk clk d32 rdAddr dout + (rdAddr,dout,ipntr) = mealyB clk rst cpu (C.replicate d7 0) (memOut,instr) + instr = asyncRom instrs <$> ipntr +:} + +>>> :{ +cpu2 :: (Vec 7 Value,Reg) -- ^ (Register bank, Load reg addr) + -> (Value,Instruction) -- ^ (Memory output, Current instruction) + -> ( (Vec 7 Value,Reg) + , (MemAddr,Maybe (MemAddr,Value),InstrAddr) + ) +cpu2 (regbank,ldRegD) (memOut,instr) = ((regbank',ldRegD'),(rdAddr,(,aluOut) <$> wrAddrM,fromIntegral ipntr)) + where + -- Current instruction pointer + ipntr = regbank C.!! PC + -- Decoder + (MachCode {..}) = case instr of + Compute op rx ry res -> nullCode {inputX=rx,inputY=ry,result=res,aluCode=op} + Branch cr a -> nullCode {inputX=cr,jmpM=Just a} + Jump a -> nullCode {aluCode=Incr,jmpM=Just a} + Load a r -> nullCode {ldReg=r,rdAddr=a} + Store r a -> nullCode {inputX=r,wrAddrM=Just a} + Nop -> nullCode + -- ALU + regX = regbank C.!! inputX + regY = regbank C.!! inputY + aluOut = alu aluCode regX regY + -- next instruction + nextPC = case jmpM of + Just a | aluOut /= 0 -> ipntr + a + _ -> ipntr + 1 + -- update registers + ldRegD' = ldReg -- Delay the ldReg by 1 cycle + regbank' = replace Zero 0 + $ replace PC nextPC + $ replace result aluOut + $ replace ldRegD memOut + $ regbank +:} + +>>> :{ +system3 + :: KnownNat n + => Vec n Instruction + -> Clock domain gated + -> Reset domain synchronous + -> Signal domain Value +system3 instrs clk rst = memOut + where + memOut = blockRam clk (C.replicate d32 0) rdAddr dout + (rdAddr,dout,ipntr) = mealyB clk rst cpu2 ((C.replicate d7 0),Zero) (memOut,instr) + instr = asyncRom instrs <$> ipntr +:} + +>>> :{ +prog2 = -- 0 := 4 + Compute Incr Zero RegA RegA :> + C.replicate d3 (Compute Incr RegA Zero RegA) C.++ + Store RegA 0 :> + -- 1 := 6 + Compute Incr Zero RegA RegA :> + C.replicate d5 (Compute Incr RegA Zero RegA) C.++ + Store RegA 1 :> + -- A := 4 + Load 0 RegA :> + -- B := 6 + Load 1 RegB :> + Nop :> -- Extra NOP + -- start + Compute CmpGt RegA RegB RegC :> + Branch RegC 4 :> + Compute CmpGt RegB RegA RegC :> + Branch RegC 4 :> + Jump 5 :> + -- (a > b) + Compute Sub RegA RegB RegA :> + Jump (-6) :> + -- (b > a) + Compute Sub RegB RegA RegB :> + Jump (-8) :> + -- end + Store RegA 2 :> + Load 2 RegC :> + Nil +:} + +-} + +-- | Create a blockRAM with space for @n@ elements +-- +-- * __NB__: Read value is delayed by 1 cycle +-- * __NB__: Initial output value is 'undefined' +-- +-- @ +-- bram40 :: 'Clock' domain gated +-- -> 'Signal' domain ('Unsigned' 6) +-- -> 'Signal' domain (Maybe ('Unsigned' 6, 'Clash.Sized.BitVector.Bit')) +-- -> 'Signal' domain 'Clash.Sized.BitVector.Bit' +-- bram40 clk = 'blockRam' clk ('Clash.Sized.Vector.replicate' d40 1) +-- @ +-- +-- Additional helpful information: +-- +-- * See "Clash.Explicit.BlockRam#usingrams" for more information on how to use a +-- Block RAM. +-- * Use the adapter 'readNew' for obtaining write-before-read semantics like this: @'readNew' clk rst ('blockRam' clk inits) rd wrM@. +blockRam + :: HasCallStack + => Enum addr + => Clock dom gated + -- ^ 'Clock' to synchronize to + -> Vec n a + -- ^ Initial content of the BRAM, also determines the size, @n@, of the BRAM. + -- + -- __NB__: __MUST__ be a constant. + -> Signal dom addr + -- ^ Read address @r@ + -> Signal dom (Maybe (addr, a)) + -- ^ (write address @w@, value to write) + -> Signal dom a + -- ^ Value of the @blockRAM@ at address @r@ from the previous clock cycle +blockRam = \clk content rd wrM -> + let en = isJust <$> wrM + (wr,din) = unbundle (fromJust <$> wrM) + in withFrozenCallStack + (blockRam# clk content (fromEnum <$> rd) en (fromEnum <$> wr) din) +{-# INLINE blockRam #-} + +-- | Create a blockRAM with space for 2^@n@ elements +-- +-- * __NB__: Read value is delayed by 1 cycle +-- * __NB__: Initial output value is 'undefined' +-- +-- @ +-- bram32 :: 'Signal' domain ('Unsigned' 5) +-- -> 'Signal' domain (Maybe ('Unsigned' 5, 'Clash.Sized.BitVector.Bit')) +-- -> 'Signal' domain 'Clash.Sized.BitVector.Bit' +-- bram32 clk = 'blockRamPow2' clk ('Clash.Sized.Vector.replicate' d32 1) +-- @ +-- +-- Additional helpful information: +-- +-- * See "Clash.Prelude.BlockRam#usingrams" for more information on how to use a +-- Block RAM. +-- * Use the adapter 'readNew' for obtaining write-before-read semantics like this: @'readNew' clk rst ('blockRamPow2' clk inits) rd wrM@. +blockRamPow2 + :: (KnownNat n, HasCallStack) + => Clock dom gated -- ^ 'Clock' to synchronize to + -> Vec (2^n) a -- ^ Initial content of the BRAM, also + -- determines the size, @2^n@, of + -- the BRAM. + -- + -- __NB__: __MUST__ be a constant. + -> Signal dom (Unsigned n) -- ^ Read address @r@ + -> Signal dom (Maybe (Unsigned n, a)) + -- ^ (Write address @w@, value to write) + -> Signal dom a + -- ^ Value of the @blockRAM@ at address @r@ from the previous + -- clock cycle +blockRamPow2 = \clk cnt rd wrM -> withFrozenCallStack + (blockRam clk cnt rd wrM) +{-# INLINE blockRamPow2 #-} + +-- | blockRAM primitive +blockRam# + :: HasCallStack + => Clock dom gated -- ^ 'Clock' to synchronize to + -> Vec n a -- ^ Initial content of the BRAM, also + -- determines the size, @n@, of the BRAM. + -- + -- __NB__: __MUST__ be a constant. + -> Signal dom Int -- ^ Read address @r@ + -> Signal dom Bool -- ^ Write enable + -> Signal dom Int -- ^ Write address @w@ + -> Signal dom a -- ^ Value to write (at address @w@) + -> Signal dom a + -- ^ Value of the @blockRAM@ at address @r@ from the previous clock + -- cycle +blockRam# clk content rd wen = case clockEnable clk of + Nothing -> + go (V.fromList (toList content)) + (withFrozenCallStack (errorX "blockRam: intial value undefined")) + rd wen + Just ena -> + go' (V.fromList (toList content)) + (withFrozenCallStack (errorX "blockRam: intial value undefined")) + ena rd (wen .&&. ena) + where + -- no clock enable + go !ram o (r :- rs) (e :- en) (w :- wr) (d :- din) = + let ram' = upd ram e w d + o' = ram V.! r + in o `seqX` o :- go ram' o' rs en wr din + -- clock enable + go' !ram o (re :- res) (r :- rs) (e :- en) (w :- wr) (d :- din) = + let ram' = upd ram e w d + o' = if re then ram V.! r else o + in o `seqX` o :- go' ram' o' res rs en wr din + + upd ram True addr d = ram V.// [(addr,d)] + upd ram False _ _ = ram +{-# NOINLINE blockRam# #-} + +-- | Create read-after-write blockRAM from a read-before-write one +readNew + :: Eq addr + => Reset domain synchronous + -> Clock domain gated + -> (Signal domain addr -> Signal domain (Maybe (addr, a)) -> Signal domain a) + -- ^ The @ram@ component + -> Signal domain addr + -- ^ Read address @r@ + -> Signal domain (Maybe (addr, a)) + -- ^ (Write address @w@, value to write) + -> Signal domain a + -- ^ Value of the @ram@ at address @r@ from the previous clock cycle +readNew rst clk ram rdAddr wrM = mux wasSame wasWritten $ ram rdAddr wrM + where readNewT rd (Just (wr, wrdata)) = (wr == rd, wrdata) + readNewT _ Nothing = (False , undefined) + + (wasSame,wasWritten) = + unbundle (register# clk rst (False,undefined) + (readNewT <$> rdAddr <*> wrM)) diff --git a/src/Clash/Explicit/BlockRam/File.hs b/src/Clash/Explicit/BlockRam/File.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Explicit/BlockRam/File.hs @@ -0,0 +1,261 @@ +{-| +Copyright : (C) 2015-2016, University of Twente, + 2017 , Myrtle Software Ltd, Google Inc. +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij + += Initialising a BlockRAM with a data file #usingramfiles# + +BlockRAM primitives that can be initialised with a data file. The BNF grammar +for this data file is simple: + +@ +FILE = LINE+ +LINE = BIT+ +BIT = '0' + | '1' +@ + +Consecutive @LINE@s correspond to consecutive memory addresses starting at @0@. +For example, a data file @memory.bin@ containing the 9-bit unsigned number +@7@ to @13@ looks like: + +@ +000000111 +000001000 +000001001 +000001010 +000001011 +000001100 +000001101 +@ + +We can instantiate a BlockRAM using the content of the above file like so: + +@ +f + :: Clock domain gated + -> Signal domain (Unsigned 3) + -> Signal domain (Unsigned 9) +f clk rd = 'Clash.Class.BitPack.unpack' '<$>' 'blockRamFile' clk d7 \"memory.bin\" rd (signal Nothing) +@ + +In the example above, we basically treat the BlockRAM as an synchronous ROM. +We can see that it works as expected: + +@ +__>>> import qualified Data.List as L__ +__>>> L.tail $ sampleN 4 $ f systemClockGen (fromList [3..5])__ +[10,11,12] +@ + +However, we can also interpret the same data as a tuple of a 6-bit unsigned +number, and a 3-bit signed number: + +@ +g + :: Clock domain Source + -> Signal domain (Unsigned 3) + -> Signal domain (Unsigned 6,Signed 3) +g clk rd = 'Clash.Class.BitPack.unpack' '<$>' 'blockRamFile' clk d7 \"memory.bin\" rd (signal Nothing) +@ + +And then we would see: + +@ +__>>> import qualified Data.List as L__ +__>>> L.tail $ sampleN 4 $ g systemClockGen (fromList [3..5])__ +[(1,2),(1,3)(1,-4)] +@ + +-} + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +{-# LANGUAGE Unsafe #-} + +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} +{-# OPTIONS_HADDOCK show-extensions #-} + +-- See: https://github.com/clash-lang/clash-compiler/commit/721fcfa9198925661cd836668705f817bddaae3c +-- as to why we need this. +{-# OPTIONS_GHC -fno-cpr-anal #-} + +module Clash.Explicit.BlockRam.File + ( -- * BlockRAM synchronised to an arbitrary clock + blockRamFile + , blockRamFilePow2 + -- * Internal + , blockRamFile# + , initMem + ) +where + +import Data.Char (digitToInt) +import Data.Maybe (fromJust, isJust, listToMaybe) +import qualified Data.Vector as V +import GHC.Stack (HasCallStack, withFrozenCallStack) +import GHC.TypeLits (KnownNat) +import Numeric (readInt) +import System.IO.Unsafe (unsafePerformIO) + +import Clash.Promoted.Nat (SNat (..), pow2SNat) +import Clash.Sized.BitVector (BitVector) +import Clash.Signal.Internal (Clock, Signal (..), (.&&.), clockEnable) +import Clash.Signal.Bundle (unbundle) +import Clash.Sized.Unsigned (Unsigned) +import Clash.XException (errorX, seqX) + + +-- | Create a blockRAM with space for 2^@n@ elements +-- +-- * __NB__: Read value is delayed by 1 cycle +-- * __NB__: Initial output value is 'undefined' +-- * __NB__: This function might not work for specific combinations of +-- code-generation backends and hardware targets. Please check the support table +-- below: +-- +-- @ +-- | VHDL | Verilog | SystemVerilog | +-- ===============+==========+==========+===============+ +-- Altera/Quartus | Broken | Works | Works | +-- Xilinx/ISE | Works | Works | Works | +-- ASIC | Untested | Untested | Untested | +-- ===============+==========+==========+===============+ +-- @ +-- +-- Additional helpful information: +-- +-- * See "Clash.Prelude.BlockRam#usingrams" for more information on how to use a +-- Block RAM. +-- * Use the adapter 'readNew'' for obtaining write-before-read semantics like this: @readNew' clk (blockRamFilePow2' clk file) rd wrM@. +-- * See "Clash.Explicit.BlockRam.File#usingramfiles" for more information on how +-- to instantiate a Block RAM with the contents of a data file. +-- * See "Clash.Explicit.Fixed#creatingdatafiles" for ideas on how to create your +-- own data files. +blockRamFilePow2 + :: forall dom gated n m + . (KnownNat m, KnownNat n, HasCallStack) + => Clock dom gated + -- ^ 'Clock' to synchronize to + -> FilePath + -- ^ File describing the initial content of the blockRAM + -> Signal dom (Unsigned n) -- ^ Read address @r@ + -> Signal dom (Maybe (Unsigned n, BitVector m)) + -- ^ (write address @w@, value to write) + -> Signal dom (BitVector m) + -- ^ Value of the @blockRAM@ at address @r@ from the previous clock cycle +blockRamFilePow2 = \clk file rd wrM -> withFrozenCallStack + (blockRamFile clk (pow2SNat (SNat @ n)) file rd wrM) +{-# INLINE blockRamFilePow2 #-} + +-- | Create a blockRAM with space for @n@ elements +-- +-- * __NB__: Read value is delayed by 1 cycle +-- * __NB__: Initial output value is 'undefined' +-- * __NB__: This function might not work for specific combinations of +-- code-generation backends and hardware targets. Please check the support table +-- below: +-- +-- @ +-- | VHDL | Verilog | SystemVerilog | +-- ===============+==========+==========+===============+ +-- Altera/Quartus | Broken | Works | Works | +-- Xilinx/ISE | Works | Works | Works | +-- ASIC | Untested | Untested | Untested | +-- ===============+==========+==========+===============+ +-- @ +-- +-- Additional helpful information: +-- +-- * See "Clash.Explicit.BlockRam#usingrams" for more information on how to use a +-- Block RAM. +-- * Use the adapter 'readNew'' for obtaining write-before-read semantics like this: @readNew' clk (blockRamFile' clk size file) rd wrM@. +-- * See "Clash.Explicit.BlockRam.File#usingramfiles" for more information on how +-- to instantiate a Block RAM with the contents of a data file. +-- * See "Clash.Sized.Fixed#creatingdatafiles" for ideas on how to create your +-- own data files. +blockRamFile + :: (KnownNat m, Enum addr, HasCallStack) + => Clock dom gated + -- ^ 'Clock' to synchronize to + -> SNat n + -- ^ Size of the blockRAM + -> FilePath + -- ^ File describing the initial content of the blockRAM + -> Signal dom addr + -- ^ Read address @r@ + -> Signal dom (Maybe (addr, BitVector m)) + -- ^ (write address @w@, value to write) + -> Signal dom (BitVector m) + -- ^ Value of the @blockRAM@ at address @r@ from the previous + -- clock cycle +blockRamFile = \clk sz file rd wrM -> + let en = isJust <$> wrM + (wr,din) = unbundle (fromJust <$> wrM) + in withFrozenCallStack + (blockRamFile# clk sz file (fromEnum <$> rd) en (fromEnum <$> wr) din) +{-# INLINE blockRamFile #-} + +-- | blockRamFile primitive +blockRamFile# + :: (KnownNat m, HasCallStack) + => Clock dom gated + -- ^ 'Clock' to synchronize to + -> SNat n + -- ^ Size of the blockRAM + -> FilePath + -- ^ File describing the initial content of the blockRAM + -> Signal dom Int + -- ^ Read address @r@ + -> Signal dom Bool + -- ^ Write enable + -> Signal dom Int + -- ^ Write address @w@ + -> Signal dom (BitVector m) + -- ^ Value to write (at address @w@) + -> Signal dom (BitVector m) + -- ^ Value of the @blockRAM@ at address @r@ from the previous clock cycle +blockRamFile# clk _sz file rd wen = case clockEnable clk of + Nothing -> + go ramI + (withFrozenCallStack (errorX "blockRamFile#: intial value undefined")) + rd wen + Just ena -> + go' ramI + (withFrozenCallStack (errorX "blockRamFile#: intial value undefined")) + ena rd (wen .&&. ena) + where + -- no clock enable + go !ram o (r :- rs) (e :- en) (w :- wr) (d :- din) = + let ram' = upd ram e w d + o' = ram V.! r + in o `seqX` o :- go ram' o' rs en wr din + -- clock enable + go' !ram o (re :- res) (r :- rs) (e :- en) (w :- wr) (d :- din) = + let ram' = upd ram e w d + o' = if re then ram V.! r else o + in o `seqX` o :- go' ram' o' res rs en wr din + + upd ram True addr d = ram V.// [(addr,d)] + upd ram False _ _ = ram + + content = unsafePerformIO (initMem file) + ramI = V.fromList content +{-# NOINLINE blockRamFile# #-} + +-- | __NB:__ Not synthesisable +initMem :: KnownNat n => FilePath -> IO [BitVector n] +initMem = fmap (map parseBV . lines) . readFile + where + parseBV s = case parseBV' s of + Just i -> fromInteger i + Nothing -> error ("Failed to parse: " ++ s) + parseBV' = fmap fst . listToMaybe . readInt 2 (`elem` "01") digitToInt +{-# NOINLINE initMem #-} diff --git a/src/Clash/Explicit/DDR.hs b/src/Clash/Explicit/DDR.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Explicit/DDR.hs @@ -0,0 +1,161 @@ +{-| +Copyright : (C) 2017, Google Inc +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij + +We simulate DDR signal by using 'Signal's which have exactly half the period +(or double the speed) of our normal 'Signal's. + +The primives in this module can be used to produce of consume DDR signals. + +DDR signals are not meant to be used internally in a design, +but only to communicate with the outside world. + +In some cases hardware specific DDR IN registers can be infered by synthesis tools +from these generic primitives. But to be sure your design will synthesize to +dedicated hardware resources use the functions from "Clash.Intel.DDR" +or "Clash.Xilinx.DDR". +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Clash.Explicit.DDR + ( ddrIn + , ddrOut + -- * Internal + , ddrIn# + , ddrOut# + ) +where + +import GHC.Stack (HasCallStack, withFrozenCallStack) + +import Clash.Explicit.Prelude +import Clash.Signal.Internal + + +-- | DDR input primitive +-- +-- Consumes a DDR input signal and produces a regular signal containing a pair +-- of values. +ddrIn + :: ( HasCallStack + , fast ~ 'Dom n pFast + , slow ~ 'Dom n (2*pFast)) + => Clock slow gated + -- ^ clock + -> Reset slow synchronous + -- ^ reset + -> (a, a, a) + -- ^ reset values + -> Signal fast a + -- ^ DDR input signal + -> Signal slow (a,a) + -- ^ normal speed output pairs +ddrIn clk rst (i0,i1,i2) = withFrozenCallStack $ ddrIn# clk rst i0 i1 i2 + + +-- For details about all the seq's en seqX's +-- see the [Note: register strictness annotations] in Clash.Signal.Internal +ddrIn# + :: forall a slow fast n pFast gated synchronous + . ( HasCallStack + , fast ~ 'Dom n pFast + , slow ~ 'Dom n (2*pFast)) + => Clock slow gated + -> Reset slow synchronous + -> a + -> a + -> a + -> Signal fast a + -> Signal slow (a,a) +ddrIn# (Clock {}) (Sync rst) i0 i1 i2 = + go ((errorX "ddrIn: initial value 0 undefined") + ,(errorX "ddrIn: initial value 1 undefined") + ,(errorX "ddrIn: initial value 2 undefined")) + rst + where + go :: (a,a,a) -> Signal slow Bool -> Signal fast a -> Signal slow (a,a) + go (o0,o1,o2) rt@(~(r :- rs)) as@(~(x0 :- x1 :- xs)) = + let (o0',o1',o2') = if r then (i0,i1,i2) else (o2,x0,x1) + in o0 `seqX` o1 `seqX` (o0,o1) :- (rt `seq` as `seq` go (o0',o1',o2') rs xs) + +ddrIn# (Clock {}) (Async rst) i0 i1 i2 = + go ((errorX "ddrIn: initial value 0 undefined") + ,(errorX "ddrIn: initial value 1 undefined") + ,(errorX "ddrIn: initial value 2 undefined")) + rst + where + go :: (a,a,a) -> Signal slow Bool -> Signal fast a -> Signal slow (a,a) + go (o0,o1,o2) ~(r :- rs) as@(~(x0 :- x1 :- xs)) = + let (o0',o1',o2') = if r then (i0,i1,i2) else (o0,o1,o2) + in o0' `seqX` o1' `seqX`(o0',o1') :- (as `seq` go (o2',x0,x1) rs xs) + +ddrIn# (GatedClock _ _ ena) (Sync rst) i0 i1 i2 = + go ((errorX "ddrIn: initial value 0 undefined") + ,(errorX "ddrIn: initial value 1 undefined") + ,(errorX "ddrIn: initial value 2 undefined")) + rst + ena + where + go :: (a,a,a) -> Signal slow Bool -> Signal slow Bool -> Signal fast a -> Signal slow (a,a) + go (o0,o1,o2) rt@(~(r :- rs)) ~(e :- es) as@(~(x0 :- x1 :- xs)) = + let (o0',o1',o2') = if r then (i0,i1,i2) else (o2,x0,x1) + in o0 `seqX` o1 `seqX` (o0,o1) + :- (rt `seq` as `seq` if e then go (o0',o1',o2') rs es xs + else go (o0 ,o1 ,o2) rs es xs) + +ddrIn# (GatedClock _ _ ena) (Async rst) i0 i1 i2 = + go ((errorX "ddrIn: initial value 0 undefined") + ,(errorX "ddrIn: initial value 1 undefined") + ,(errorX "ddrIn: initial value 2 undefined")) + rst + ena + where + go :: (a,a,a) -> Signal slow Bool -> Signal slow Bool -> Signal fast a -> Signal slow (a,a) + go (o0,o1,o2) ~(r :- rs) ~(e :- es) as@(~(x0 :- x1 :- xs)) = + let (o0',o1',o2') = if r then (i0,i1,i2) else (o0,o1,o2) + in o0' `seqX` o1' `seqX` (o0',o1') + :- (as `seq` if e then go (o2',x0 ,x1) rs es xs + else go (o0',o1',o2') rs es xs) +{-# NOINLINE ddrIn# #-} + +-- | DDR output primitive +-- +-- Produces a DDR output signal from a normal signal of pairs of input. +ddrOut :: ( HasCallStack + , fast ~ 'Dom n pFast + , slow ~ 'Dom n (2*pFast)) + => Clock slow gated -- ^ clock + -> Reset slow synchronous -- ^ reset + -> a -- ^ reset value + -> Signal slow (a,a) -- ^ normal speed input pairs + -> Signal fast a -- ^ DDR output signal +ddrOut clk rst i0 = uncurry (withFrozenCallStack $ ddrOut# clk rst i0) . unbundle + + +ddrOut# :: ( HasCallStack + , fast ~ 'Dom n pFast + , slow ~ 'Dom n (2*pFast)) + => Clock slow gated + -> Reset slow synchronous + -> a + -> Signal slow a + -> Signal slow a + -> Signal fast a +ddrOut# clk rst i0 xs ys = + -- We only observe one reset value, because when the mux switches on the + -- next clock level, the second register will already be outputting its + -- first input. + -- + -- That is why we drop the first value of the stream. + let (_ :- out) = zipSig xs' ys' in out + where + xs' = register clk rst i0 xs + ys' = register clk rst i0 ys + zipSig (a :- as) (b :- bs) = a :- b :- zipSig as bs +{-# NOINLINE ddrOut# #-} diff --git a/src/Clash/Explicit/Mealy.hs b/src/Clash/Explicit/Mealy.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Explicit/Mealy.hs @@ -0,0 +1,128 @@ +{-| + Copyright : (C) 2013-2016, University of Twente, + 2017 , Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Whereas the output of a Moore machine depends on the /previous state/, the + output of a Mealy machine depends on /current transition/. + + Mealy machines are strictly more expressive, but may impose stricter timing + requirements. +-} + +{-# LANGUAGE Safe #-} + +module Clash.Explicit.Mealy + ( -- * Mealy machines with explicit clock and reset ports + mealy + , mealyB + ) +where + +import Clash.Explicit.Signal (Bundle (..), Clock, Reset, Signal, register) + +{- $setup +>>> :set -XDataKinds -XTypeApplications +>>> import Clash.Explicit.Prelude +>>> import qualified Data.List as L +>>> :{ +let macT s (x,y) = (s',s) + where + s' = x * y + s +:} + +>>> let mac clk rst = mealy clk rst macT 0 +-} + +-- | Create a synchronous function from a combinational function describing +-- a mealy machine +-- +-- @ +-- import qualified Data.List as L +-- +-- macT +-- :: Int -- Current state +-- -> (Int,Int) -- Input +-- -> (Int,Int) -- (Updated state, output) +-- macT s (x,y) = (s',s) +-- where +-- s' = x * y + s +-- +-- mac +-- :: 'Clock' domain Source +-- -> 'Reset' domain Asynchronous +-- -> 'Signal' domain (Int, Int) +-- -> 'Signal' domain Int +-- mac clk rst = 'mealy' clk rst macT 0 +-- @ +-- +-- >>> simulate (mac systemClockGen systemResetGen) [(1,1),(2,2),(3,3),(4,4)] +-- [0,1,5,14... +-- ... +-- +-- Synchronous sequential functions can be composed just like their +-- combinational counterpart: +-- +-- @ +-- dualMac +-- :: 'Clock' domain gated -> 'Reset' domain synchronous +-- -> ('Signal' domain Int, 'Signal' domain Int) +-- -> ('Signal' domain Int, 'Signal' domain Int) +-- -> 'Signal' domain Int +-- dualMac clk rst (a,b) (x,y) = s1 + s2 +-- where +-- s1 = 'mealy' clk rst mac 0 ('bundle' (a,x)) +-- s2 = 'mealy' clk rst mac 0 ('bundle' (b,y)) +-- @ +mealy :: Clock dom gated -- ^ 'Clock' to synchronize to + -> Reset dom synchronous + -> (s -> i -> (s,o)) -- ^ Transfer function in mealy machine form: + -- @state -> input -> (newstate,output)@ + -> s -- ^ Initial state + -> (Signal dom i -> Signal dom o) + -- ^ Synchronous sequential function with input and output matching that + -- of the mealy machine +mealy clk rst f iS = + \i -> let (s',o) = unbundle $ f <$> s <*> i + s = register clk rst iS s' + in o +{-# INLINABLE mealy #-} + +-- | A version of 'mealy' that does automatic 'Bundle'ing +-- +-- Given a function @f@ of type: +-- +-- @ +-- __f__ :: Int -> (Bool,Int) -> (Int,(Int,Bool)) +-- @ +-- +-- When we want to make compositions of @f@ in @g@ using 'mealy'', we have to +-- write: +-- +-- @ +-- g clk rst a b c = (b1,b2,i2) +-- where +-- (i1,b1) = 'unbundle' (mealy clk rst f 0 ('bundle' (a,b))) +-- (i2,b2) = 'unbundle' (mealy clk rst f 3 ('bundle' (i1,c))) +-- @ +-- +-- Using 'mealyB'' however we can write: +-- +-- @ +-- g clk rst a b c = (b1,b2,i2) +-- where +-- (i1,b1) = 'mealyB' clk rst f 0 (a,b) +-- (i2,b2) = 'mealyB' clk rst f 3 (i1,c) +-- @ +mealyB :: (Bundle i, Bundle o) + => Clock dom gated + -> Reset dom synchronous + -> (s -> i -> (s,o)) -- ^ Transfer function in mealy machine form: + -- @state -> input -> (newstate,output)@ + -> s -- ^ Initial state + -> (Unbundled dom i -> Unbundled dom o) + -- ^ Synchronous sequential function with input and output matching that + -- of the mealy machine +mealyB clk rst f iS i = unbundle (mealy clk rst f iS (bundle i)) +{-# INLINE mealyB #-} diff --git a/src/Clash/Explicit/Moore.hs b/src/Clash/Explicit/Moore.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Explicit/Moore.hs @@ -0,0 +1,150 @@ +{-| + Copyright : (C) 2013-2016, University of Twente, + 2017 , Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Whereas the output of a Mealy machine depends on /current transition/, the + output of a Moore machine depends on the /previous state/. + + Moore machines are strictly less expressive, but may impose laxer timing + requirements. +-} + +{-# LANGUAGE Safe #-} + +module Clash.Explicit.Moore + ( -- * Moore machines with explicit clock and reset ports + moore + , mooreB + , medvedev + , medvedevB + ) +where + +import Clash.Explicit.Signal (Bundle (..), Clock, Reset, Signal, register) + +{- $setup +>>> :set -XDataKinds -XTypeApplications +>>> import Clash.Explicit.Prelude +>>> let macT s (x,y) = x * y + s +>>> let mac clk rst = moore clk rst macT id 0 +-} + +-- | Create a synchronous function from a combinational function describing +-- a moore machine +-- +-- @ +-- macT +-- :: Int -- Current state +-- -> (Int,Int) -- Input +-- -> (Int,Int) -- Updated state +-- macT s (x,y) = x * y + s +-- +-- mac +-- :: 'Clock' mac Source +-- -> 'Reset' mac Asynchronous +-- -> 'Signal' mac (Int, Int) +-- -> 'Signal' mac Int +-- mac clk rst = 'moore' clk rst macT id 0 +-- @ +-- +-- >>> simulate (mac systemClockGen systemResetGen) [(1,1),(2,2),(3,3),(4,4)] +-- [0,1,5,14... +-- ... +-- +-- Synchronous sequential functions can be composed just like their +-- combinational counterpart: +-- +-- @ +-- dualMac +-- :: Clock domain gated +-- -> Reset domain synchronous +-- -> ('Signal' domain Int, 'Signal' domain Int) +-- -> ('Signal' domain Int, 'Signal' domain Int) +-- -> 'Signal' domain Int +-- dualMac clk rst (a,b) (x,y) = s1 + s2 +-- where +-- s1 = 'moore' clk rst mac id 0 ('bundle' (a,x)) +-- s2 = 'moore' clk rst mac id 0 ('bundle' (b,y)) +-- @ +moore + :: Clock domain gated -- ^ 'Clock' to synchronize to + -> Reset domain synchronous + -> (s -> i -> s) -- ^ Transfer function in moore machine form: + -- @state -> input -> newstate@ + -> (s -> o) -- ^ Output function in moore machine form: + -- @state -> output@ + -> s -- ^ Initial state + -> (Signal domain i -> Signal domain o) + -- ^ Synchronous sequential function with input and output matching that + -- of the moore machine +moore clk rst ft fo iS = + \i -> let s' = ft <$> s <*> i + s = register clk rst iS s' + in fo <$> s +{-# INLINABLE moore #-} + +-- | Create a synchronous function from a combinational function describing +-- a moore machine without any output logic +medvedev + :: Clock domain gated + -> Reset domain synchronous + -> (s -> i -> s) + -> s + -> (Signal domain i -> Signal domain s) +medvedev clk rst tr st = moore clk rst tr id st +{-# INLINE medvedev #-} + +-- | A version of 'moore' that does automatic 'Bundle'ing +-- +-- Given a functions @t@ and @o@ of types: +-- +-- @ +-- __t__ :: Int -> (Bool, Int) -> Int +-- __o__ :: Int -> (Int, Bool) +-- @ +-- +-- When we want to make compositions of @t@ and @o@ in @g@ using 'moore'', we have to +-- write: +-- +-- @ +-- g clk rst a b c = (b1,b2,i2) +-- where +-- (i1,b1) = 'unbundle' (moore clk rst t o 0 ('bundle' (a,b))) +-- (i2,b2) = 'unbundle' (moore clk rst t o 3 ('bundle' (i1,c))) +-- @ +-- +-- Using 'mooreB'' however we can write: +-- +-- @ +-- g clk rst a b c = (b1,b2,i2) +-- where +-- (i1,b1) = 'mooreB' clk rst t o 0 (a,b) +-- (i2,b2) = 'mooreB' clk rst t o 3 (i1,c) +-- @ +mooreB + :: (Bundle i, Bundle o) + => Clock domain gated + -> Reset domain synchronous + -> (s -> i -> s) -- ^ Transfer function in moore machine form: + -- @state -> input -> newstate@ + -> (s -> o) -- ^ Output function in moore machine form: + -- @state -> output@ + -> s -- ^ Initial state + -> (Unbundled domain i -> Unbundled domain o) + -- ^ Synchronous sequential function with input and output matching that + -- of the moore machine +mooreB clk rst ft fo iS i = unbundle (moore clk rst ft fo iS (bundle i)) +{-# INLINE mooreB #-} + +-- | A version of 'medvedev' that does automatic 'Bundle'ing +medvedevB + :: (Bundle i, Bundle s) + => Clock domain gated + -> Reset domain synchronous + -> (s -> i -> s) + -> s + -> (Unbundled domain i -> Unbundled domain s) +medvedevB clk rst tr st = mooreB clk rst tr id st +{-# INLINE medvedevB #-} diff --git a/src/Clash/Explicit/Prelude.hs b/src/Clash/Explicit/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Explicit/Prelude.hs @@ -0,0 +1,217 @@ +{-| +Copyright : (C) 2013-2016, University of Twente, + 2017 , Google Inc. +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij + +This module defines the explicitly clocked counterparts of the functions +defined in "Clash.Prelude". Take a look at "Clash.Signal.Explicit" to see how +you can make multi-clock designs. +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeOperators #-} + +{-# LANGUAGE Unsafe #-} + +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} +{-# OPTIONS_HADDOCK show-extensions #-} + +module Clash.Explicit.Prelude + ( -- * Creating synchronous sequential circuits + mealy + , mealyB + , moore + , mooreB + , registerB + -- * Synchronizer circuits for safe clock domain crossings + , dualFlipFlopSynchronizer + , asyncFIFOSynchronizer + -- * ROMs + , asyncRom + , asyncRomPow2 + , rom + , romPow2 + -- ** ROMs initialised with a data file + , asyncRomFile + , asyncRomFilePow2 + , romFile + , romFilePow2 + -- * RAM primitives with a combinational read port + , asyncRam + , asyncRamPow2 + -- * BlockRAM primitives + , blockRam + , blockRamPow2 + -- ** BlockRAM primitives initialised with a data file + , blockRamFile + , blockRamFilePow2 + -- ** BlockRAM read/write conflict resolution + , readNew + -- * Utility functions + , window + , windowD + , isRising + , isFalling + -- * Testbench functions + , assert + , stimuliGenerator + , outputVerifier + -- * Exported modules + -- ** Synchronous signals + , module Clash.Explicit.Signal + , module Clash.Explicit.Signal.Delayed + -- ** DataFlow interface + , module Clash.Prelude.DataFlow + -- ** Datatypes + -- *** Bit vectors + , module Clash.Sized.BitVector + , module Clash.Prelude.BitIndex + , module Clash.Prelude.BitReduction + -- *** Arbitrary-width numbers + , module Clash.Sized.Signed + , module Clash.Sized.Unsigned + , module Clash.Sized.Index + -- *** Fixed point numbers + , module Clash.Sized.Fixed + -- *** Fixed size vectors + , module Clash.Sized.Vector + -- *** Perfect depth trees + , module Clash.Sized.RTree + -- ** Annotations + , module Clash.Annotations.TopEntity + -- ** Type-level natural numbers + , module GHC.TypeLits + , module GHC.TypeLits.Extra + , module Clash.Promoted.Nat + , module Clash.Promoted.Nat.Literals + , module Clash.Promoted.Nat.TH + , module Clash.Promoted.Symbol + -- ** Template Haskell + , Lift (..) + -- ** Type classes + -- *** Clash + , module Clash.Class.BitPack + , module Clash.Class.Num + , module Clash.Class.Resize + -- *** Other + , module Control.Applicative + , module Data.Bits + , module Data.Default + -- ** Exceptions + , module Clash.XException + , undefined + -- ** Named types + , module Clash.NamedTypes + -- ** Haskell Prelude + -- $hiding + , module Prelude + ) +where + +import Control.Applicative +import Data.Bits +import Data.Default +import GHC.TypeLits +import GHC.TypeLits.Extra +import Language.Haskell.TH.Syntax (Lift(..)) +import Prelude hiding + ((++), (!!), concat, drop, foldl, foldl1, foldr, foldr1, head, init, iterate, + last, length, map, repeat, replicate, reverse, scanl, scanr, splitAt, tail, + take, unzip, unzip3, zip, zip3, zipWith, zipWith3, undefined) + +import Clash.Annotations.TopEntity +import Clash.Class.BitPack +import Clash.Class.Num +import Clash.Class.Resize +import Clash.NamedTypes +import Clash.Explicit.BlockRam +import Clash.Explicit.BlockRam.File +import Clash.Explicit.Mealy +import Clash.Explicit.Moore +import Clash.Explicit.RAM +import Clash.Explicit.ROM +import Clash.Explicit.ROM.File +import Clash.Explicit.Prelude.Safe +import Clash.Explicit.Signal +import Clash.Explicit.Signal.Delayed +import Clash.Explicit.Synchronizer + (dualFlipFlopSynchronizer, asyncFIFOSynchronizer) +import Clash.Explicit.Testbench +import Clash.Prelude.BitIndex +import Clash.Prelude.BitReduction +import Clash.Prelude.DataFlow +import Clash.Prelude.ROM (asyncRom, asyncRomPow2) +import Clash.Prelude.ROM.File (asyncRomFile, asyncRomFilePow2) +import Clash.Promoted.Nat +import Clash.Promoted.Nat.TH +import Clash.Promoted.Nat.Literals +import Clash.Promoted.Symbol +import Clash.Sized.BitVector +import Clash.Sized.Fixed +import Clash.Sized.Index +import Clash.Sized.RTree +import Clash.Sized.Signed +import Clash.Sized.Unsigned +import Clash.Sized.Vector +import Clash.XException + +{- $setup +>>> :set -XDataKinds -XTypeApplications +>>> import Clash.Explicit.Prelude +>>> let window4 = window @3 +>>> let windowD3 = windowD @2 +-} + +-- | Give a window over a 'Signal' +-- +-- @ +-- window4 +--- :: Clock domain gated -> Reset domain synchronous +-- -> 'Signal' domain Int -> 'Vec' 4 ('Signal' domain Int) +-- window4 = 'window' +-- @ +-- +-- >>> simulateB (window4 systemClockGen systemResetGen) [1::Int,2,3,4,5] :: [Vec 4 Int] +-- [<1,0,0,0>,<2,1,0,0>,<3,2,1,0>,<4,3,2,1>,<5,4,3,2>... +-- ... +window + :: (KnownNat n, Default a) + => Clock domain gated + -- ^ Clock to which the incoming signal is synchronized + -> Reset domain synchronous + -> Signal domain a -- ^ Signal to create a window over + -> Vec (n + 1) (Signal domain a) -- ^ Window of at least size 1 +window clk rst x = res + where + res = x :> prev + prev = case natVal (asNatProxy prev) of + 0 -> repeat def + _ -> let next = x +>> prev + in registerB clk rst (repeat def) next +{-# INLINABLE window #-} + +-- | Give a delayed window over a 'Signal' +-- +-- @ +-- windowD3 :: Clock domain gated -> Reset domain synchronous +-- -> 'Signal' domain Int -> 'Vec' 3 ('Signal' domain Int) +-- windowD3 = 'windowD' +-- @ +-- +-- >>> simulateB (windowD3 systemClockGen systemResetGen) [1::Int,2,3,4] :: [Vec 3 Int] +-- [<0,0,0>,<1,0,0>,<2,1,0>,<3,2,1>,<4,3,2>... +-- ... +windowD + :: (KnownNat n, Default a) + => Clock domain gated + -- ^ Clock to which the incoming signal is synchronized + -> Reset domain synchronous + -> Signal domain a -- ^ Signal to create a window over + -> Vec (n + 1) (Signal domain a) -- ^ Window of at least size 1 +windowD clk rst x = + let prev = registerB clk rst (repeat def) next + next = x +>> prev + in prev +{-# INLINABLE windowD #-} diff --git a/src/Clash/Explicit/Prelude/Safe.hs b/src/Clash/Explicit/Prelude/Safe.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Explicit/Prelude/Safe.hs @@ -0,0 +1,236 @@ +{-| +Copyright : (C) 2013-2016, University of Twente, + 2017 , Myrtle Software Ltd, Google Inc. +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij + +__This is the API only of "Clash.Explicit.Prelude"__ + +This module defines the explicitly clocked counterparts of the functions +defined in "Clash.Prelude". Take a look at "Clash.Signal.Explicit" to see how +you can make multi-clock designs. +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# LANGUAGE Safe #-} + +{-# OPTIONS_HADDOCK show-extensions #-} + +module Clash.Explicit.Prelude.Safe + ( -- * Creating synchronous sequential circuits + mealy + , mealyB + , moore + , mooreB + , registerB + -- * Synchronizer circuits for safe clock domain crossing + , dualFlipFlopSynchronizer + , asyncFIFOSynchronizer + -- * ROMs + , asyncRom + , asyncRomPow2 + , rom + , romPow2 + -- * RAM primitives with a combinational read port + , asyncRam + , asyncRamPow2 + -- * BlockRAM primitives + , blockRam + , blockRamPow2 + -- ** BlockRAM read/write conflict resolution + , readNew + -- * Utility functions + , isRising + , isFalling + , riseEvery + , oscillate + -- * Exported modules + -- ** Synchronous signals + , module Clash.Explicit.Signal + , module Clash.Explicit.Signal.Delayed + -- ** DataFlow interface + , module Clash.Prelude.DataFlow + -- ** Datatypes + -- *** Bit vectors + , module Clash.Sized.BitVector + , module Clash.Prelude.BitIndex + , module Clash.Prelude.BitReduction + -- *** Arbitrary-width numbers + , module Clash.Sized.Signed + , module Clash.Sized.Unsigned + , module Clash.Sized.Index + -- *** Fixed point numbers + , module Clash.Sized.Fixed + -- *** Fixed size vectors + , module Clash.Sized.Vector + -- *** Perfect depth trees + , module Clash.Sized.RTree + -- ** Annotations + , module Clash.Annotations.TopEntity + -- ** Type-level natural numbers + , module GHC.TypeLits + , module GHC.TypeLits.Extra + , module Clash.Promoted.Nat + , module Clash.Promoted.Nat.Literals + , module Clash.Promoted.Nat.TH + , module Clash.Promoted.Symbol + -- ** Type classes + -- *** Clash + , module Clash.Class.BitPack + , module Clash.Class.Num + , module Clash.Class.Resize + -- *** Other + , module Control.Applicative + , module Data.Bits + -- ** Exceptions + , module Clash.XException + , undefined + -- ** Named types + , module Clash.NamedTypes + -- ** Haskell Prelude + -- $hiding + , module Prelude + ) +where + +import Control.Applicative +import Data.Bits +import GHC.Stack +import GHC.TypeLits +import GHC.TypeLits.Extra +import Prelude hiding + ((++), (!!), concat, drop, foldl, foldl1, foldr, foldr1, head, init, iterate, + last, length, map, repeat, replicate, reverse, scanl, scanr, splitAt, tail, + take, unzip, unzip3, zip, zip3, zipWith, zipWith3, undefined) + +import Clash.Annotations.TopEntity +import Clash.Class.BitPack +import Clash.Class.Num +import Clash.Class.Resize +import Clash.NamedTypes + +import Clash.Explicit.BlockRam +import Clash.Explicit.Mealy +import Clash.Explicit.Moore +import Clash.Explicit.RAM +import Clash.Explicit.ROM +import Clash.Explicit.Signal +import Clash.Explicit.Signal.Delayed +import Clash.Explicit.Synchronizer + (dualFlipFlopSynchronizer, asyncFIFOSynchronizer) +import Clash.Prelude.BitIndex +import Clash.Prelude.BitReduction +import Clash.Prelude.DataFlow +import Clash.Prelude.ROM (asyncRom, asyncRomPow2) +import Clash.Promoted.Nat +import Clash.Promoted.Nat.TH +import Clash.Promoted.Nat.Literals +import Clash.Promoted.Symbol +import Clash.Sized.BitVector +import Clash.Sized.Fixed +import Clash.Sized.Index +import Clash.Sized.RTree +import Clash.Sized.Signed +import Clash.Sized.Unsigned +import Clash.Sized.Vector +import Clash.XException + +{- $setup +>>> :set -XDataKinds +>>> import Clash.Explicit.Prelude +>>> let rP clk rst = registerB clk rst (8::Int,8::Int) +-} + + +-- | Create a 'register' function for product-type like signals (e.g. +-- @('Signal' a, 'Signal' b)@) +-- +-- @ +-- rP :: Clock domain gated -> Reset domain synchronous +-- -> ('Signal' domain Int, 'Signal' domain Int) +-- -> ('Signal' domain Int, 'Signal' domain Int) +-- rP clk rst = 'registerB' clk rst (8,8) +-- @ +-- +-- >>> simulateB (rP systemClockGen systemResetGen) [(1,1),(2,2),(3,3)] :: [(Int,Int)] +-- [(8,8),(1,1),(2,2),(3,3)... +-- ... +registerB + :: Bundle a + => Clock domain gated + -> Reset domain synchronous + -> a + -> Unbundled domain a + -> Unbundled domain a +registerB clk rst i = unbundle Prelude.. register clk rst i Prelude.. bundle +{-# INLINE registerB #-} + +-- | Give a pulse when the 'Signal' goes from 'minBound' to 'maxBound' +isRising + :: (Bounded a, Eq a) + => Clock domain gated + -> Reset domain synchronous + -> a -- ^ Starting value + -> Signal domain a + -> Signal domain Bool +isRising clk rst is s = liftA2 edgeDetect prev s + where + prev = register clk rst is s + edgeDetect old new = old == minBound && new == maxBound +{-# INLINABLE isRising #-} + +-- | Give a pulse when the 'Signal' goes from 'maxBound' to 'minBound' +isFalling + :: (Bounded a, Eq a) + => Clock domain gated + -> Reset domain synchronous + -> a -- ^ Starting value + -> Signal domain a + -> Signal domain Bool +isFalling clk rst is s = liftA2 edgeDetect prev s + where + prev = register clk rst is s + edgeDetect old new = old == maxBound && new == minBound +{-# INLINABLE isFalling #-} + +-- | Give a pulse every @n@ clock cycles. This is a useful helper function when +-- combined with functions like @'Clash.Explicit.Signal.regEn'@ or +-- @'Clash.Explicit.Signal.mux'@, in order to delay a register by a known amount. +riseEvery + :: forall domain gated synchronous n + . Clock domain gated + -> Reset domain synchronous + -> SNat n + -> Signal domain Bool +riseEvery clk rst SNat = moore clk rst transfer output 0 (pure ()) + where + output :: Index n -> Bool + output = (== maxBound) + + transfer :: Index n -> () -> Index n + transfer s _ = if (s == maxBound) then 0 else s+1 +{-# INLINEABLE riseEvery #-} + +-- | Oscillate a @'Bool'@ for a given number of cycles, given the starting state. +oscillate + :: forall domain gated synchronous n + . Clock domain gated + -> Reset domain synchronous + -> Bool + -> SNat n + -> Signal domain Bool +oscillate clk rst begin SNat = moore clk rst transfer snd (0, begin) (pure ()) + where + transfer :: (Index n, Bool) -> () -> (Index n, Bool) + transfer (s, i) _ = + if s == maxBound + then (0, not i) -- reset state and oscillate output + else (s+1, i) -- hold current output +{-# INLINEABLE oscillate #-} + +undefined :: HasCallStack => a +undefined = errorX "undefined" diff --git a/src/Clash/Explicit/RAM.hs b/src/Clash/Explicit/RAM.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Explicit/RAM.hs @@ -0,0 +1,137 @@ +{-| +Copyright : (C) 2015-2016, University of Twente, + 2017 , Myrtle Software Ltd, Google Inc. +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij + +RAM primitives with a combinational read port. +-} + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +{-# LANGUAGE Trustworthy #-} + +-- See: https://github.com/clash-lang/clash-compiler/commit/721fcfa9198925661cd836668705f817bddaae3c +-- as to why we need this. +{-# OPTIONS_GHC -fno-cpr-anal #-} + +{-# OPTIONS_HADDOCK show-extensions #-} + +module Clash.Explicit.RAM + ( -- * RAM synchronised to an arbitrary clock + asyncRam + , asyncRamPow2 + -- * Internal + , asyncRam# + ) +where + +import Data.Maybe (fromJust, isJust) +import GHC.Stack (HasCallStack, withFrozenCallStack) +import GHC.TypeLits (KnownNat) +import qualified Data.Vector as V + +import Clash.Explicit.Signal ((.&&.), unbundle, unsafeSynchronizer) +import Clash.Promoted.Nat (SNat (..), snatToNum, pow2SNat) +import Clash.Signal.Internal (Clock (..), Signal (..), clockEnable) +import Clash.Sized.Unsigned (Unsigned) +import Clash.XException (errorX) + +-- | Create a RAM with space for 2^@n@ elements +-- +-- * __NB__: Initial content of the RAM is 'undefined' +-- +-- Additional helpful information: +-- +-- * See "Clash.Prelude.BlockRam#usingrams" for more information on how to use a +-- RAM. +asyncRamPow2 + :: forall wdom rdom wgated rgated n a + . (KnownNat n, HasCallStack) + => Clock wdom wgated + -- ^ 'Clock' to which to synchronise the write port of the RAM + -> Clock rdom rgated + -- ^ 'Clock' to which the read address signal, @r@, is synchronised + -> Signal rdom (Unsigned n) + -- ^ Read address @r@ + -> Signal wdom (Maybe (Unsigned n, a)) + -- ^ (write address @w@, value to write) + -> Signal rdom a + -- ^ Value of the @RAM@ at address @r@ +asyncRamPow2 = \wclk rclk rd wrM -> withFrozenCallStack + (asyncRam wclk rclk (pow2SNat (SNat @ n)) rd wrM) +{-# INLINE asyncRamPow2 #-} + + +-- | Create a RAM with space for @n@ elements +-- +-- * __NB__: Initial content of the RAM is 'undefined' +-- +-- Additional helpful information: +-- +-- * See "Clash.Explicit.BlockRam#usingrams" for more information on how to use a +-- RAM. +asyncRam + :: (Enum addr, HasCallStack) + => Clock wdom wgated + -- ^ 'Clock' to which to synchronise the write port of the RAM + -> Clock rdom rgated + -- ^ 'Clock' to which the read address signal, @r@, is synchronised + -> SNat n + -- ^ Size @n@ of the RAM + -> Signal rdom addr + -- ^ Read address @r@ + -> Signal wdom (Maybe (addr, a)) + -- ^ (write address @w@, value to write) + -> Signal rdom a + -- ^ Value of the @RAM@ at address @r@ +asyncRam = \wclk rclk sz rd wrM -> + let en = isJust <$> wrM + (wr,din) = unbundle (fromJust <$> wrM) + in withFrozenCallStack + (asyncRam# wclk rclk sz (fromEnum <$> rd) en (fromEnum <$> wr) din) +{-# INLINE asyncRam #-} + +-- | RAM primitive +asyncRam# + :: HasCallStack + => Clock wdom wgated + -- ^ 'Clock' to which to synchronise the write port of the RAM + -> Clock rdom rgated + -- ^ 'Clock' to which the read address signal, @r@, is synchronised + -> SNat n -- ^ Size @n@ of the RAM + -> Signal rdom Int -- ^ Read address @r@ + -> Signal wdom Bool -- ^ Write enable + -> Signal wdom Int -- ^ Write address @w@ + -> Signal wdom a -- ^ Value to write (at address @w@) + -> Signal rdom a -- ^ Value of the @RAM@ at address @r@ +asyncRam# wclk rclk sz rd en wr din = + unsafeSynchronizer wclk rclk dout + where + rd' = unsafeSynchronizer rclk wclk rd + ramI = V.replicate + (snatToNum sz) + (withFrozenCallStack (errorX "asyncRam#: initial value undefined")) + en' = case clockEnable wclk of + Nothing -> en + Just wgt -> en .&&. wgt + dout = go ramI rd' en' wr din + + go :: V.Vector a -> Signal wdom Int -> Signal wdom Bool + -> Signal wdom Int -> Signal wdom a -> Signal wdom a + go !ram (r :- rs) (e :- es) (w :- ws) (d :- ds) = + let ram' = upd ram e w d + o = ram V.! r + in o :- go ram' rs es ws ds + + upd ram True addr d = ram V.// [(addr,d)] + upd ram False _ _ = ram +{-# NOINLINE asyncRam# #-} diff --git a/src/Clash/Explicit/ROM.hs b/src/Clash/Explicit/ROM.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Explicit/ROM.hs @@ -0,0 +1,97 @@ +{-| +Copyright : (C) 2015-2016, University of Twente, + 2017 , Google Inc. +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij + +ROMs +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeOperators #-} + +{-# LANGUAGE Safe #-} + +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} +{-# OPTIONS_HADDOCK show-extensions #-} + +module Clash.Explicit.ROM + ( -- * Synchronous ROM synchronised to an arbitrary clock + rom + , romPow2 + -- * Internal + , rom# + ) +where + +import Data.Array ((!),listArray) +import GHC.TypeLits (KnownNat, type (^)) +import Prelude hiding (length) + +-- import Clash.Signal (Signal) +-- import Clash.Signal.Explicit (Signal', SClock, systemClockGen) +import Clash.Explicit.Signal (Clock, Signal, delay) + +import Clash.Sized.Unsigned (Unsigned) +-- import Clash.Signal.Explicit (register') +import Clash.Sized.Vector (Vec, length, toList) +-- import Clash.XException (errorX) + + +-- | A ROM with a synchronous read port, with space for 2^@n@ elements +-- +-- * __NB__: Read value is delayed by 1 cycle +-- * __NB__: Initial output value is 'undefined' +-- +-- Additional helpful information: +-- +-- * See "Clash.Sized.Fixed#creatingdatafiles" and "Clash.Explicit.BlockRam#usingrams" +-- for ideas on how to use ROMs and RAMs +romPow2 + :: KnownNat n + => Clock domain gated -- ^ 'Clock' to synchronize to + -> Vec (2^n) a -- ^ ROM content + -- + -- __NB:__ must be a constant + -> Signal domain (Unsigned n) -- ^ Read address @rd@ + -> Signal domain a -- ^ The value of the ROM at address @rd@ +romPow2 = rom +{-# INLINE romPow2 #-} + +-- | A ROM with a synchronous read port, with space for @n@ elements +-- +-- * __NB__: Read value is delayed by 1 cycle +-- * __NB__: Initial output value is 'undefined' +-- +-- Additional helpful information: +-- +-- * See "Clash.Sized.Fixed#creatingdatafiles" and "Clash.Explicit.BlockRam#usingrams" +-- for ideas on how to use ROMs and RAMs +rom + :: (KnownNat n, Enum addr) + => Clock domain gated -- ^ 'Clock' to synchronize to + -> Vec n a -- ^ ROM content + -- + -- __NB:__ must be a constant + -> Signal domain addr -- ^ Read address @rd@ + -> Signal domain a + -- ^ The value of the ROM at address @rd@ from the previous clock cycle +rom = \clk content rd -> rom# clk content (fromEnum <$> rd) +{-# INLINE rom #-} + +-- | ROM primitive +rom# + :: KnownNat n + => Clock domain gated -- ^ 'Clock' to synchronize to + -> Vec n a -- ^ ROM content + -- + -- __NB:__ must be a constant + -> Signal domain Int -- ^ Read address @rd@ + -> Signal domain a + -- ^ The value of the ROM at address @rd@ from the previous clock cycle +rom# clk content rd = delay clk ((arr !) <$> rd) + where + szI = length content + arr = listArray (0,szI-1) (toList content) +{-# NOINLINE rom# #-} diff --git a/src/Clash/Explicit/ROM/File.hs b/src/Clash/Explicit/ROM/File.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Explicit/ROM/File.hs @@ -0,0 +1,193 @@ +{-| +Copyright : (C) 2015-2016, University of Twente, + 2017 , Google Inc. +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij + += Initialising a ROM with a data file #usingromfiles# + +ROMs initialised with a data file. The BNF grammar for this data file is simple: + +@ +FILE = LINE+ +LINE = BIT+ +BIT = '0' + | '1' +@ + +Consecutive @LINE@s correspond to consecutive memory addresses starting at @0@. +For example, a data file @memory.bin@ containing the 9-bit unsigned number +@7@ to @13@ looks like: + +@ +000000111 +000001000 +000001001 +000001010 +000001011 +000001100 +000001101 +@ + +We can instantiate a synchronous ROM using the content of the above file like +so: + +@ +f + :: Clock domain gated + -> Signal domain (Unsigned 3) + -> Signal domain (Unsigned 9) +f clk rd = 'Clash.Class.BitPack.unpack' '<$>' 'romFile' clk d7 \"memory.bin\" rd +@ + +And see that it works as expected: + +@ +__>>> import qualified Data.List as L__ +__>>> L.tail $ sampleN 4 $ f systemClockGen (fromList [3..5])__ +[10,11,12] +@ + +However, we can also interpret the same data as a tuple of a 6-bit unsigned +number, and a 3-bit signed number: + +@ +g + :: Clock domain Source + -> Signal domain (Unsigned 3) + -> Signal domain (Unsigned 6,Signed 3) +g clk rd = 'Clash.Class.BitPack.unpack' '<$>' 'romFile' clk d7 \"memory.bin\" rd +@ + +And then we would see: + +@ +__>>> import qualified Data.List as L__ +__>>> L.tail $ sampleN 4 $ g systemClockGen (fromList [3..5])__ +[(1,2),(1,3)(1,-4)] +@ +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +{-# LANGUAGE Unsafe #-} + +{-# OPTIONS_HADDOCK show-extensions #-} + +module Clash.Explicit.ROM.File + ( -- * Synchronous ROM synchronised to an arbitrary clock + romFile + , romFilePow2 + -- * Internal + , romFile# + ) +where + +import Data.Array (listArray,(!)) +import GHC.TypeLits (KnownNat) +import System.IO.Unsafe (unsafePerformIO) +-- +import Clash.Explicit.BlockRam.File (initMem) +import Clash.Promoted.Nat (SNat (..), pow2SNat, snatToNum) +import Clash.Sized.BitVector (BitVector) +import Clash.Explicit.Signal (Clock, Signal, delay) +import Clash.Sized.Unsigned (Unsigned) + + +-- | A ROM with a synchronous read port, with space for 2^@n@ elements +-- +-- * __NB__: Read value is delayed by 1 cycle +-- * __NB__: Initial output value is 'undefined' +-- * __NB__: This function might not work for specific combinations of +-- code-generation backends and hardware targets. Please check the support table +-- below: +-- +-- @ +-- | VHDL | Verilog | SystemVerilog | +-- ===============+==========+==========+===============+ +-- Altera/Quartus | Broken | Works | Works | +-- Xilinx/ISE | Works | Works | Works | +-- ASIC | Untested | Untested | Untested | +-- ===============+==========+==========+===============+ +-- @ +-- +-- Additional helpful information: +-- +-- * See "Clash.Explicit.ROM.File#usingromfiles" for more information on how +-- to instantiate a ROM with the contents of a data file. +-- * See "Clash.Sized.Fixed#creatingdatafiles" for ideas on how to create your +-- own data files. +romFilePow2 + :: forall domain gated n m + . (KnownNat m, KnownNat n) + => Clock domain gated -- ^ 'Clock' to synchronize to + -> FilePath -- ^ File describing the content of + -- the ROM + -> Signal domain (Unsigned n) -- ^ Read address @rd@ + -> Signal domain (BitVector m) + -- ^ The value of the ROM at address @rd@ from the previous clock cycle +romFilePow2 = \clk -> romFile clk (pow2SNat (SNat @ n)) +{-# INLINE romFilePow2 #-} + +-- | A ROM with a synchronous read port, with space for @n@ elements +-- +-- * __NB__: Read value is delayed by 1 cycle +-- * __NB__: Initial output value is 'undefined' +-- * __NB__: This function might not work for specific combinations of +-- code-generation backends and hardware targets. Please check the support table +-- below: +-- +-- @ +-- | VHDL | Verilog | SystemVerilog | +-- ===============+==========+==========+===============+ +-- Altera/Quartus | Broken | Works | Works | +-- Xilinx/ISE | Works | Works | Works | +-- ASIC | Untested | Untested | Untested | +-- ===============+==========+==========+===============+ +-- @ +-- +-- Additional helpful information: +-- +-- * See "Clash.Explicit.ROM.File#usingromfiles" for more information on how +-- to instantiate a ROM with the contents of a data file. +-- * See "Clash.Sized.Fixed#creatingdatafiles" for ideas on how to create your +-- own data files. +romFile + :: (KnownNat m, Enum addr) + => Clock domain gated + -- ^ 'Clock' to synchronize to + -> SNat n + -- ^ Size of the ROM + -> FilePath + -- ^ File describing the content of the ROM + -> Signal domain addr + -- ^ Read address @rd@ + -> Signal domain (BitVector m) + -- ^ The value of the ROM at address @rd@ from the previous clock cycle +romFile = \clk sz file rd -> romFile# clk sz file (fromEnum <$> rd) +{-# INLINE romFile #-} + +-- | romFile primitive +romFile# + :: KnownNat m + => Clock domain gated + -- ^ 'Clock' to synchronize to + -> SNat n + -- ^ Size of the ROM + -> FilePath + -- ^ File describing the content of the ROM + -> Signal domain Int + -- ^ Read address @rd@ + -> Signal domain (BitVector m) + -- ^ The value of the ROM at address @rd@ from the previous clock cycle +romFile# clk sz file rd = delay clk ((content !) <$> rd) + where + mem = unsafePerformIO (initMem file) + content = listArray (0,szI-1) mem + szI = snatToNum sz +{-# NOINLINE romFile# #-} diff --git a/src/Clash/Explicit/Signal.hs b/src/Clash/Explicit/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Explicit/Signal.hs @@ -0,0 +1,588 @@ +{-| +Copyright : (C) 2013-2016, University of Twente, + 2016 , Myrtle Software, + 2017 , Google Inc. +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij + +CλaSH has synchronous 'Signal's in the form of: + +@ +'Signal' (domain :: 'Domain') a +@ + +Where /a/ is the type of the value of the 'Signal', for example /Int/ or /Bool/, +and /domain/ is the /clock-/ (and /reset-/) domain to which the memory elements +manipulating these 'Signal's belong. + +The type-parameter, /domain/, is of the kind 'Domain' which has types of the +following shape: + +@ +data Domain = Dom { domainName :: 'GHC.TypeLits.Symbol', clkPeriod :: 'GHC.TypeLits.Nat' } +@ + +Where /domainName/ is a type-level string ('GHC.TypeLits.Symbol') representing +the name of the /clock-/ (and /reset-/) domain, and /clkPeriod/ is a type-level +natural number ('GHC.TypeLits.Nat') representing the clock period (in __ps__) +of the clock lines in the /clock-domain/. + +* __NB__: \"Bad things\"™ happen when you actually use a clock period of @0@, +so do __not__ do that! +* __NB__: You should be judicious using a clock with period of @1@ as you can +never create a clock that goes any faster! + +=== Explicit clocks and resets, and meta-stability #metastability# + +When +using the mechanisms provided by the __clash-prelude__, then clocks and resets +are also implicitly unique. + +The protection against accidental + +offered by Clash's /domain/ annotation on 'Signal's is based on the uniqueness +of clocks and resets. But with explicit clock and reset lines, there are +ways to (accidentally) introduce situations that are prone to metastability. + +There are four different clock and reset lines: + +@ +'Reset' domain 'Synchronous' +'Reset' domain 'Asynchronous' +'Clock' domain 'Source' +'Clock' domain 'Gated' +@ + +We now go over the combinations over these clock and reset line combinations +and explain when they can potentially introduce situations prone to +meta-stability: + + * /Reset situation 1/: + + @ + f :: Reset domain Synchronous -> Reset domain Synchronous -> .. + f x y = .. + @ + + There are no problems here, because although /x/ and /y/ can have + different values, components to these reset lines are reset + /synchronously/, and there is no metastability situation. + + * /Reset situation 2/: + + @ + g :: Reset domain Asynchronous -> Reset domain Asynchronous -> .. + g x y = .. + @ + + This situation can be prone to metastability, because although /x/ and + /y/ belong to the same /domain/ according to their type, there is no + guarantee that they actually originate from the same source. This means + that one component can enter its reset state asynchronously to another + component, inducing metastability in the other component. + + * The Clash compiler will give a warning whenever a function has a + type-signature similar to the one above. + * This is the reason why `unsafeFromAsyncReset` is prefixed with the + word /unsafe/. + + * /Reset situation 3/: + + @ + h :: Reset domain Asynchronous -> Reset domain Synchronous -> .. + h x y = .. + @ + + Also this situation is prone to metastability, because again, one + component can enter its reset state asynchronously to the other, + inducing metastability in the other component. + + * The Clash compiler will give a warning whenever a function has a + type-signature similar to the one above. + * Although in a standalone context, converting between @'Reset' domain + 'Synchronous'@ and @'Signal' domain 'Bool'@ would be safe from a + metastability point of view, it is not when we're in a context where + there are also asynchronous resets. That is why 'unsafeToSyncReset' + is prefixed with the word /unsafe/. + + * /Clock situations 1, 2, and 3/: + + @ + k :: Clock domain Source -> Clock domain source -> .. + k x y = .. + + l :: Clock domain Source -> Clock domain Gated -> .. + l x y = .. + + m :: Clock domain Gated -> Clock domain Gated -> .. + m x y = .. + @ + + All the above situations are potentially prone to metastability, because + even though /x/ and /y/ belong to the same /domain/ according to their + type, there is no guarantee that they actually originate from the same + source. They could hence be connected to completely unrelated clock + sources, and components can then induce metastable states in others. + + * The Clash compiler will give a warning whenever a function has a + type-signature similar to one of the above three situations. +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} + +{-# LANGUAGE Trustworthy #-} + +{-# OPTIONS_HADDOCK show-extensions #-} + +module Clash.Explicit.Signal + ( -- * Synchronous signal + Signal, Domain (..), System + -- * Clock + , Clock, ClockKind (..) + , freqCalc + -- ** Synchronisation primitive + , unsafeSynchronizer + -- ** Clock gating + , clockGate + -- * Reset + , Reset, ResetKind (..) + , unsafeFromAsyncReset + , unsafeToAsyncReset + , fromSyncReset + , unsafeToSyncReset + , resetSynchronizer + -- * Basic circuit functions + , delay + , register + , regMaybe + , regEn + -- * Simulation and testbench functions + , clockGen + , tbClockGen + , asyncResetGen + , syncResetGen + , systemClockGen + , tbSystemClockGen + , systemResetGen + -- * Boolean connectives + , (.&&.), (.||.) + -- * Product/Signal isomorphism + , Bundle(..) + -- * Simulation functions (not synthesisable) + , simulate + , simulateB + -- ** lazy versions + , simulate_lazy + , simulateB_lazy + -- * List \<-\> Signal conversion (not synthesisable) + , sample + , sampleN + , fromList + -- ** lazy versions + , sample_lazy + , sampleN_lazy + , fromList_lazy + -- * QuickCheck combinators + , testFor + -- * Type classes + -- ** 'Eq'-like + , (.==.), (./=.) + -- ** 'Ord'-like + , (.<.), (.<=.), (.>=.), (.>.) + ) +where + +import Control.DeepSeq (NFData) +import Data.Maybe (isJust, fromJust) +import GHC.Stack (HasCallStack, withFrozenCallStack) + +import Clash.Signal.Internal +import Clash.Signal.Bundle (Bundle (..)) + +{- $setup +>>> :set -XDataKinds -XTypeApplications +>>> import Clash.Explicit.Prelude +>>> import qualified Data.List as L +>>> type Dom2 = Dom "dom" 2 +>>> type Dom7 = Dom "dom" 7 +>>> let clk2 = clockGen @Dom2 +>>> let clk7 = clockGen @Dom7 +>>> let oversampling clkA clkB = delay clkB . unsafeSynchronizer clkA clkB . delay clkA +>>> let almostId clkA clkB = delay clkB . unsafeSynchronizer clkA clkB . delay clkA . unsafeSynchronizer clkB clkA . delay clkB +>>> let oscillate clk rst = let s = register clk rst False (not <$> s) in s +>>> let count clk rst = let s = regEn clk rst 0 (oscillate clk rst) (s + 1) in s +>>> :{ +sometimes1 clk rst = s where + s = register clk rst Nothing (switch <$> s) + switch Nothing = Just 1 + switch _ = Nothing +:} + +>>> :{ +countSometimes clk rst = s where + s = regMaybe clk rst 0 (plusM (pure <$> s) (sometimes1 clk rst)) + plusM = liftA2 (liftA2 (+)) +:} + +-} + +-- **Clock + +-- | A /clock/ (and /reset/) domain with clocks running at 100 MHz +type System = 'Dom "system" 10000 + +-- | Clock generator for the 'System' clock domain. +-- +-- __NB__: should only be used for simulation, and __not__ for the /testBench/ +-- function. For the /testBench/ function, used 'tbSystemClockGen' +systemClockGen + :: Clock System 'Source +systemClockGen = clockGen + +-- | Clock generator for the 'System' clock domain. +-- +-- __NB__: can be used in the /testBench/ function +-- +-- === __Example__ +-- +-- @ +-- topEntity :: Vec 2 (Vec 3 (Unsigned 8)) -> Vec 6 (Unsigned 8) +-- topEntity = concat +-- +-- testBench :: Signal System Bool +-- testBench = done +-- where +-- testInput = pure ((1 :> 2 :> 3 :> Nil) :> (4 :> 5 :> 6 :> Nil) :> Nil) +-- expectedOutput = outputVerifier ((1:>2:>3:>4:>5:>6:>Nil):>Nil) +-- done = exposeClockReset (expectedOutput (topEntity <$> testInput)) clk rst +-- clk = 'tbSystemClockGen' (not <\$\> done) +-- rst = systemResetGen +-- @ +tbSystemClockGen + :: Signal System Bool + -> Clock System 'Source +tbSystemClockGen = tbClockGen + +-- | Reset generator for the 'System' clock domain. +-- +-- __NB__: should only be used for simulation or the \testBench\ function. +-- +-- === __Example__ +-- +-- @ +-- topEntity :: Vec 2 (Vec 3 (Unsigned 8)) -> Vec 6 (Unsigned 8) +-- topEntity = concat +-- +-- testBench :: Signal System Bool +-- testBench = done +-- where +-- testInput = pure ((1 :> 2 :> 3 :> Nil) :> (4 :> 5 :> 6 :> Nil) :> Nil) +-- expectedOutput = outputVerifier ((1:>2:>3:>4:>5:>6:>Nil):>Nil) +-- done = exposeClockReset (expectedOutput (topEntity <$> testInput)) clk rst +-- clk = tbSystemClockGen (not <\$\> done) +-- rst = 'systemResetGen' +-- @ +systemResetGen :: Reset System 'Asynchronous +systemResetGen = asyncResetGen + +-- | Normally, asynchronous resets can be both asynchronously asserted and +-- de-asserted. Asynchronous de-assertion can induce meta-stability in the +-- component which is being reset. To ensure this doesn't happen, +-- 'resetSynchronizer' ensures that de-assertion of a reset happens +-- synchronously. Assertion of the reset remains asynchronous. +-- +-- Note that asynchronous assertion does not induce meta-stability in the +-- component whose reset is asserted. However, when a component \"A\" in another +-- clock or reset domain depends on the value of a component \"B\" being +-- reset, then asynchronous assertion of the reset of component \"B"\ can induce +-- meta-stability in component \"A\". To prevent this from happening you need +-- to use a proper synchronizer, for example one of the synchronizers in +-- "Clash.Explicit.Synchronizer" +-- +-- __NB:__ Assumes the component(s) being reset have an /active-high/ reset port, +-- which all components in __clash-prelude__ have. +-- +-- === __Example__ +-- +-- @ +-- topEntity +-- :: Clock System Source +-- -> Reset System Asynchronous +-- -> Signal System Bit +-- -> Signal System (BitVector 8) +-- topEntity clk rst key1 = +-- let (pllOut,pllStable) = altpll (SSymbol @ "altpll50") clk rst +-- rstSync = 'resetSynchronizer' pllOut (unsafeToAsyncReset pllStable) +-- in exposeClockReset leds pllOut rstSync +-- where +-- key1R = isRising 1 key1 +-- leds = mealy blinkerT (1,False,0) key1R +-- @ +resetSynchronizer + :: Clock domain gated + -> Reset domain 'Asynchronous + -> Reset domain 'Asynchronous +resetSynchronizer clk rst = + let r1 = register clk rst True (pure False) + r2 = register clk rst True r1 + in unsafeToAsyncReset r2 + +-- | Calculate the period, in __ps__, given a frequency in __Hz__ +-- +-- i.e. to calculate the clock period for a circuit to run at 240 MHz we get +-- +-- >>> freqCalc 240e6 +-- 4167 +-- +-- __NB__: This function is /not/ synthesisable +freqCalc :: Double -> Integer +freqCalc freq = ceiling ((1.0 / freq) / 1.0e-12) + +-- ** Synchronisation primitive +{-# NOINLINE unsafeSynchronizer #-} +-- | The 'unsafeSynchronizer' function is a primitive that must be used to +-- connect one clock domain to the other, and will be synthesised to a (bundle +-- of) wire(s) in the eventual circuit. This function should only be used as +-- part of a proper synchronisation component, such as the following dual +-- flip-flop synchronizer: +-- +-- @ +-- dualFlipFlop :: Clock domA gatedA -> Clock domB gatedB +-- -> Signal domA Bit -> Signal domB Bit +-- dualFlipFlop clkA clkB = 'delay' clkB . 'delay' clkB +-- . 'unsafeSynchronizer' clkA clkB +-- @ +-- +-- The 'unsafeSynchronizer' works in such a way that, given 2 clocks: +-- +-- @ +-- type Dom7 = 'Dom' \"dom\" 7 +-- +-- clk7 :: 'Clock' Dom7 Source +-- clk7 = 'clockGen' +-- @ +-- +-- and +-- +-- @ +-- type Dom2 = 'Dom' \"dom\" 2 +-- +-- clk2 :: 'Clock' Dom2 Source +-- clk2 = 'clockGen' +-- @ +-- +-- Oversampling followed by compression is the identity function plus 2 initial +-- values: +-- +-- @ +-- 'delay' clkB $ +-- 'unsafeSynchronizer' clkA clkB $ +-- 'delay' clkA $ +-- 'unsafeSynchronizer' clkB clkA $ +-- 'delay' clkB s +-- +-- == +-- +-- X :- X :- s +-- @ +-- +-- Something we can easily observe: +-- +-- @ +-- oversampling clkA clkB = 'delay' clkB . 'unsafeSynchronizer' clkA clkB +-- . 'delay' clkA +-- almostId clkA clkB = 'delay' clkB . 'unsafeSynchronizer' clkA clkB +-- . 'delay' clkA . 'unsafeSynchronizer' clkB clkA +-- . 'delay' clkB +-- @ +-- +-- >>> printX (sampleN 37 (oversampling clk7 clk2 (fromList [(1::Int)..10]))) +-- [X,X,1,1,1,2,2,2,2,3,3,3,4,4,4,4,5,5,5,6,6,6,6,7,7,7,8,8,8,8,9,9,9,10,10,10,10] +-- >>> printX (sampleN 12 (almostId clk2 clk7 (fromList [(1::Int)..10]))) +-- [X,X,1,2,3,4,5,6,7,8,9,10] +unsafeSynchronizer + :: Clock domain1 gated1 -- ^ 'Clock' of the incoming signal + -> Clock domain2 gated2 -- ^ 'Clock' of the outgoing signal + -> Signal domain1 a + -> Signal domain2 a +unsafeSynchronizer clk1 clk2 s = s' + where + t1 = clockPeriod clk1 + t2 = clockPeriod clk2 + s' | t1 < t2 = compress t2 t1 s + | t1 > t2 = oversample t1 t2 s + | otherwise = same s + +same :: Signal domain1 a -> Signal domain2 a +same (s :- ss) = s :- same ss + +oversample :: Int -> Int -> Signal domain1 a -> Signal domain2 a +oversample high low (s :- ss) = s :- oversampleS (reverse (repSchedule high low)) ss + +oversampleS :: [Int] -> Signal domain1 a -> Signal domain2 a +oversampleS sched = oversample' sched + where + oversample' [] s = oversampleS sched s + oversample' (d:ds) (s:-ss) = prefixN d s (oversample' ds ss) + + prefixN 0 _ s = s + prefixN n x s = x :- prefixN (n-1) x s + +compress :: Int -> Int -> Signal domain1 a -> Signal domain2 a +compress high low s = compressS (repSchedule high low) s + +compressS :: [Int] -> Signal domain1 a -> Signal domain2 a +compressS sched = compress' sched + where + compress' [] s = compressS sched s + compress' (d:ds) ss@(s :- _) = s :- compress' ds (dropS d ss) + + dropS 0 s = s + dropS n (_ :- ss) = dropS (n-1) ss + +repSchedule :: Int -> Int -> [Int] +repSchedule high low = take low $ repSchedule' low high 1 + where + repSchedule' cnt th rep + | cnt < th = repSchedule' (cnt+low) th (rep + 1) + | otherwise = rep : repSchedule' (cnt + low) (th + high) 1 + +-- * Basic circuit functions + +-- | \"@'delay' clk s@\" delays the values in 'Signal' /s/ for once cycle, the +-- value at time 0 is /undefined/. +-- +-- >>> printX (sampleN 3 (delay systemClockGen (fromList [1,2,3,4]))) +-- [X,1,2] +delay + :: HasCallStack + => Clock domain gated + -- ^ Clock + -> Signal domain a + -> Signal domain a +delay = \clk i -> withFrozenCallStack (delay# clk i) +{-# INLINE delay #-} + +-- | \"@'register' clk rst i s@\" delays the values in 'Signal' /s/ for one +-- cycle, and sets the value to @i@ the moment the reset becomes 'False'. +-- +-- >>> sampleN 3 (register systemClockGen systemResetGen 8 (fromList [1,2,3,4])) +-- [8,1,2] +register + :: HasCallStack + => Clock domain gated + -- ^ clock + -> Reset domain synchronous + -- ^ Reset (active-high), 'register' outputs the reset value when the + -- reset value becomes 'True' + -> a + -- ^ Reset value + -> Signal domain a + -> Signal domain a +register = \clk rst initial i -> withFrozenCallStack + (register# clk rst initial i) +{-# INLINE register #-} + +-- | Version of 'register' that only updates its content when its fourth +-- argument is a 'Just' value. So given: +-- +-- @ +-- sometimes1 clk rst = s where +-- s = 'register' clk rst Nothing (switch '<$>' s) +-- +-- switch Nothing = Just 1 +-- switch _ = Nothing +-- +-- countSometimes clk rst = s where +-- s = 'regMaybe' clk rst 0 (plusM ('pure' '<$>' s) (sometimes1 clk rst)) +-- plusM = liftA2 (liftA2 (+)) +-- @ +-- +-- We get: +-- +-- >>> sampleN 8 (sometimes1 systemClockGen systemResetGen) +-- [Nothing,Just 1,Nothing,Just 1,Nothing,Just 1,Nothing,Just 1] +-- >>> sampleN 8 (count systemClockGen systemResetGen) +-- [0,0,1,1,2,2,3,3] +regMaybe + :: HasCallStack + => Clock domain gated + -- ^ Clock + -> Reset domain synchronous + -- ^ Reset (active-high), 'regMaybe' outputs the reset value when the + -- reset value becomes 'True' + -> a + -- ^ Reset value + -> Signal domain (Maybe a) + -> Signal domain a +regMaybe = \clk rst initial iM -> withFrozenCallStack + (register# (clockGate clk (fmap isJust iM)) rst initial (fmap fromJust iM)) +{-# INLINE regMaybe #-} + +-- | Version of 'register' that only updates its content when its fourth +-- argument is asserted. So given: +-- +-- @ +-- oscillate clk rst = let s = 'register' clk rst False (not \<$\> s) in s +-- count clk rst = let s = 'regEn clk rst 0 (oscillate clk rst) (s + 1) in s +-- @ +-- +-- We get: +-- +-- >>> sampleN 8 (oscillate systemClockGen systemResetGen) +-- [False,True,False,True,False,True,False,True] +-- >>> sampleN 8 (count systemClockGen systemResetGen) +-- [0,0,1,1,2,2,3,3] +regEn + :: Clock domain clk + -- ^ Clock + -> Reset domain synchronous + -- ^ Reset (active-high), 'regEn' outputs the reset value when the + -- reset value becomes 'True' + -> a + -- ^ Reset value + -> Signal domain Bool + -- ^ Enable signal + -> Signal domain a + -> Signal domain a +regEn = \clk rst initial en i -> withFrozenCallStack + (register# (clockGate clk en) rst initial i) +{-# INLINE regEn #-} + +-- * Product/Signal isomorphism + +-- | Simulate a (@'Unbundled' a -> 'Unbundled' b@) function given a list of +-- samples of type /a/ +-- +-- >>> simulateB (unbundle . register systemClockGen systemResetGen (8,8) . bundle) [(1,1), (2,2), (3,3)] :: [(Int,Int)] +-- [(8,8),(1,1),(2,2),(3,3)... +-- ... +-- +-- __NB__: This function is not synthesisable +simulateB + :: (Bundle a, Bundle b, NFData a, NFData b) + => (Unbundled domain1 a -> Unbundled domain2 b) + -- ^ The function we want to simulate + -> [a] + -- ^ Input samples + -> [b] +simulateB f = simulate (bundle . f . unbundle) + +-- | /Lazily/ simulate a (@'Unbundled' a -> 'Unbundled' b@) function given a +-- list of samples of type /a/ +-- +-- >>> simulateB (unbundle . register systemClockGen systemResetGen (8,8) . bundle) [(1,1), (2,2), (3,3)] :: [(Int,Int)] +-- [(8,8),(1,1),(2,2),(3,3)... +-- ... +-- +-- __NB__: This function is not synthesisable +simulateB_lazy + :: (Bundle a, Bundle b) + => (Unbundled domain1 a -> Unbundled domain2 b) + -- ^ The function we want to simulate + -> [a] + -- ^ Input samples + -> [b] +simulateB_lazy f = simulate_lazy (bundle . f . unbundle) diff --git a/src/Clash/Explicit/Signal/Delayed.hs b/src/Clash/Explicit/Signal/Delayed.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Explicit/Signal/Delayed.hs @@ -0,0 +1,209 @@ +{-| +Copyright : (C) 2013-2016, University of Twente, + 2017 , Google Inc. +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +{-# LANGUAGE Trustworthy #-} + +{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} +{-# OPTIONS_HADDOCK show-extensions #-} + +module Clash.Explicit.Signal.Delayed + ( -- * Delay-annotated synchronous signals + DSignal + , delayed + , delayedI + , feedback + -- * Signal \<-\> DSignal conversion + , fromSignal + , toSignal + -- * List \<-\> DSignal conversion (not synthesisable) + , dfromList + -- ** lazy versions + , dfromList_lazy + -- * Experimental + , unsafeFromSignal + , antiDelay + ) +where + +import Control.DeepSeq (NFData) +import Data.Coerce (coerce) +import Data.Default (Default(..)) +import GHC.TypeLits (KnownNat, Nat, type (+)) +import Language.Haskell.TH.Syntax (Lift) +import Prelude hiding (head, length, repeat) +import Test.QuickCheck (Arbitrary, CoArbitrary) + +import Clash.Promoted.Nat (SNat) +import Clash.Sized.Vector + (Vec, head, length, repeat, shiftInAt0, singleton) +import Clash.Explicit.Signal + (Clock, Domain, Reset, Signal, register, fromList, fromList_lazy, bundle, + unbundle) + +{- $setup +>>> :set -XDataKinds +>>> :set -XTypeOperators +>>> import Clash.Explicit.Prelude +>>> let delay3 clk rst = delayed clk rst (0 :> 0 :> 0 :> Nil) +>>> let delay2 clk rst = (delayedI clk rst :: DSignal System n Int -> DSignal System (n + 2) Int) +>>> :{ +let mac :: Clock System gated + -> Reset System synchronous + -> DSignal System 0 Int -> DSignal System 0 Int + -> DSignal System 0 Int + mac clk rst x y = feedback (mac' x y) + where + mac' :: DSignal System 0 Int -> DSignal System 0 Int + -> DSignal System 0 Int + -> (DSignal System 0 Int, DSignal System 1 Int) + mac' a b acc = let acc' = a * b + acc + in (acc, delayed clk rst (singleton 0) acc') +:} + +-} + +-- | A synchronized signal with samples of type @a@, synchronized to clock +-- @clk@, that has accumulated @delay@ amount of samples delay along its path. +newtype DSignal (domain :: Domain) (delay :: Nat) a = + DSignal { -- | Strip a 'DSignal' from its delay information. + toSignal :: Signal domain a + } + deriving (Show,Default,Functor,Applicative,Num,Fractional, + Foldable,Traversable,Arbitrary,CoArbitrary,Lift) + +-- | Create a 'DSignal' from a list +-- +-- Every element in the list will correspond to a value of the signal for one +-- clock cycle. +-- +-- >>> sampleN 2 (dfromList [1,2,3,4,5]) +-- [1,2] +-- +-- __NB__: This function is not synthesisable +dfromList :: NFData a => [a] -> DSignal domain 0 a +dfromList = coerce . fromList + +-- | Create a 'DSignal' from a list +-- +-- Every element in the list will correspond to a value of the signal for one +-- clock cycle. +-- +-- >>> sampleN 2 (dfromList [1,2,3,4,5]) +-- [1,2] +-- +-- __NB__: This function is not synthesisable +dfromList_lazy :: [a] -> DSignal domain 0 a +dfromList_lazy = coerce . fromList_lazy + +-- | Delay a 'DSignal' for @d@ periods. +-- +-- @ +-- delay3 :: Clock domain gated -> Reset domain synchronous +-- -> 'DSignal' domain n Int -> 'DSignal' domain (n + 3) Int +-- delay3 clk rst = 'delayed' clk rst (0 ':>' 0 ':>' 0 ':>' 'Nil') +-- @ +-- +-- >>> sampleN 6 (delay3 systemClockGen systemResetGen (dfromList [1..])) +-- [0,0,0,1,2,3] +delayed + :: forall domain gated synchronous a n d + . KnownNat d + => Clock domain gated + -> Reset domain synchronous + -> Vec d a + -> DSignal domain n a + -> DSignal domain (n + d) a +delayed clk rst m ds = coerce (delaySignal (coerce ds)) + where + delaySignal :: Signal domain a -> Signal domain a + delaySignal s = case length m of + 0 -> s + _ -> let (r',o) = shiftInAt0 (unbundle r) (singleton s) + r = register clk rst m (bundle r') + in head o + +-- | Delay a 'DSignal' for @m@ periods, where @m@ is derived from the +-- context. +-- +-- @ +-- delay2 :: Clock domain gated -> Reset domain synchronous +-- -> 'DSignal' domain n Int -> 'DSignal' domain (n + 2) Int +-- delay2 = 'delayI' +-- @ +-- +-- >>> sampleN 6 (delay2 systemClockGen systemResetGen (dfromList [1..])) +-- [0,0,1,2,3,4] +delayedI + :: (Default a, KnownNat d) + => Clock domain gated + -> Reset domain synchronous + -> DSignal domain n a + -> DSignal domain (n + d) a +delayedI clk rst = delayed clk rst (repeat def) + +-- | Feed the delayed result of a function back to its input: +-- +-- @ +-- mac :: Clock domain gated -> Reset domain synchronous +-- -> 'DSignal' domain 0 Int -> 'DSignal' domain 0 Int -> 'DSignal' domain 0 Int +-- mac clk rst x y = 'feedback' (mac' x y) +-- where +-- mac' :: 'DSignal' domain 0 Int -> 'DSignal' domain 0 Int -> 'DSignal' domain 0 Int +-- -> ('DSignal' domain 0 Int, 'DSignal' domain 1 Int) +-- mac' a b acc = let acc' = a * b + acc +-- in (acc, 'delay' clk rst ('singleton' 0) acc') +-- @ +-- +-- >>> sampleN 6 (mac systemClockGen systemResetGen (dfromList [1..]) (dfromList [1..])) +-- [0,1,5,14,30,55] +feedback + :: (DSignal domain n a -> (DSignal domain n a,DSignal domain (n + m + 1) a)) + -> DSignal domain n a +feedback f = let (o,r) = f (coerce r) in o + +-- | 'Signal's are not delayed +-- +-- > sample s == dsample (fromSignal s) +fromSignal :: Signal domain a -> DSignal domain 0 a +fromSignal = coerce + +-- | __EXPERIMENTAL__ +-- +-- __Unsafely__ convert a 'Signal' to /any/ 'DSignal' clk'. +-- +-- __NB__: Should only be used to interface with functions specified in terms of +-- 'Signal'. +unsafeFromSignal :: Signal domain a -> DSignal domain n a +unsafeFromSignal = DSignal + +-- | __EXPERIMENTAL__ +-- +-- Access a /delayed/ signal in the present. +-- +-- @ +-- mac :: Clock domain gated -> Reset domain synchronous +-- -> 'DSignal' domain 0 Int -> 'DSignal' domain 0 Int -> 'DSignal' domain 0 Int +-- mac clk rst x y = acc' +-- where +-- acc' = (x * y) + 'antiDelay' d1 acc +-- acc = 'delay' clk rst ('singleton' 0) acc' +-- @ +antiDelay :: SNat d -> DSignal domain (n + d) a -> DSignal domain n a +antiDelay _ = coerce diff --git a/src/Clash/Explicit/Synchronizer.hs b/src/Clash/Explicit/Synchronizer.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Explicit/Synchronizer.hs @@ -0,0 +1,193 @@ +{-| +Copyright : (C) 2015-2016, University of Twente, + 2016-2017, Myrtle Software Ltd, + 2017 , Google Inc. +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij + +Synchronizer circuits for safe clock domain crossings +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +#if !MIN_VERSION_constraints(0,9,0) +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE PolyKinds #-} +#endif + +#if MIN_VERSION_constraints(0,9,0) +{-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif + +{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} + +{-# OPTIONS_HADDOCK show-extensions #-} + +module Clash.Explicit.Synchronizer + ( -- * Bit-synchronizers + dualFlipFlopSynchronizer + -- * Word-synchronizers + , asyncFIFOSynchronizer + ) +where + +import Control.Applicative (liftA2) +import Data.Bits (complement, shiftR, xor) +import Data.Constraint ((:-)(..), Dict (..)) +#if MIN_VERSION_constraints(0,9,0) +import Data.Constraint.Nat (leTrans) +#else +import Unsafe.Coerce +#endif +import Data.Maybe (isJust) +import GHC.TypeLits (type (+), type (-), type (<=)) + +import Clash.Class.BitPack (boolToBV) +import Clash.Class.Resize (truncateB) +import Clash.Prelude.BitIndex (slice) +import Clash.Explicit.Mealy (mealyB) +import Clash.Explicit.RAM (asyncRam) +import Clash.Explicit.Signal + (Clock, Reset, Signal, register, unsafeSynchronizer) +import Clash.Promoted.Nat (SNat (..), pow2SNat) +import Clash.Promoted.Nat.Literals (d0) +import Clash.Signal (mux) +import Clash.Sized.BitVector (BitVector, (++#)) + +-- * Dual flip-flop synchronizer + +-- | Synchroniser based on two sequentially connected flip-flops. +-- +-- * __NB__: This synchroniser can be used for __bit__-synchronization. +-- +-- * __NB__: Although this synchroniser does reduce metastability, it does +-- not guarantee the proper synchronisation of a whole __word__. For +-- example, given that the output is sampled twice as fast as the input is +-- running, and we have two samples in the input stream that look like: +-- +-- @[0111,1000]@ +-- +-- But the circuit driving the input stream has a longer propagation delay +-- on __msb__ compared to the __lsb__s. What can happen is an output stream +-- that looks like this: +-- +-- @[0111,0111,0000,1000]@ +-- +-- Where the level-change of the __msb__ was not captured, but the level +-- change of the __lsb__s were. +-- +-- If you want to have /safe/ __word__-synchronisation use +-- 'asyncFIFOSynchronizer'. +dualFlipFlopSynchronizer + :: Clock domain1 gated1 + -- ^ 'Clock' to which the incoming data is synchronised + -> Clock domain2 gated2 + -- ^ 'Clock' to which the outgoing data is synchronised + -> Reset domain2 synchronous + -- ^ 'Reset' for registers on the outgoing domain + -> a + -- ^ Initial value of the two synchronisation registers + -> Signal domain1 a -- ^ Incoming data + -> Signal domain2 a -- ^ Outgoing, synchronised, data +dualFlipFlopSynchronizer clk1 clk2 rst i = + register clk2 rst i . register clk2 rst i . unsafeSynchronizer clk1 clk2 + +-- * Asynchronous FIFO synchronizer + +fifoMem + :: Clock wdomain wgated + -> Clock rdomain rgated + -> SNat addrSize + -> Signal wdomain Bool + -> Signal rdomain (BitVector addrSize) + -> Signal wdomain (Maybe (BitVector addrSize, a)) + -> Signal rdomain a +fifoMem wclk rclk addrSize@SNat full raddr writeM = + asyncRam wclk rclk + (pow2SNat addrSize) + raddr + (mux full (pure Nothing) writeM) + +ptrCompareT :: SNat addrSize + -> (BitVector (addrSize + 1) -> BitVector (addrSize + 1) -> Bool) + -> (BitVector (addrSize + 1), BitVector (addrSize + 1), Bool) + -> (BitVector (addrSize + 1), Bool) + -> ((BitVector (addrSize + 1), BitVector (addrSize + 1), Bool) + ,(Bool, BitVector addrSize, BitVector (addrSize + 1))) +ptrCompareT SNat flagGen (bin,ptr,flag) (s_ptr,inc) = ((bin',ptr',flag') + ,(flag,addr,ptr)) + where + -- GRAYSTYLE2 pointer + bin' = bin + boolToBV (inc && not flag) + ptr' = (bin' `shiftR` 1) `xor` bin' + addr = truncateB bin + + flag' = flagGen ptr' s_ptr + +-- FIFO full: when next pntr == synchonized {~wptr[addrSize:addrSize-1],wptr[addrSize-1:0]} +isFull :: forall addrSize . + (2 <= addrSize) + => SNat addrSize + -> BitVector (addrSize + 1) + -> BitVector (addrSize + 1) + -> Bool +isFull addrSize@SNat ptr s_ptr = case leTrans @1 @2 @addrSize of + Sub Dict -> + let a1 = SNat @(addrSize - 1) + a2 = SNat @(addrSize - 2) + in ptr == (complement (slice addrSize a1 s_ptr) ++# slice a2 d0 s_ptr) + +-- | Synchroniser implemented as a FIFO around an asynchronous RAM. Based on the +-- design described in "Clash.Tutorial#multiclock", which is itself based on the +-- design described in . +-- +-- __NB__: This synchroniser can be used for __word__-synchronization. +asyncFIFOSynchronizer + :: (2 <= addrSize) + => SNat addrSize + -- ^ Size of the internally used addresses, the FIFO contains @2^addrSize@ + -- elements. + -> Clock wdomain wgated + -- ^ 'Clock' to which the write port is synchronised + -> Clock rdomain rgated + -- ^ 'Clock' to which the read port is synchronised + -> Reset wdomain synchronous + -> Reset rdomain synchronous + -> Signal rdomain Bool + -- ^ Read request + -> Signal wdomain (Maybe a) + -- ^ Element to insert + -> (Signal rdomain a, Signal rdomain Bool, Signal wdomain Bool) + -- ^ (Oldest element in the FIFO, @empty@ flag, @full@ flag) +asyncFIFOSynchronizer addrSize@SNat wclk rclk wrst rrst rinc wdataM = + (rdata,rempty,wfull) + where + s_rptr = dualFlipFlopSynchronizer rclk wclk wrst 0 rptr + s_wptr = dualFlipFlopSynchronizer wclk rclk rrst 0 wptr + + rdata = fifoMem wclk rclk addrSize wfull raddr + (liftA2 (,) <$> (pure <$> waddr) <*> wdataM) + + (rempty,raddr,rptr) = mealyB rclk rrst (ptrCompareT addrSize (==)) (0,0,True) + (s_wptr,rinc) + + (wfull,waddr,wptr) = mealyB wclk wrst (ptrCompareT addrSize (isFull addrSize)) + (0,0,False) (s_rptr,isJust <$> wdataM) + +#if !MIN_VERSION_constraints(0,9,0) +axiom :: forall a b . Dict (a ~ b) +axiom = unsafeCoerce (Dict :: Dict (a ~ a)) + +axiomLe :: forall a b. Dict (a <= b) +axiomLe = axiom + +leTrans :: forall a b c. (b <= c, a <= b) :- (a <= c) +leTrans = Sub (axiomLe @a @c) +#endif diff --git a/src/Clash/Explicit/Testbench.hs b/src/Clash/Explicit/Testbench.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Explicit/Testbench.hs @@ -0,0 +1,171 @@ +{-| +Copyright : (C) 2013-2016, University of Twente, + 2017 , Google Inc. +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij +-} + +{-# LANGUAGE ScopedTypeVariables #-} + +{-# LANGUAGE Unsafe #-} + +{-# OPTIONS_HADDOCK show-extensions #-} + +module Clash.Explicit.Testbench + ( -- * Testbench functions for circuits + assert + , stimuliGenerator + , outputVerifier + ) +where + +import Control.Exception (catch, evaluate) +import Debug.Trace (trace) +import GHC.TypeLits (KnownNat) +import Prelude hiding ((!!), length) +import System.IO.Unsafe (unsafeDupablePerformIO) + +import Clash.Explicit.Signal + (Clock, Reset, Signal, fromList, register, unbundle) +import Clash.Sized.Index (Index) +import Clash.Sized.Vector (Vec, (!!), length) +import Clash.XException (ShowX (..), XException) + +{- $setup +>>> :set -XTemplateHaskell -XDataKinds +>>> import Clash.Explicit.Prelude +>>> let testInput clk rst = stimuliGenerator clk rst $(listToVecTH [(1::Int),3..21]) +>>> let expectedOutput clk rst = outputVerifier clk rst $(listToVecTH ([70,99,2,3,4,5,7,8,9,10]::[Int])) +-} + +-- | Compares the first two 'Signal's for equality and logs a warning when they +-- are not equal. The second 'Signal' is considered the expected value. This +-- function simply returns the third 'Signal'' unaltered as its result. This +-- function is used by 'outputVerifier'. +-- +-- +-- __NB__: This function /can/ be used in synthesizable designs. +assert + :: (Eq a,ShowX a) + => Clock domain gated + -> Reset domain synchronous + -> String -- ^ Additional message + -> Signal domain a -- ^ Checked value + -> Signal domain a -- ^ Expected value + -> Signal domain b -- ^ Return value + -> Signal domain b +assert clk _rst msg checked expected returned = + (\c e cnt r -> + if eqX c e + then r + else trace (concat [ "\ncycle(" ++ show clk ++ "): " + , show cnt + , ", " + , msg + , "\nexpected value: " + , showX e + , ", not equal to actual value: " + , showX c + ]) r) + <$> checked <*> expected <*> fromList [(0::Integer)..] <*> returned + where + eqX a b = unsafeDupablePerformIO (catch (evaluate (a == b)) + (\(_ :: XException) -> return False)) +{-# NOINLINE assert #-} + +-- | To be used as one of the functions to create the \"magical\" 'testInput' +-- value, which the CλaSH compiler looks for to create the stimulus generator +-- for the generated VHDL testbench. +-- +-- Example: +-- +-- @ +-- testInput +-- :: Clock domain gated -> Reset domain synchronous +-- -> 'Signal' domain Int +-- testInput clk rst = 'stimuliGenerator' clk rst $('Clash.Sized.Vector.listToVecTH' [(1::Int),3..21]) +-- @ +-- +-- >>> sampleN 13 (testInput systemClockGen systemResetGen) +-- [1,3,5,7,9,11,13,15,17,19,21,21,21] +stimuliGenerator + :: forall l domain gated synchronous a + . KnownNat l + => Clock domain gated + -- ^ Clock to which to synchronize the output signal + -> Reset domain synchronous + -> Vec l a -- ^ Samples to generate + -> Signal domain a -- ^ Signal of given samples +stimuliGenerator clk rst samples = + let (r,o) = unbundle (genT <$> register clk rst 0 r) + in o + where + genT :: Index l -> (Index l,a) + genT s = (s',samples !! s) + where + maxI = toEnum (length samples - 1) + + s' = if s < maxI + then s + 1 + else s +{-# INLINABLE stimuliGenerator #-} + +-- | To be used as one of the functions to generate the \"magical\" 'expectedOutput' +-- function, which the CλaSH compiler looks for to create the signal verifier +-- for the generated VHDL testbench. +-- +-- Example: +-- +-- @ +-- expectedOutput +-- :: Clock domain gated -> Reset domain synchronous +-- -> 'Signal' domain Int -> 'Signal' domain Bool +-- expectedOutput clk rst = 'outputVerifier' clk rst $('Clash.Sized.Vector.listToVecTH' ([70,99,2,3,4,5,7,8,9,10]::[Int])) +-- @ +-- +-- >>> import qualified Data.List as List +-- >>> sampleN 12 (expectedOutput systemClockGen systemResetGen (fromList ([0..10] List.++ [10,10,10]))) +-- +-- cycle(system10000): 0, outputVerifier +-- expected value: 70, not equal to actual value: 0 +-- [False +-- cycle(system10000): 1, outputVerifier +-- expected value: 99, not equal to actual value: 1 +-- ,False,False,False,False,False +-- cycle(system10000): 6, outputVerifier +-- expected value: 7, not equal to actual value: 6 +-- ,False +-- cycle(system10000): 7, outputVerifier +-- expected value: 8, not equal to actual value: 7 +-- ,False +-- cycle(system10000): 8, outputVerifier +-- expected value: 9, not equal to actual value: 8 +-- ,False +-- cycle(system10000): 9, outputVerifier +-- expected value: 10, not equal to actual value: 9 +-- ,False,True,True] +outputVerifier + :: forall l domain gated synchronous a + . (KnownNat l, Eq a, ShowX a) + => Clock domain gated + -- ^ Clock to which the input signal is synchronized to + -> Reset domain synchronous + -> Vec l a -- ^ Samples to compare with + -> Signal domain a -- ^ Signal to verify + -> Signal domain Bool -- ^ Indicator that all samples are verified +outputVerifier clk rst samples i = + let (s,o) = unbundle (genT <$> register clk rst 0 s) + (e,f) = unbundle o + in assert clk rst "outputVerifier" i e (register clk rst False f) + where + genT :: Index l -> (Index l,(a,Bool)) + genT s = (s',(samples !! s,finished)) + where + maxI = toEnum (length samples - 1) + + s' = if s < maxI + then s + 1 + else s + + finished = s == maxI +{-# INLINABLE outputVerifier #-} diff --git a/src/Clash/Hidden.hs b/src/Clash/Hidden.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Hidden.hs @@ -0,0 +1,100 @@ +{-| +Copyright : (C) 2018 , QBayLogic B.V. +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij + +Hidden arguments +-} + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +{-# LANGUAGE Trustworthy #-} + +module Clash.Hidden + ( Hidden + , expose + -- * OverloadedLabels + , fromLabel + ) +where + +import qualified GHC.Classes +import GHC.TypeLits +import Unsafe.Coerce + +-- | A value reflected to, or /hiding/ at, the /Constraint/ level +-- +-- e.g. a function: +-- +-- @ +-- f :: Hidden "foo" Int +-- => Bool +-- -> Int +-- f = ... +-- @ +-- +-- has a /normal/ argument of type @Bool@, and a /hidden/ argument called \"foo\" +-- of type @Int@. In order to apply the @Int@ argument we have to use the +-- 'expose' function, so that the /hidden/ argument becomes a normal argument +-- again. +-- +-- === __Original implementation__ +-- +-- 'Hidden' used to be implemented by: +-- +-- @ +-- class Hidden (x :: Symbol) a | x -> a where +-- hidden :: a +-- @ +-- +-- which is equivalent to /IP/, except that /IP/ has magic inference rules +-- bestowed by GHC so that there's never any ambiguity. We need these magic +-- inference rules so we don't end up in type inference absurdity where asking +-- for the type of an type-annotated value results in a /no-instance-in-scope/ +-- error. +type Hidden (x :: Symbol) a = GHC.Classes.IP x a + +newtype Secret x a r = Secret (Hidden x a => r) + +-- | Expose a 'Hidden' argument so that it can be applied normally, e.g. +-- +-- @ +-- f :: Hidden "foo" Int +-- => Bool +-- -> Int +-- f = ... +-- +-- g :: Int -> Bool -> Int +-- g = 'expose' \@\"foo" f +-- @ +expose + :: forall x a r + . (Hidden x a => r) + -- ^ Function with a 'Hidden' argument + -> (a -> r) + -- ^ Function with the 'Hidden' argument exposed +expose k = unsafeCoerce (Secret @x @a @r k) +{-# INLINE expose #-} + +-- | Using /-XOverloadedLabels/ and /-XRebindableSyntax/, we can turn any +-- value into a /hidden/ argument using the @#foo@ notation, e.g.: +-- +-- @ +-- f :: Int -> Bool -> Int +-- f = ... +-- +-- g :: Hidden "foo" Bool +-- => Int -> Int +-- g i = f i #foo +-- @ +fromLabel :: forall x a . Hidden x a => a +fromLabel = GHC.Classes.ip @x +{-# INLINE fromLabel #-} diff --git a/src/Clash/Intel/ClockGen.hs b/src/Clash/Intel/ClockGen.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Intel/ClockGen.hs @@ -0,0 +1,90 @@ +{-| +Copyright : (C) 2017, Google Inc +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij + +PLL and other clock-related components for Intel (Altera) FPGAs +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE GADTs #-} +module Clash.Intel.ClockGen where + +import Clash.Promoted.Symbol +import Clash.Signal.Internal +import Unsafe.Coerce + +-- | A clock source that corresponds to the Intel/Quartus \"ALTPLL\" component +-- with settings to provide a stable 'Clock' from a single free-running input +-- +-- Only works when configured with: +-- +-- * 1 reference clock +-- * 1 output clock +-- * a reset port +-- * a locked port +-- +-- You must use type applications to specify the output clock domain, e.g.: +-- +-- @ +-- type Dom100MHz = Dom \"A\" 10000 +-- +-- -- outputs a clock running at 100 MHz +-- altpll @@Dom100MHz (SSymbol @@"altpll50to100") clk50 rst +-- @ +altpll + :: forall pllOut pllIn name + . SSymbol name + -- ^ Name of the component, must correspond to the name entered in the QSys + -- dialog. + -- + -- For example, when you entered \"altPLL50\", instantiate as follows: + -- + -- > SSymbol @ "altPLL50" + -> Clock pllIn 'Source + -- ^ Free running clock (i.e. a clock pin connected to a crystal) + -> Reset pllIn 'Asynchronous + -- ^ Reset for the PLL + -> (Clock pllOut 'Source, Signal pllOut Bool) + -- ^ (Stable PLL clock, PLL lock) +altpll _ clk (Async rst) = (unsafeCoerce (clockGate clk rst), unsafeCoerce rst) +{-# NOINLINE altpll #-} + +-- | A clock source that corresponds to the Intel/Quartus \"Altera PLL\" +-- component with settings to provide a stable 'Clock' from a single +-- free-running input +-- +-- Only works when configured with: +-- +-- * 1 reference clock +-- * 1 output clock +-- * a reset port +-- * a locked port +-- +-- You must use type applications to specify the output clock domain, e.g.: +-- +-- @ +-- type Dom100MHz = Dom \"A\" 10000 +-- +-- -- outputs a clock running at 100 MHz +-- alteraPll @@Dom100MHz (SSymbol @@"alteraPll50to100") clk50 rst +-- @ +alteraPll + :: forall pllOut pllIn name + . SSymbol name + -- ^ Name of the component, must correspond to the name entered in the QSys + -- dialog. + -- + -- For example, when you entered \"alteraPLL50\", instantiate as follows: + -- + -- > SSymbol @ "alteraPLL50" + -> Clock pllIn 'Source + -- ^ Free running clock (i.e. a clock pin connected to a crystal) + -> Reset pllIn 'Asynchronous + -- ^ Reset for the PLL + -> (Clock pllOut 'Source, Signal pllOut Bool) + -- ^ (Stable PLL clock, PLL lock) +alteraPll _ clk (Async rst) = + (unsafeCoerce (clockGate clk rst), unsafeCoerce rst) +{-# NOINLINE alteraPll #-} diff --git a/src/Clash/Intel/DDR.hs b/src/Clash/Intel/DDR.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Intel/DDR.hs @@ -0,0 +1,94 @@ +{-| +Copyright : (C) 2017, Google Inc +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij + +DDR primitives for Intel FPGAs using ALTDDIO primitives. + +For general information about DDR primitives see "Clash.Explicit.DDR". + +Note that a synchronous reset is only available on certain devices, +see ALTDDIO userguide for the specifics: +https://www.altera.com/content/dam/altera-www/global/en_US/pdfs/literature/ug/ug_altddio.pdf +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Clash.Intel.DDR + ( altddioIn + , altddioOut + ) +where + +import GHC.Stack (HasCallStack, withFrozenCallStack) + +import Clash.Explicit.Prelude +import Clash.Explicit.DDR + +-- | Intel specific variant of 'ddrIn' implemented using the ALTDDIO_IN IP core. +-- +-- Reset values are @0@ +altddioIn + :: ( HasCallStack + , fast ~ 'Dom n pFast + , slow ~ 'Dom n (2*pFast) + , KnownNat m ) + => SSymbol deviceFamily + -- ^ The FPGA family + -- + -- For example this can be instantiated as follows: + -- + -- > SSymbol @"Cyclone IV GX" + -> Clock slow gated + -- ^ clock + -> Reset slow synchronous + -- ^ reset + -> Signal fast (BitVector m) + -- ^ DDR input signal + -> Signal slow (BitVector m,BitVector m) + -- ^ normal speed output pairs +altddioIn _devFam clk rst = withFrozenCallStack ddrIn# clk rst 0 0 0 +{-# NOINLINE altddioIn #-} + +-- | Intel specific variant of 'ddrOut' implemented using the ALTDDIO_OUT IP core. +-- +-- Reset value is @0@ +altddioOut + :: ( HasCallStack + , fast ~ 'Dom n pFast + , slow ~ 'Dom n (2*pFast) + , KnownNat m ) + => SSymbol deviceFamily + -- ^ The FPGA family + -- + -- For example this can be instantiated as follows: + -- + -- > SSymbol @"Cyclone IV E" + -> Clock slow gated + -- ^ clock + -> Reset slow synchronous + -- ^ reset + -> Signal slow (BitVector m,BitVector m) + -- ^ normal speed input pair + -> Signal fast (BitVector m) + -- ^ DDR output signal +altddioOut devFam clk rst = + uncurry (withFrozenCallStack altddioOut# devFam clk rst) . unbundle + +altddioOut# + :: ( HasCallStack + , fast ~ 'Dom n pFast + , slow ~ 'Dom n (2*pFast) + , KnownNat m ) + => SSymbol deviceFamily + -> Clock slow gated + -> Reset slow synchronous + -> Signal slow (BitVector m) + -> Signal slow (BitVector m) + -> Signal fast (BitVector m) +altddioOut# _ clk rst = ddrOut# clk rst 0 +{-# NOINLINE altddioOut# #-} diff --git a/src/Clash/NamedTypes.hs b/src/Clash/NamedTypes.hs new file mode 100644 --- /dev/null +++ b/src/Clash/NamedTypes.hs @@ -0,0 +1,66 @@ +{- | +Copyright : (C) 2017, Myrtle Software Ltd, QBayLogic, Google Inc. +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij + +Add inline documentation to types: + +@ +fifo + :: Clock domain gated + -> Reset domain synchronous + -> SNat addrSize + -> "read request" ::: Signal domain Bool + -> "write request" ::: Signal domain (Maybe (BitVector dataSize)) + -> ( "q" ::: Signal domain (BitVector dataSize) + , "full" ::: Signal domain Bool + , "empty" ::: Signal domain Bool + ) +@ + +which can subsequently be inspected in the interactive environment: + +>>> :t fifo @System +fifo @System + :: Clock System gated + -> Reset System synchronous + -> SNat addrSize + -> ("read request" ::: Signal System Bool) + -> ("write request" ::: Signal System (Maybe (BitVector dataSize))) + -> ("q" ::: Signal System (BitVector dataSize), + "full" ::: Signal System Bool, "empty" ::: Signal System Bool) + +-} + +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeOperators #-} + +{-# LANGUAGE Safe #-} + +{-# OPTIONS_HADDOCK show-extensions #-} + +module Clash.NamedTypes + ((:::)) +where + +type (name :: k) ::: a = a +-- ^ Annotate a type with a name + +{- $setup +>>> :set -XDataKinds -XTypeOperators -XNoImplicitPrelude +>>> import Clash.Explicit.Prelude +>>> :{ +let fifo + :: Clock domain gated + -> Reset domain synchronous + -> SNat addrSize + -> "read request" ::: Signal domain Bool + -> "write request" ::: Signal domain (Maybe (BitVector dataSize)) + -> ( "q" ::: Signal domain (BitVector dataSize) + , "full" ::: Signal domain Bool + , "empty" ::: Signal domain Bool + ) + fifo = Clash.Explicit.Prelude.undefined +:} + +-} diff --git a/src/Clash/Prelude.hs b/src/Clash/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Prelude.hs @@ -0,0 +1,215 @@ +{-| + Copyright : (C) 2013-2016, University of Twente, + 2017 , Myrtle Software Ltd, Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + CλaSH (pronounced ‘clash’) is a functional hardware description language that + borrows both its syntax and semantics from the functional programming language + Haskell. The merits of using a functional language to describe hardware comes + from the fact that combinational circuits can be directly modeled as + mathematical functions and that functional languages lend themselves very well + at describing and (de-)composing mathematical functions. + + This package provides: + + * Prelude library containing datatypes and functions for circuit design + + To use the library: + + * Import "Clash.Prelude"; by default clock and reset lines are implicitly + routed for all the components found in "Clash.Prelude". You can read more + about implicit clock and reset lines in "Clash.Signal#implicitclockandreset" + * Alternatively, if you want to explicitly route clock and reset ports, + for more straightforward multi-clock designs, you can import the + "Clash.Explicit.Prelude" module. Note that you should not import + "Clash.Prelude" and "Clash.Explicit.Prelude" at the same time as they + have overlapping definitions. + + For now, "Clash.Prelude" is also the best starting point for exploring the + library. A preliminary version of a tutorial can be found in "Clash.Tutorial". + Some circuit examples can be found in "Clash.Examples". +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} + +{-# LANGUAGE Unsafe #-} + +{-# OPTIONS_HADDOCK show-extensions #-} + +module Clash.Prelude + ( -- * Creating synchronous sequential circuits + mealy + , mealyB + , (<^>) + , moore + , mooreB + , registerB + -- * ROMs + , asyncRom + , asyncRomPow2 + , rom + , romPow2 + -- ** ROMs initialised with a data file + , asyncRomFile + , asyncRomFilePow2 + , romFile + , romFilePow2 + -- * RAM primitives with a combinational read port + , asyncRam + , asyncRamPow2 + -- * BlockRAM primitives + , blockRam + , blockRamPow2 + -- ** BlockRAM primitives initialised with a data file + , blockRamFile + , blockRamFilePow2 + -- ** BlockRAM read/write conflict resolution + , readNew + -- * Utility functions + , window + , windowD + , isRising + , isFalling + -- * Exported modules + -- ** Synchronous signals + , module Clash.Signal + , module Clash.Signal.Delayed + -- ** DataFlow interface + , module Clash.Prelude.DataFlow + -- ** Datatypes + -- *** Bit vectors + , module Clash.Sized.BitVector + , module Clash.Prelude.BitIndex + , module Clash.Prelude.BitReduction + -- *** Arbitrary-width numbers + , module Clash.Sized.Signed + , module Clash.Sized.Unsigned + , module Clash.Sized.Index + -- *** Fixed point numbers + , module Clash.Sized.Fixed + -- *** Fixed size vectors + , module Clash.Sized.Vector + -- *** Perfect depth trees + , module Clash.Sized.RTree + -- ** Annotations + , module Clash.Annotations.TopEntity + -- ** Type-level natural numbers + , module GHC.TypeLits + , module GHC.TypeLits.Extra + , module Clash.Promoted.Nat + , module Clash.Promoted.Nat.Literals + , module Clash.Promoted.Nat.TH + -- ** Template Haskell + , Lift (..) + -- ** Type classes + -- *** Clash + , module Clash.Class.BitPack + , module Clash.Class.Num + , module Clash.Class.Resize + -- *** Other + , module Control.Applicative + , module Data.Bits + , module Data.Default + -- ** Exceptions + , module Clash.XException + , undefined + -- ** Named types + , module Clash.NamedTypes + -- ** Hidden arguments + , module Clash.Hidden + -- ** Haskell Prelude + -- $hiding + , module Prelude + ) +where + +import Control.Applicative +import Data.Bits +import Data.Default +import GHC.TypeLits +import GHC.TypeLits.Extra +import Language.Haskell.TH.Syntax (Lift(..)) +import Prelude hiding + ((++), (!!), concat, drop, foldl, foldl1, foldr, foldr1, head, init, iterate, + last, length, map, repeat, replicate, reverse, scanl, scanr, splitAt, tail, + take, unzip, unzip3, zip, zip3, zipWith, zipWith3, undefined) + +import Clash.Annotations.TopEntity +import Clash.Class.BitPack +import Clash.Class.Num +import Clash.Class.Resize +import qualified Clash.Explicit.Prelude as E +import Clash.Hidden +import Clash.NamedTypes +import Clash.Prelude.BitIndex +import Clash.Prelude.BitReduction +import Clash.Prelude.BlockRam.File +import Clash.Prelude.DataFlow +import Clash.Prelude.ROM.File +import Clash.Prelude.Safe +import Clash.Promoted.Nat +import Clash.Promoted.Nat.TH +import Clash.Promoted.Nat.Literals +import Clash.Sized.BitVector +import Clash.Sized.Fixed +import Clash.Sized.Index +import Clash.Sized.RTree +import Clash.Sized.Signed +import Clash.Sized.Unsigned +import Clash.Sized.Vector +import Clash.Signal +import Clash.Signal.Delayed +import Clash.XException + +{- $setup +>>> :set -XDataKinds -XFlexibleContexts +>>> let window4 = window :: HiddenClockReset domain gated synchronous => Signal domain Int -> Vec 4 (Signal domain Int) +>>> let windowD3 = windowD :: HiddenClockReset domain gated synchronous => Signal domain Int -> Vec 3 (Signal domain Int) +-} + +{- $hiding +"Clash.Prelude" re-exports most of the Haskell "Prelude" with the exception of +the following: (++), (!!), concat, drop, foldl, foldl1, foldr, foldr1, head, +init, iterate, last, length, map, repeat, replicate, reverse, scanl, scanr, +splitAt, tail, take, unzip, unzip3, zip, zip3, zipWith, zipWith3. + +It instead exports the identically named functions defined in terms of +'Clash.Sized.Vector.Vec' at "Clash.Sized.Vector". +-} + + +-- | Give a window over a 'Signal' +-- +-- > window4 :: HiddenClockReset domain gated synchronous +-- > => Signal domain Int -> Vec 4 (Signal domain Int) +-- > window4 = window +-- +-- >>> simulateB window4 [1::Int,2,3,4,5] :: [Vec 4 Int] +-- [<1,0,0,0>,<2,1,0,0>,<3,2,1,0>,<4,3,2,1>,<5,4,3,2>... +-- ... +window + :: (KnownNat n, Default a, HiddenClockReset domain gated synchronous) + => Signal domain a -- ^ Signal to create a window over + -> Vec (n + 1) (Signal domain a) -- ^ Window of at least size 1 +window = hideClockReset E.window +{-# INLINE window #-} + +-- | Give a delayed window over a 'Signal' +-- +-- > windowD3 :: HiddenClockReset domain gated synchronous +-- > => Signal domain Int -> Vec 3 (Signal domain Int) +-- > windowD3 = windowD +-- +-- >>> simulateB windowD3 [1::Int,2,3,4] :: [Vec 3 Int] +-- [<0,0,0>,<1,0,0>,<2,1,0>,<3,2,1>,<4,3,2>... +-- ... +windowD + :: (KnownNat n, Default a, HiddenClockReset domain gated synchronous) + => Signal domain a -- ^ Signal to create a window over + -> Vec (n + 1) (Signal domain a) -- ^ Window of at least size 1 +windowD = hideClockReset E.windowD +{-# INLINE windowD #-} diff --git a/src/Clash/Prelude/BitIndex.hs b/src/Clash/Prelude/BitIndex.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Prelude/BitIndex.hs @@ -0,0 +1,152 @@ +{-| +Copyright : (C) 2013-2016, University of Twente +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} + +{-# LANGUAGE Trustworthy #-} + +{-# OPTIONS_HADDOCK show-extensions #-} + +module Clash.Prelude.BitIndex where + +import GHC.TypeLits (KnownNat, type (+), type (-)) + +import Clash.Class.BitPack (BitPack (..)) +import Clash.Promoted.Nat (SNat) +import Clash.Sized.Internal.BitVector (BitVector, Bit, index#, lsb#, msb#, + replaceBit#, setSlice#, slice#, split#) + +{- $setup +>>> :set -XDataKinds +>>> import Clash.Prelude +-} + +{-# INLINE (!) #-} +-- | Get the bit at the specified bit index. +-- +-- __NB:__ Bit indices are __DESCENDING__. +-- +-- >>> pack (7 :: Unsigned 6) +-- 00_0111 +-- >>> (7 :: Unsigned 6) ! 1 +-- 1 +-- >>> (7 :: Unsigned 6) ! 5 +-- 0 +-- >>> (7 :: Unsigned 6) ! 6 +-- *** Exception: (!): 6 is out of range [5..0] +-- ... +(!) :: (BitPack a, KnownNat (BitSize a), Enum i) => a -> i -> Bit +(!) v i = index# (pack v) (fromEnum i) + +{-# INLINE slice #-} +-- | Get a slice between bit index @m@ and and bit index @n@. +-- +-- __NB:__ Bit indices are __DESCENDING__. +-- +-- >>> pack (7 :: Unsigned 6) +-- 00_0111 +-- >>> slice d4 d2 (7 :: Unsigned 6) +-- 001 +-- >>> slice d6 d4 (7 :: Unsigned 6) +-- +-- :... +-- • Couldn't match type ‘7 + i0’ with ‘6’ +-- arising from a use of ‘slice’ +-- The type variable ‘i0’ is ambiguous +-- • In the expression: slice d6 d4 (7 :: Unsigned 6) +-- In an equation for ‘it’: it = slice d6 d4 (7 :: Unsigned 6) +slice :: (BitPack a, BitSize a ~ ((m + 1) + i)) => SNat m -> SNat n -> a + -> BitVector (m + 1 - n) +slice m n v = slice# (pack v) m n + +{-# INLINE split #-} +-- | Split a value of a bit size @m + n@ into a tuple of values with size @m@ +-- and size @n@. +-- +-- >>> pack (7 :: Unsigned 6) +-- 00_0111 +-- >>> split (7 :: Unsigned 6) :: (BitVector 2, BitVector 4) +-- (00,0111) +split :: (BitPack a, BitSize a ~ (m + n), KnownNat n) => a + -> (BitVector m, BitVector n) +split v = split# (pack v) + +{-# INLINE replaceBit #-} +-- | Set the bit at the specified index +-- +-- __NB:__ Bit indices are __DESCENDING__. +-- +-- >>> pack (-5 :: Signed 6) +-- 11_1011 +-- >>> replaceBit 4 0 (-5 :: Signed 6) +-- -21 +-- >>> pack (-21 :: Signed 6) +-- 10_1011 +-- >>> replaceBit 5 0 (-5 :: Signed 6) +-- 27 +-- >>> pack (27 :: Signed 6) +-- 01_1011 +-- >>> replaceBit 6 0 (-5 :: Signed 6) +-- *** Exception: replaceBit: 6 is out of range [5..0] +-- ... +replaceBit :: (BitPack a, KnownNat (BitSize a), Enum i) => i -> Bit -> a + -> a +replaceBit i b v = unpack (replaceBit# (pack v) (fromEnum i) b) + +{-# INLINE setSlice #-} +-- | Set the bits between bit index @m@ and bit index @n@. +-- +-- __NB:__ Bit indices are __DESCENDING__. +-- +-- >>> pack (-5 :: Signed 6) +-- 11_1011 +-- >>> setSlice d4 d3 0 (-5 :: Signed 6) +-- -29 +-- >>> pack (-29 :: Signed 6) +-- 10_0011 +-- >>> setSlice d6 d5 0 (-5 :: Signed 6) +-- +-- :... +-- • Couldn't match type ‘7 + i0’ with ‘6’ +-- arising from a use of ‘setSlice’ +-- The type variable ‘i0’ is ambiguous +-- • In the expression: setSlice d6 d5 0 (- 5 :: Signed 6) +-- In an equation for ‘it’: it = setSlice d6 d5 0 (- 5 :: Signed 6) +setSlice :: (BitPack a, BitSize a ~ ((m + 1) + i)) => SNat m -> SNat n + -> BitVector (m + 1 - n) -> a -> a +setSlice m n w v = unpack (setSlice# (pack v) m n w) + +{-# INLINE msb #-} +-- | Get the most significant bit. +-- +-- >>> pack (-4 :: Signed 6) +-- 11_1100 +-- >>> msb (-4 :: Signed 6) +-- 1 +-- >>> pack (4 :: Signed 6) +-- 00_0100 +-- >>> msb (4 :: Signed 6) +-- 0 +msb :: (BitPack a, KnownNat (BitSize a)) => a -> Bit +msb v = msb# (pack v) + +{-# INLINE lsb #-} +-- | Get the least significant bit. +-- +-- >>> pack (-9 :: Signed 6) +-- 11_0111 +-- >>> lsb (-9 :: Signed 6) +-- 1 +-- >>> pack (-8 :: Signed 6) +-- 11_1000 +-- >>> lsb (-8 :: Signed 6) +-- 0 +lsb :: BitPack a => a -> Bit +lsb v = lsb# (pack v) diff --git a/src/Clash/Prelude/BitReduction.hs b/src/Clash/Prelude/BitReduction.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Prelude/BitReduction.hs @@ -0,0 +1,70 @@ +{-| +Copyright : (C) 2013-2016, University of Twente +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij +-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MagicHash #-} + +{-# LANGUAGE Trustworthy #-} + +{-# OPTIONS_HADDOCK show-extensions #-} + +module Clash.Prelude.BitReduction where + +import GHC.TypeLits (KnownNat) + +import Clash.Class.BitPack (BitPack (..)) +import Clash.Sized.Internal.BitVector (Bit, reduceAnd#, reduceOr#, reduceXor#) + +{- $setup +>>> :set -XDataKinds +>>> import Clash.Prelude +-} + +{-# INLINE reduceAnd #-} +-- | Are all bits set to '1'? +-- +-- >>> pack (-2 :: Signed 6) +-- 11_1110 +-- >>> reduceAnd (-2 :: Signed 6) +-- 0 +-- >>> pack (-1 :: Signed 6) +-- 11_1111 +-- >>> reduceAnd (-1 :: Signed 6) +-- 1 +reduceAnd :: (BitPack a, KnownNat (BitSize a)) => a -> Bit +reduceAnd v = reduceAnd# (pack v) + +{-# INLINE reduceOr #-} +-- | Is there at least one bit set to '1'? +-- +-- >>> pack (5 :: Signed 6) +-- 00_0101 +-- >>> reduceOr (5 :: Signed 6) +-- 1 +-- >>> pack (0 :: Signed 6) +-- 00_0000 +-- >>> reduceOr (0 :: Signed 6) +-- 0 +reduceOr :: BitPack a => a -> Bit +reduceOr v = reduceOr# (pack v) + +{-# INLINE reduceXor #-} +-- | Is the number of bits set to '1' uneven? +-- +-- >>> pack (5 :: Signed 6) +-- 00_0101 +-- >>> reduceXor (5 :: Signed 6) +-- 0 +-- >>> pack (28 :: Signed 6) +-- 01_1100 +-- >>> reduceXor (28 :: Signed 6) +-- 1 +-- >>> pack (-5 :: Signed 6) +-- 11_1011 +-- >>> reduceXor (-5 :: Signed 6) +-- 1 +reduceXor :: BitPack a => a -> Bit +reduceXor v = reduceXor# (pack v) diff --git a/src/Clash/Prelude/BlockRam.hs b/src/Clash/Prelude/BlockRam.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Prelude/BlockRam.hs @@ -0,0 +1,710 @@ +{-| +Copyright : (C) 2013-2016, University of Twente, + 2016-2017, Myrtle Software Ltd, + 2017 , Google Inc. +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij + +BlockRAM primitives + += Using RAMs #usingrams# + +We will show a rather elaborate example on how you can, and why you might want +to use 'blockRam's. We will build a \"small\" CPU+Memory+Program ROM where we +will slowly evolve to using blockRams. Note that the code is /not/ meant as a +de-facto standard on how to do CPU design in CλaSH. + +We start with the definition of the Instructions, Register names and machine +codes: + +@ +{\-\# LANGUAGE RecordWildCards, TupleSections \#-\} +module CPU where + +import Clash.Prelude + +type InstrAddr = Unsigned 8 +type MemAddr = Unsigned 5 +type Value = Signed 8 + +data Instruction + = Compute Operator Reg Reg Reg + | Branch Reg Value + | Jump Value + | Load MemAddr Reg + | Store Reg MemAddr + | Nop + deriving (Eq,Show) + +data Reg + = Zero + | PC + | RegA + | RegB + | RegC + | RegD + | RegE + deriving (Eq,Show,Enum) + +data Operator = Add | Sub | Incr | Imm | CmpGt + deriving (Eq,Show) + +data MachCode + = MachCode + { inputX :: Reg + , inputY :: Reg + , result :: Reg + , aluCode :: Operator + , ldReg :: Reg + , rdAddr :: MemAddr + , wrAddrM :: Maybe MemAddr + , jmpM :: Maybe Value + } + +nullCode = MachCode { inputX = Zero, inputY = Zero, result = Zero, aluCode = Imm + , ldReg = Zero, rdAddr = 0, wrAddrM = Nothing + , jmpM = Nothing + } +@ + +Next we define the CPU and its ALU: + +@ +cpu :: Vec 7 Value -- ^ Register bank + -> (Value,Instruction) -- ^ (Memory output, Current instruction) + -> ( Vec 7 Value + , (MemAddr, Maybe (MemAddr,Value), InstrAddr) + ) +cpu regbank (memOut,instr) = (regbank',(rdAddr,(,aluOut) '<$>' wrAddrM,fromIntegral ipntr)) + where + -- Current instruction pointer + ipntr = regbank '!!' PC + + -- Decoder + (MachCode {..}) = case instr of + Compute op rx ry res -> nullCode {inputX=rx,inputY=ry,result=res,aluCode=op} + Branch cr a -> nullCode {inputX=cr,jmpM=Just a} + Jump a -> nullCode {aluCode=Incr,jmpM=Just a} + Load a r -> nullCode {ldReg=r,rdAddr=a} + Store r a -> nullCode {inputX=r,wrAddrM=Just a} + Nop -> nullCode + + -- ALU + regX = regbank '!!' inputX + regY = regbank '!!' inputY + aluOut = alu aluCode regX regY + + -- next instruction + nextPC = case jmpM of + Just a | aluOut /= 0 -> ipntr + a + _ -> ipntr + 1 + + -- update registers + regbank' = 'replace' Zero 0 + $ 'replace' PC nextPC + $ 'replace' result aluOut + $ 'replace' ldReg memOut + $ regbank + +alu Add x y = x + y +alu Sub x y = x - y +alu Incr x _ = x + 1 +alu Imm x _ = x +alu CmpGt x y = if x > y then 1 else 0 +@ + +We initially create a memory out of simple registers: + +@ +dataMem :: HiddenClockReset domain gated synchronous + => Signal domain MemAddr -- ^ Read address + -> Signal domain (Maybe (MemAddr,Value)) -- ^ (write address, data in) + -> Signal domain Value -- ^ data out +dataMem rd wrM = 'Clash.Prelude.Mealy.mealy' dataMemT ('replicate' d32 0) (bundle (rd,wrM)) + where + dataMemT mem (rd,wrM) = (mem',dout) + where + dout = mem '!!' rd + mem' = case wrM of + Just (wr,din) -> 'replace' wr din mem + _ -> mem +@ + +And then connect everything: + +@ +system :: (KnownNat n, HiddenClockReset domain gated synchronous) => Vec n Instruction -> Signal domain Value +system instrs = memOut + where + memOut = dataMem rdAddr dout + (rdAddr,dout,ipntr) = 'Clash.Prelude.Mealy.mealyB' cpu ('replicate' d7 0) (memOut,instr) + instr = 'Clash.Prelude.ROM.asyncRom' instrs '<$>' ipntr +@ + +Create a simple program that calculates the GCD of 4 and 6: + +@ +-- Compute GCD of 4 and 6 +prog = -- 0 := 4 + Compute Incr Zero RegA RegA :> + replicate d3 (Compute Incr RegA Zero RegA) ++ + Store RegA 0 :> + -- 1 := 6 + Compute Incr Zero RegA RegA :> + replicate d5 (Compute Incr RegA Zero RegA) ++ + Store RegA 1 :> + -- A := 4 + Load 0 RegA :> + -- B := 6 + Load 1 RegB :> + -- start + Compute CmpGt RegA RegB RegC :> + Branch RegC 4 :> + Compute CmpGt RegB RegA RegC :> + Branch RegC 4 :> + Jump 5 :> + -- (a > b) + Compute Sub RegA RegB RegA :> + Jump (-6) :> + -- (b > a) + Compute Sub RegB RegA RegB :> + Jump (-8) :> + -- end + Store RegA 2 :> + Load 2 RegC :> + Nil +@ + +And test our system: + +@ +>>> sampleN 31 (system prog) +[0,0,0,0,0,4,4,4,4,4,4,4,4,6,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,2] + +@ + +to see that our system indeed calculates that the GCD of 6 and 4 is 2. + +=== Improvement 1: using @asyncRam@ + +As you can see, it's fairly straightforward to build a memory using registers +and read ('!!') and write ('replace') logic. This might however not result in +the most efficient hardware structure, especially when building an ASIC. + +Instead it is preferable to use the 'Clash.Prelude.RAM.asyncRam' function which +has the potential to be translated to a more efficient structure: + +@ +system2 :: (KnownNat n, HiddenClockReset domain gated synchronous) => Vec n Instruction -> Signal domain Value +system2 instrs = memOut + where + memOut = 'Clash.Prelude.RAM.asyncRam' d32 rdAddr dout + (rdAddr,dout,ipntr) = 'mealyB' cpu ('replicate' d7 0) (memOut,instr) + instr = 'Clash.Prelude.ROM.asyncRom' instrs '<$>' ipntr +@ + +Again, we can simulate our system and see that it works. This time however, +we need to disregard the first few output samples, because the initial content of an +'Clash.Prelude.RAM.asyncRam' is 'undefined', and consequently, the first few +output samples are also 'undefined'. We use the utility function 'printX' to conveniently +filter out the undefinedness and replace it with the string "X" in the few leading outputs. + +@ +>>> printX $ sampleN 31 (system2 prog) +[X,X,X,X,X,4,4,4,4,4,4,4,4,6,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,2] + +@ + +=== Improvement 2: using @blockRam@ + +Finally we get to using 'blockRam'. On FPGAs, 'Clash.Prelude.RAM.asyncRam' will +be implemented in terms of LUTs, and therefore take up logic resources. FPGAs +also have large(r) memory structures called /Block RAMs/, which are preferred, +especially as the memories we need for our application get bigger. The +'blockRam' function will be translated to such a /Block RAM/. + +One important aspect of Block RAMs have a /synchronous/ read port, meaning that, +unlike the behaviour of 'Clash.Prelude.RAM.asyncRam', given a read address @r@ +at time @t@, the value @v@ in the RAM at address @r@ is only available at time +@t+1@. + +For us that means we need to change the design of our CPU. Right now, upon a +load instruction we generate a read address for the memory, and the value at +that read address is immediately available to be put in the register bank. +Because we will be using a BlockRAM, the value is delayed until the next cycle. +We hence need to also delay the register address to which the memory address +is loaded: + +@ +cpu2 :: (Vec 7 Value,Reg) -- ^ (Register bank, Load reg addr) + -> (Value,Instruction) -- ^ (Memory output, Current instruction) + -> ( (Vec 7 Value,Reg) + , (MemAddr, Maybe (MemAddr,Value), InstrAddr) + ) +cpu2 (regbank,ldRegD) (memOut,instr) = ((regbank',ldRegD'),(rdAddr,(,aluOut) '<$>' wrAddrM,fromIntegral ipntr)) + where + -- Current instruction pointer + ipntr = regbank '!!' PC + + -- Decoder + (MachCode {..}) = case instr of + Compute op rx ry res -> nullCode {inputX=rx,inputY=ry,result=res,aluCode=op} + Branch cr a -> nullCode {inputX=cr,jmpM=Just a} + Jump a -> nullCode {aluCode=Incr,jmpM=Just a} + Load a r -> nullCode {ldReg=r,rdAddr=a} + Store r a -> nullCode {inputX=r,wrAddrM=Just a} + Nop -> nullCode + + -- ALU + regX = regbank '!!' inputX + regY = regbank '!!' inputY + aluOut = alu aluCode regX regY + + -- next instruction + nextPC = case jmpM of + Just a | aluOut /= 0 -> ipntr + a + _ -> ipntr + 1 + + -- update registers + ldRegD' = ldReg -- Delay the ldReg by 1 cycle + regbank' = 'replace' Zero 0 + $ 'replace' PC nextPC + $ 'replace' result aluOut + $ 'replace' ldRegD memOut + $ regbank +@ + +We can now finally instantiate our system with a 'blockRam': + +@ +system3 :: (KnownNat n, HiddenClockReset domain gated synchronous) => Vec n Instruction -> Signal domain Value +system3 instrs = memOut + where + memOut = 'blockRam' (replicate d32 0) rdAddr dout + (rdAddr,dout,ipntr) = 'mealyB' cpu2 (('replicate' d7 0),Zero) (memOut,instr) + instr = 'Clash.Prelude.ROM.asyncRom' instrs '<$>' ipntr +@ + +We are, however, not done. We will also need to update our program. The reason +being that values that we try to load in our registers won't be loaded into the +register until the next cycle. This is a problem when the next instruction +immediately depended on this memory value. In our case, this was only the case +when the loaded the value @6@, which was stored at address @1@, into @RegB@. +Our updated program is thus: + +@ +prog2 = -- 0 := 4 + Compute Incr Zero RegA RegA :> + replicate d3 (Compute Incr RegA Zero RegA) ++ + Store RegA 0 :> + -- 1 := 6 + Compute Incr Zero RegA RegA :> + replicate d5 (Compute Incr RegA Zero RegA) ++ + Store RegA 1 :> + -- A := 4 + Load 0 RegA :> + -- B := 6 + Load 1 RegB :> + Nop :> -- Extra NOP + -- start + Compute CmpGt RegA RegB RegC :> + Branch RegC 4 :> + Compute CmpGt RegB RegA RegC :> + Branch RegC 4 :> + Jump 5 :> + -- (a > b) + Compute Sub RegA RegB RegA :> + Jump (-6) :> + -- (b > a) + Compute Sub RegB RegA RegB :> + Jump (-8) :> + -- end + Store RegA 2 :> + Load 2 RegC :> + Nil +@ + +When we simulate our system we see that it works. This time again, +we need to disregard the first sample, because the initial output of a +'blockRam' is 'undefined'. We use the utility function 'printX' to conveniently +filter out the undefinedness and replace it with the string "X". + +@ +>>> printX $ sampleN 33 (system3 prog2) +[X,0,0,0,0,0,4,4,4,4,4,4,4,4,6,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,2] + +@ + +This concludes the short introduction to using 'blockRam'. + +-} + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +{-# LANGUAGE Safe #-} + +{-# OPTIONS_HADDOCK show-extensions #-} + +module Clash.Prelude.BlockRam + ( -- * BlockRAM synchronised to the system clock + blockRam + , blockRamPow2 + -- * Read/Write conflict resolution + , readNew + ) +where + +import GHC.TypeLits (KnownNat, type (^)) +import GHC.Stack (HasCallStack, withFrozenCallStack) + +import qualified Clash.Explicit.BlockRam as E +import Clash.Signal +import Clash.Sized.Unsigned (Unsigned) +import Clash.Sized.Vector (Vec) + +{- $setup +>>> import Clash.Prelude as C +>>> import qualified Data.List as L +>>> :set -XDataKinds -XRecordWildCards -XTupleSections -XTypeApplications -XFlexibleContexts +>>> type InstrAddr = Unsigned 8 +>>> type MemAddr = Unsigned 5 +>>> type Value = Signed 8 +>>> :{ +data Reg + = Zero + | PC + | RegA + | RegB + | RegC + | RegD + | RegE + deriving (Eq,Show,Enum) +:} + +>>> :{ +data Operator = Add | Sub | Incr | Imm | CmpGt + deriving (Eq,Show) +:} + +>>> :{ +data Instruction + = Compute Operator Reg Reg Reg + | Branch Reg Value + | Jump Value + | Load MemAddr Reg + | Store Reg MemAddr + | Nop + deriving (Eq,Show) +:} + +>>> :{ +data MachCode + = MachCode + { inputX :: Reg + , inputY :: Reg + , result :: Reg + , aluCode :: Operator + , ldReg :: Reg + , rdAddr :: MemAddr + , wrAddrM :: Maybe MemAddr + , jmpM :: Maybe Value + } +:} + +>>> :{ +nullCode = MachCode { inputX = Zero, inputY = Zero, result = Zero, aluCode = Imm + , ldReg = Zero, rdAddr = 0, wrAddrM = Nothing + , jmpM = Nothing + } +:} + +>>> :{ +alu Add x y = x + y +alu Sub x y = x - y +alu Incr x _ = x + 1 +alu Imm x _ = x +alu CmpGt x y = if x > y then 1 else 0 +:} + +>>> :{ +cpu :: Vec 7 Value -- ^ Register bank + -> (Value,Instruction) -- ^ (Memory output, Current instruction) + -> ( Vec 7 Value + , (MemAddr,Maybe (MemAddr,Value),InstrAddr) + ) +cpu regbank (memOut,instr) = (regbank',(rdAddr,(,aluOut) <$> wrAddrM,fromIntegral ipntr)) + where + -- Current instruction pointer + ipntr = regbank C.!! PC + -- Decoder + (MachCode {..}) = case instr of + Compute op rx ry res -> nullCode {inputX=rx,inputY=ry,result=res,aluCode=op} + Branch cr a -> nullCode {inputX=cr,jmpM=Just a} + Jump a -> nullCode {aluCode=Incr,jmpM=Just a} + Load a r -> nullCode {ldReg=r,rdAddr=a} + Store r a -> nullCode {inputX=r,wrAddrM=Just a} + Nop -> nullCode + -- ALU + regX = regbank C.!! inputX + regY = regbank C.!! inputY + aluOut = alu aluCode regX regY + -- next instruction + nextPC = case jmpM of + Just a | aluOut /= 0 -> ipntr + a + _ -> ipntr + 1 + -- update registers + regbank' = replace Zero 0 + $ replace PC nextPC + $ replace result aluOut + $ replace ldReg memOut + $ regbank +:} + +>>> :{ +dataMem + :: HiddenClockReset domain gated synchronous + => Signal domain MemAddr + -> Signal domain (Maybe (MemAddr,Value)) + -> Signal domain Value +dataMem rd wrM = mealy dataMemT (C.replicate d32 0) (bundle (rd,wrM)) + where + dataMemT mem (rd,wrM) = (mem',dout) + where + dout = mem C.!! rd + mem' = case wrM of + Just (wr,din) -> replace wr din mem + Nothing -> mem +:} + +>>> :{ +system + :: (KnownNat n, HiddenClockReset domain gated synchronous) + => Vec n Instruction + -> Signal domain Value +system instrs = memOut + where + memOut = dataMem rdAddr dout + (rdAddr,dout,ipntr) = mealyB cpu (C.replicate d7 0) (memOut,instr) + instr = asyncRom instrs <$> ipntr +:} + +>>> :{ +-- Compute GCD of 4 and 6 +prog = -- 0 := 4 + Compute Incr Zero RegA RegA :> + C.replicate d3 (Compute Incr RegA Zero RegA) C.++ + Store RegA 0 :> + -- 1 := 6 + Compute Incr Zero RegA RegA :> + C.replicate d5 (Compute Incr RegA Zero RegA) C.++ + Store RegA 1 :> + -- A := 4 + Load 0 RegA :> + -- B := 6 + Load 1 RegB :> + -- start + Compute CmpGt RegA RegB RegC :> + Branch RegC 4 :> + Compute CmpGt RegB RegA RegC :> + Branch RegC 4 :> + Jump 5 :> + -- (a > b) + Compute Sub RegA RegB RegA :> + Jump (-6) :> + -- (b > a) + Compute Sub RegB RegA RegB :> + Jump (-8) :> + -- end + Store RegA 2 :> + Load 2 RegC :> + Nil +:} + +>>> :{ +system2 + :: (KnownNat n, HiddenClockReset domain gated synchronous) + => Vec n Instruction + -> Signal domain Value +system2 instrs = memOut + where + memOut = asyncRam d32 rdAddr dout + (rdAddr,dout,ipntr) = mealyB cpu (C.replicate d7 0) (memOut,instr) + instr = asyncRom instrs <$> ipntr +:} + +>>> :{ +cpu2 :: (Vec 7 Value,Reg) -- ^ (Register bank, Load reg addr) + -> (Value,Instruction) -- ^ (Memory output, Current instruction) + -> ( (Vec 7 Value,Reg) + , (MemAddr,Maybe (MemAddr,Value),InstrAddr) + ) +cpu2 (regbank,ldRegD) (memOut,instr) = ((regbank',ldRegD'),(rdAddr,(,aluOut) <$> wrAddrM,fromIntegral ipntr)) + where + -- Current instruction pointer + ipntr = regbank C.!! PC + -- Decoder + (MachCode {..}) = case instr of + Compute op rx ry res -> nullCode {inputX=rx,inputY=ry,result=res,aluCode=op} + Branch cr a -> nullCode {inputX=cr,jmpM=Just a} + Jump a -> nullCode {aluCode=Incr,jmpM=Just a} + Load a r -> nullCode {ldReg=r,rdAddr=a} + Store r a -> nullCode {inputX=r,wrAddrM=Just a} + Nop -> nullCode + -- ALU + regX = regbank C.!! inputX + regY = regbank C.!! inputY + aluOut = alu aluCode regX regY + -- next instruction + nextPC = case jmpM of + Just a | aluOut /= 0 -> ipntr + a + _ -> ipntr + 1 + -- update registers + ldRegD' = ldReg -- Delay the ldReg by 1 cycle + regbank' = replace Zero 0 + $ replace PC nextPC + $ replace result aluOut + $ replace ldRegD memOut + $ regbank +:} + +>>> :{ +system3 + :: (KnownNat n, HiddenClockReset domain gated synchronous) + => Vec n Instruction + -> Signal domain Value +system3 instrs = memOut + where + memOut = blockRam (C.replicate d32 0) rdAddr dout + (rdAddr,dout,ipntr) = mealyB cpu2 ((C.replicate d7 0),Zero) (memOut,instr) + instr = asyncRom instrs <$> ipntr +:} + +>>> :{ +prog2 = -- 0 := 4 + Compute Incr Zero RegA RegA :> + C.replicate d3 (Compute Incr RegA Zero RegA) C.++ + Store RegA 0 :> + -- 1 := 6 + Compute Incr Zero RegA RegA :> + C.replicate d5 (Compute Incr RegA Zero RegA) C.++ + Store RegA 1 :> + -- A := 4 + Load 0 RegA :> + -- B := 6 + Load 1 RegB :> + Nop :> -- Extra NOP + -- start + Compute CmpGt RegA RegB RegC :> + Branch RegC 4 :> + Compute CmpGt RegB RegA RegC :> + Branch RegC 4 :> + Jump 5 :> + -- (a > b) + Compute Sub RegA RegB RegA :> + Jump (-6) :> + -- (b > a) + Compute Sub RegB RegA RegB :> + Jump (-8) :> + -- end + Store RegA 2 :> + Load 2 RegC :> + Nil +:} + +-} + +-- | Create a blockRAM with space for @n@ elements. +-- +-- * __NB__: Read value is delayed by 1 cycle +-- * __NB__: Initial output value is 'undefined' +-- +-- @ +-- bram40 +-- :: 'HiddenClock' domain +-- => 'Signal' domain ('Unsigned' 6) +-- -> 'Signal' domain (Maybe ('Unsigned' 6, 'Clash.Sized.BitVector.Bit')) +-- -> 'Signal' domain 'Clash.Sized.BitVector.Bit' +-- bram40 = 'blockRam' ('Clash.Sized.Vector.replicate' d40 1) +-- @ +-- +-- Additional helpful information: +-- +-- * See "Clash.Prelude.BlockRam#usingrams" for more information on how to use a +-- Block RAM. +-- * Use the adapter 'readNew' for obtaining write-before-read semantics like this: @readNew (blockRam inits) rd wrM@. +blockRam + :: (Enum addr, HiddenClock domain gated, HasCallStack) + => Vec n a -- ^ Initial content of the BRAM, also + -- determines the size, @n@, of the BRAM. + -- + -- __NB__: __MUST__ be a constant. + -> Signal domain addr -- ^ Read address @r@ + -> Signal domain (Maybe (addr, a)) + -- ^ (write address @w@, value to write) + -> Signal domain a + -- ^ Value of the @blockRAM@ at address @r@ from the previous clock + -- cycle +blockRam = \cnt rd wrM -> withFrozenCallStack + (hideClock E.blockRam cnt rd wrM) +{-# INLINE blockRam #-} + +-- | Create a blockRAM with space for 2^@n@ elements +-- +-- * __NB__: Read value is delayed by 1 cycle +-- * __NB__: Initial output value is 'undefined' +-- +-- @ +-- bram32 +-- :: 'HiddenClock' domain +-- => 'Signal' domain ('Unsigned' 5) +-- -> 'Signal' domain (Maybe ('Unsigned' 5, 'Clash.Sized.BitVector.Bit')) +-- -> 'Signal' domain 'Clash.Sized.BitVector.Bit' +-- bram32 = 'blockRamPow2' ('Clash.Sized.Vector.replicate' d32 1) +-- @ +-- +-- Additional helpful information: +-- +-- * See "Clash.Prelude.BlockRam#usingrams" for more information on how to use a +-- Block RAM. +-- * Use the adapter 'readNew' for obtaining write-before-read semantics like this: @readNew (blockRamPow2 inits) rd wrM@. +blockRamPow2 + :: (KnownNat n, HiddenClock domain gated, HasCallStack) + => Vec (2^n) a -- ^ Initial content of the BRAM, also + -- determines the size, @2^n@, of the BRAM. + -- + -- __NB__: __MUST__ be a constant. + -> Signal domain (Unsigned n) -- ^ Read address @r@ + -> Signal domain (Maybe (Unsigned n, a)) + -- ^ (write address @w@, value to write) + -> Signal domain a + -- ^ Value of the @blockRAM@ at address @r@ from the previous clock + -- cycle +blockRamPow2 = \cnt rd wrM -> withFrozenCallStack + (hideClock E.blockRamPow2 cnt rd wrM) +{-# INLINE blockRamPow2 #-} + +-- | Create read-after-write blockRAM from a read-before-write one (synchronised to system clock) +-- +-- >>> import Clash.Prelude +-- >>> :t readNew (blockRam (0 :> 1 :> Nil)) +-- readNew (blockRam (0 :> 1 :> Nil)) +-- :: ... +-- ... => +-- Signal domain addr +-- -> Signal domain (Maybe (addr, a)) -> Signal domain a +readNew :: (Eq addr, HiddenClockReset domain gated synchronous) + => (Signal domain addr -> Signal domain (Maybe (addr, a)) -> Signal domain a) + -- ^ The @ram@ component + -> Signal domain addr -- ^ Read address @r@ + -> Signal domain (Maybe (addr, a)) -- ^ (Write address @w@, value to write) + -> Signal domain a + -- ^ Value of the @ram@ at address @r@ from the previous clock + -- cycle +readNew = hideClockReset (\clk rst -> E.readNew rst clk) +{-# INLINE readNew #-} diff --git a/src/Clash/Prelude/BlockRam/File.hs b/src/Clash/Prelude/BlockRam/File.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Prelude/BlockRam/File.hs @@ -0,0 +1,180 @@ +{-| +Copyright : (C) 2015-2016, University of Twente, + 2017 , Myrtle Software Ltd, Google Inc. +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij + += Initialising a BlockRAM with a data file #usingramfiles# + +BlockRAM primitives that can be initialised with a data file. The BNF grammar +for this data file is simple: + +@ +FILE = LINE+ +LINE = BIT+ +BIT = '0' + | '1' +@ + +Consecutive @LINE@s correspond to consecutive memory addresses starting at @0@. +For example, a data file @memory.bin@ containing the 9-bit unsigned number +@7@ to @13@ looks like: + +@ +000000111 +000001000 +000001001 +000001010 +000001011 +000001100 +000001101 +@ + +We can instantiate a BlockRAM using the content of the above file like so: + +@ +f :: HiddenClock domain -> Signal domain (Unsigned 3) -> Signal domain (Unsigned 9) +f rd = 'Clash.Class.BitPack.unpack' '<$>' exposeClock 'blockRamFile' clk d7 \"memory.bin\" rd (signal Nothing) +@ + +In the example above, we basically treat the BlockRAM as an synchronous ROM. +We can see that it works as expected: + +@ +__>>> import qualified Data.List as L__ +__>>> L.tail $ sampleN 4 $ f (fromList [3..5])__ +[10,11,12] +@ + +However, we can also interpret the same data as a tuple of a 6-bit unsigned +number, and a 3-bit signed number: + +@ +g :: HiddenClock domain -> Signal domain (Unsigned 3) -> Signal domain (Unsigned 6,Signed 3) +g clk rd = 'Clash.Class.BitPack.unpack' '<$>' exposeClock 'blockRamFile' clk d7 \"memory.bin\" rd (signal Nothing) +@ + +And then we would see: + +@ +__>>> import qualified Data.List as L__ +__>>> L.tail $ sampleN 4 $ g (fromList [3..5])__ +[(1,2),(1,3)(1,-4)] +@ + +-} + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +{-# LANGUAGE Unsafe #-} + +{-# OPTIONS_HADDOCK show-extensions #-} + +module Clash.Prelude.BlockRam.File + ( -- * BlockRAM synchronised to an arbitrary clock + blockRamFile + , blockRamFilePow2 + ) +where + +import GHC.TypeLits (KnownNat) +import GHC.Stack (HasCallStack, withFrozenCallStack) + + +import qualified Clash.Explicit.BlockRam.File as E +import Clash.Promoted.Nat (SNat) +import Clash.Signal (HiddenClock, Signal, hideClock) +import Clash.Sized.BitVector (BitVector) +import Clash.Sized.Unsigned (Unsigned) + +-- | Create a blockRAM with space for 2^@n@ elements +-- +-- * __NB__: Read value is delayed by 1 cycle +-- * __NB__: Initial output value is 'undefined' +-- * __NB__: This function might not work for specific combinations of +-- code-generation backends and hardware targets. Please check the support table +-- below: +-- +-- @ +-- | VHDL | Verilog | SystemVerilog | +-- ===============+==========+==========+===============+ +-- Altera/Quartus | Broken | Works | Works | +-- Xilinx/ISE | Works | Works | Works | +-- ASIC | Untested | Untested | Untested | +-- ===============+==========+==========+===============+ +-- @ +-- +-- Additional helpful information: +-- +-- * See "Clash.Prelude.BlockRam#usingrams" for more information on how to use a +-- Block RAM. +-- * Use the adapter 'readNew'' for obtaining write-before-read semantics like this: @readNew' clk (blockRamFilePow2' clk file) rd wrM@. +-- * See "Clash.Prelude.BlockRam.File#usingramfiles" for more information on how +-- to instantiate a Block RAM with the contents of a data file. +-- * See "Clash.Sized.Fixed#creatingdatafiles" for ideas on how to create your +-- own data files. +blockRamFilePow2 + :: forall domain gated n m + . (KnownNat m, KnownNat n, HiddenClock domain gated, HasCallStack) + => FilePath + -- ^ File describing the initial content of the blockRAM + -> Signal domain (Unsigned n) + -- ^ Read address @r@ + -> Signal domain (Maybe (Unsigned n, BitVector m)) + -- ^ (write address @w@, value to write) + -> Signal domain (BitVector m) + -- ^ Value of the @blockRAM@ at address @r@ from the previous + -- clock cycle +blockRamFilePow2 = \fp rd wrM -> withFrozenCallStack + (hideClock E.blockRamFilePow2 fp rd wrM) +{-# INLINE blockRamFilePow2 #-} + +-- | Create a blockRAM with space for @n@ elements +-- +-- * __NB__: Read value is delayed by 1 cycle +-- * __NB__: Initial output value is 'undefined' +-- * __NB__: This function might not work for specific combinations of +-- code-generation backends and hardware targets. Please check the support table +-- below: +-- +-- @ +-- | VHDL | Verilog | SystemVerilog | +-- ===============+==========+==========+===============+ +-- Altera/Quartus | Broken | Works | Works | +-- Xilinx/ISE | Works | Works | Works | +-- ASIC | Untested | Untested | Untested | +-- ===============+==========+==========+===============+ +-- @ +-- +-- Additional helpful information: +-- +-- * See "Clash.Prelude.BlockRam#usingrams" for more information on how to use a +-- Block RAM. +-- * Use the adapter 'readNew'' for obtaining write-before-read semantics like this: @readNew' clk (blockRamFile' clk size file) rd wrM@. +-- * See "Clash.Prelude.BlockRam.File#usingramfiles" for more information on how +-- to instantiate a Block RAM with the contents of a data file. +-- * See "Clash.Sized.Fixed#creatingdatafiles" for ideas on how to create your +-- own data files. +blockRamFile + :: (KnownNat m, Enum addr, HiddenClock domain gated, HasCallStack) + => SNat n + -- ^ Size of the blockRAM + -> FilePath + -- ^ File describing the initial content of the blockRAM + -> Signal domain addr + -- ^ Read address @r@ + -> Signal domain (Maybe (addr, BitVector m)) + -- ^ (write address @w@, value to write) + -> Signal domain (BitVector m) + -- ^ Value of the @blockRAM@ at address @r@ from the previous + -- clock cycle +blockRamFile = \sz fp rd wrM -> withFrozenCallStack + (hideClock E.blockRamFile sz fp rd wrM) +{-# INLINE blockRamFile #-} diff --git a/src/Clash/Prelude/DataFlow.hs b/src/Clash/Prelude/DataFlow.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Prelude/DataFlow.hs @@ -0,0 +1,545 @@ +{-| +Copyright : (C) 2013-2016, University of Twente, + 2017 , Google Inc. +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij + +Self-synchronising circuits based on data-flow principles. +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +{-# LANGUAGE Trustworthy #-} + +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} +{-# OPTIONS_HADDOCK show-extensions #-} + +module Clash.Prelude.DataFlow + ( -- * Data types + DataFlow (..) + -- * Creating DataFlow circuits + , liftDF + , pureDF + , mealyDF + , mooreDF + , fifoDF + -- * Composition combinators + , idDF + , seqDF + , firstDF + , swapDF + , secondDF + , parDF + , parNDF + , loopDF + , loopDF_nobuf + -- * Lock-Step operation + , LockStep (..) + ) +where + +import GHC.TypeLits (KnownNat, type (+), type (^)) +import Prelude hiding ((++), (!!), length, map, repeat, tail, unzip3, zip3 + , zipWith) + +import Clash.Class.BitPack (boolToBV) +import Clash.Class.Resize (truncateB) +import Clash.Prelude.BitIndex (msb) +import Clash.Explicit.Mealy (mealyB) +import Clash.Promoted.Nat (SNat) +import Clash.Signal ((.&&.), unbundle) +import Clash.Signal.Bundle (Bundle (..)) +import Clash.Signal.Internal (clockGate, register#) +import Clash.Explicit.Signal (Clock, Reset, Signal) +import Clash.Sized.BitVector (BitVector) +import Clash.Sized.Vector + +{- | Dataflow circuit with bidirectional synchronisation channels. + +In the /forward/ direction we assert /validity/ of the data. In the /backward/ +direction we assert that the circuit is /ready/ to receive new data. A circuit +adhering to the 'DataFlow' type should: + + * Not consume data when validity is deasserted. + * Only update its output when readiness is asserted. + +The 'DataFlow'' type is defined as: + +@ +newtype DataFlow' dom iEn oEn i o + = DF + { df :: 'Signal'' dom i -- Incoming data + -> 'Signal'' dom iEn -- Flagged with /valid/ bits @iEn@. + -> 'Signal'' dom oEn -- Incoming back-pressure, /ready/ edge. + -> ( 'Signal'' dom o -- Outgoing data. + , 'Signal'' dom oEn -- Flagged with /valid/ bits @oEn@. + , 'Signal'' dom iEn -- Outgoing back-pressure, /ready/ edge. + ) + } +@ + +where: + + * @dom@ is the clock to which the circuit is synchronised. + * @iEn@ is the type of the bidirectional incoming synchronisation channel. + * @oEn@ is the type of the bidirectional outgoing synchronisation channel. + * @i@ is the incoming data type. + * @o@ is the outgoing data type. + +We define several composition operators for our 'DataFlow' circuits: + + * 'seqDF' sequential composition. + * 'parDF' parallel composition. + * 'loopDF' add a feedback arc. + * 'lockStep' proceed in lock-step. + +When you look at the types of the above operators it becomes clear why we +parametrise in the types of the synchronisation channels. +-} +newtype DataFlow domain iEn oEn i o + = DF + { -- | Create an ordinary circuit from a 'DataFlow' circuit + df :: Signal domain i -- Incoming data + -> Signal domain iEn -- Flagged with /valid/ bits @iEn@. + -> Signal domain oEn -- Incoming back-pressure, /ready/ edge. + -> ( Signal domain o -- Outgoing data. + , Signal domain oEn -- Flagged with /valid/ bits @oEn@. + , Signal domain iEn -- Outgoing back-pressure, /ready/ edge. + ) + } + +-- | Dataflow circuit synchronised to the 'systemClockGen'. +-- type DataFlow iEn oEn i o = DataFlow' systemClockGen iEn oEn i o + +-- | Create a 'DataFlow' circuit from a circuit description with the appropriate +-- type: +-- +-- @ +-- 'Signal'' dom i -- Incoming data. +-- -> 'Signal'' dom Bool -- Flagged with a single /valid/ bit. +-- -> 'Signal'' dom Bool -- Incoming back-pressure, /ready/ bit. +-- -> ( 'Signal'' dom o -- Outgoing data. +-- , 'Signal'' dom oEn -- Flagged with a single /valid/ bit. +-- , 'Signal'' dom iEn -- Outgoing back-pressure, /ready/ bit. +-- ) +-- @ +-- +-- A circuit adhering to the 'DataFlow' type should: +-- +-- * Not consume data when validity is deasserted. +-- * Only update its output when readiness is asserted. +liftDF :: (Signal dom i -> Signal dom Bool -> Signal dom Bool + -> (Signal dom o, Signal dom Bool, Signal dom Bool)) + -> DataFlow dom Bool Bool i o +liftDF = DF + +-- | Create a 'DataFlow' circuit where the given function @f@ operates on the +-- data, and the synchronisation channels are passed unaltered. +pureDF :: (i -> o) + -> DataFlow dom Bool Bool i o +pureDF f = DF (\i iV oR -> (fmap f i,iV,oR)) + +-- | Create a 'DataFlow' circuit from a Mealy machine description as those of +-- "Clash.Prelude.Mealy" +mealyDF :: Clock domain gated + -> Reset domain synchronous + -> (s -> i -> (s,o)) + -> s + -> DataFlow domain Bool Bool i o +mealyDF clk rst f iS = + DF (\i iV oR -> let en = iV .&&. oR + (s',o) = unbundle (f <$> s <*> i) + s = register# (clockGate clk en) rst iS s' + in (o,iV,oR)) + +-- | Create a 'DataFlow' circuit from a Moore machine description as those of +-- "Clash.Prelude.Moore" +mooreDF :: Clock domain gated + -> Reset domain synchronous + -> (s -> i -> s) + -> (s -> o) + -> s + -> DataFlow domain Bool Bool i o +mooreDF clk rst ft fo iS = + DF (\i iV oR -> let en = iV .&&. oR + s' = ft <$> s <*> i + s = register# (clockGate clk en) rst iS s' + o = fo <$> s + in (o,iV,oR)) + +fifoDF_mealy :: forall addrSize a . KnownNat addrSize + => (Vec (2^addrSize) a, BitVector (addrSize + 1), BitVector (addrSize + 1)) + -> (a, Bool, Bool) + -> ((Vec (2^addrSize) a, BitVector (addrSize + 1), BitVector (addrSize + 1)) + ,(a, Bool, Bool)) +fifoDF_mealy (mem,rptr,wptr) (wdata,winc,rinc) = + let raddr = truncateB rptr :: BitVector addrSize + waddr = truncateB wptr :: BitVector addrSize + + mem' | winc && not full = replace waddr wdata mem + | otherwise = mem + + rdata = mem !! raddr + + rptr' = rptr + boolToBV (rinc && not empty) + wptr' = wptr + boolToBV (winc && not full) + empty = rptr == wptr + full = msb rptr /= msb wptr && raddr == waddr + in ((mem',rptr',wptr'), (rdata,empty,full)) + +-- | Create a FIFO buffer adhering to the 'DataFlow' protocol. Can be filled +-- with initial content. +-- +-- To create a FIFO of size 4, with two initial values 2 and 3 you would write: +-- +-- @ +-- fifo4 = 'fifoDF' d4 (2 :> 3 :> Nil) +-- @ +fifoDF :: forall addrSize m n a domain gated synchronous . + (KnownNat addrSize, KnownNat n, KnownNat m, (m + n) ~ (2 ^ addrSize)) + => Clock domain gated + -> Reset domain synchronous + -> SNat (m + n) -- ^ Depth of the FIFO buffer. Must be a power of two. + -> Vec m a -- ^ Initial content. Can be smaller than the size of the + -- FIFO. Empty spaces are initialised with 'undefined'. + -> DataFlow domain Bool Bool a a +fifoDF clk rst _ iS = DF $ \i iV oR -> + let initRdPtr = 0 + initWrPtr = fromIntegral (length iS) + initMem = iS ++ repeat undefined :: Vec (m + n) a + initS = (initMem,initRdPtr,initWrPtr) + (o,empty,full) = mealyB clk rst fifoDF_mealy initS (i,iV,oR) + in (o,not <$> empty, not <$> full) + +-- | Identity circuit +-- +-- <> +idDF :: DataFlow dom en en a a +idDF = DF (\a val rdy -> (a,val,rdy)) + +-- | Sequential composition of two 'DataFlow' circuits. +-- +-- <> +seqDF :: DataFlow dom aEn bEn a b + -> DataFlow dom bEn cEn b c + -> DataFlow dom aEn cEn a c +(DF f) `seqDF` (DF g) = DF (\a aVal cRdy -> let (b,bVal,aRdy) = f a aVal bRdy + (c,cVal,bRdy) = g b bVal cRdy + in (c,cVal,aRdy)) + +-- | Apply the circuit to the first halve of the communication channels, leave +-- the second halve unchanged. +-- +-- <> +firstDF :: DataFlow dom aEn bEn a b + -> DataFlow dom (aEn,cEn) (bEn,cEn) (a,c) (b,c) +firstDF (DF f) = DF (\ac acV bcR -> let (a,c) = unbundle ac + (aV,cV) = unbundle acV + (bR,cR) = unbundle bcR + (b,bV,aR) = f a aV bR + bc = bundle (b,c) + bcV = bundle (bV,cV) + acR = bundle (aR,cR) + in (bc,bcV,acR) + ) + +-- | Swap the two communication channels. +-- +-- <> +swapDF :: DataFlow dom (aEn,bEn) (bEn,aEn) (a,b) (b,a) +swapDF = DF (\ab abV baR -> (swap <$> ab, swap <$> abV, swap <$> baR)) + where + swap ~(a,b) = (b,a) + +-- | Apply the circuit to the second halve of the communication channels, leave +-- the first halve unchanged. +-- +-- <> +secondDF :: DataFlow dom aEn bEn a b + -> DataFlow dom (cEn,aEn) (cEn,bEn) (c,a) (c,b) +secondDF f = swapDF `seqDF` firstDF f `seqDF` swapDF + +-- | Compose two 'DataFlow' circuits in parallel. +-- +-- <> +parDF :: DataFlow dom aEn bEn a b + -> DataFlow dom cEn dEn c d + -> DataFlow dom (aEn,cEn) (bEn,dEn) (a,c) (b,d) +f `parDF` g = firstDF f `seqDF` secondDF g + +-- | Compose /n/ 'DataFlow' circuits in parallel. +parNDF :: KnownNat n + => Vec n (DataFlow dom aEn bEn a b) + -> DataFlow dom + (Vec n aEn) + (Vec n bEn) + (Vec n a) + (Vec n b) +parNDF fs = + DF (\as aVs bRs -> + let as' = unbundle as + aVs' = unbundle aVs + bRs' = unbundle bRs + (bs,bVs,aRs) = unzip3 (zipWith (\k (a,b,r) -> df k a b r) fs + (zip3 (lazyV as') (lazyV aVs') bRs')) + in (bundle bs,bundle bVs, bundle aRs) + ) + +-- | Feed back the second halve of the communication channel. The feedback loop +-- is buffered by a 'fifoDF' circuit. +-- +-- So given a circuit /h/ with two synchronisation channels: +-- +-- @ +-- __h__ :: 'DataFlow' (Bool,Bool) (Bool,Bool) (a,d) (b,d) +-- @ +-- +-- Feeding back the /d/ part (including its synchronisation channels) results +-- in: +-- +-- @ +-- 'loopDF' d4 Nil h +-- @ +-- +-- <> +-- +-- When you have a circuit @h'@, with only a single synchronisation channel: +-- +-- @ +-- __h'__ :: 'DataFlow' Bool Bool (a,d) (b,d) +-- @ +-- +-- and you want to compose /h'/ in a feedback loop, the following will not work: +-- +-- @ +-- f \`@'seqDF'@\` ('loopDF' d4 Nil h') \`@'seqDF'@\` g +-- @ +-- +-- The circuits @f@, @h@, and @g@, must operate in /lock-step/ because the /h'/ +-- circuit only has a single synchronisation channel. Consequently, there +-- should only be progress when all three circuits are producing /valid/ data +-- and all three circuits are /ready/ to receive new data. We need to compose +-- /h'/ with the 'lockStep' and 'stepLock' functions to achieve the /lock-step/ +-- operation. +-- +-- @ +-- f \`@'seqDF'@\` ('lockStep' \`@'seqDF'@\` 'loopDF' d4 Nil h' \`@'seqDF'@\` 'stepLock') \`@'seqDF'@\` g +-- @ +-- +-- <> +loopDF :: (KnownNat m, KnownNat n, KnownNat addrSize, (m+n) ~ (2^addrSize)) + => Clock dom gated + -> Reset dom synchronous + -> SNat (m + n) -- ^ Depth of the FIFO buffer. Must be a power of two + -> Vec m d -- ^ Initial content of the FIFO buffer. Can be smaller than + -- the size of the FIFO. Empty spaces are initialised with + -- 'undefined'. + -> DataFlow dom (Bool,Bool) (Bool,Bool) (a,d) (b,d) + -> DataFlow dom Bool Bool a b +loopDF clk rst sz is (DF f) = + DF (\a aV bR -> let (bd,bdV,adR) = f ad adV bdR + (b,d) = unbundle bd + (bV,dV) = unbundle bdV + (aR,dR) = unbundle adR + (d_buf,dV_buf,dR_buf) = df (fifoDF clk rst sz is) d dV dR + + ad = bundle (a,d_buf) + adV = bundle (aV,dV_buf) + bdR = bundle (bR,dR_buf) + in (b,bV,aR) + ) + +-- | Feed back the second halve of the communication channel. Unlike 'loopDF', +-- the feedback loop is /not/ buffered. +loopDF_nobuf :: DataFlow dom (Bool,Bool) (Bool,Bool) (a,d) (b,d) + -> DataFlow dom Bool Bool a b +loopDF_nobuf (DF f) = DF (\a aV bR -> let (bd,bdV,adR) = f ad adV bdR + (b,d) = unbundle bd + (bV,dV) = unbundle bdV + (aR,dR) = unbundle adR + ad = bundle (a,d) + adV = bundle (aV,dV) + bdR = bundle (bR,dR) + in (b,bV,aR) + ) + +-- | Reduce or extend the synchronisation granularity of parallel compositions. +class LockStep a b where + -- | Reduce the synchronisation granularity to a single 'Bool'ean value. + -- + -- Given: + -- + -- @ + -- __f__ :: 'DataFlow' Bool Bool a b + -- __g__ :: 'DataFlow' Bool Bool c d + -- __h__ :: 'DataFlow' Bool Bool (b,d) (p,q) + -- @ + -- + -- We /cannot/ simply write: + -- + -- @ + -- (f \`@'parDF'@\` g) \`@'seqDF'@\` h + -- @ + -- + -- because, @f \`parDF\` g@, has type, @'DataFlow' (Bool,Bool) (Bool,Bool) (a,c) (b,d)@, + -- which does not match the expected synchronisation granularity of @h@. We + -- need a circuit in between that has the type: + -- + -- @ + -- 'DataFlow' (Bool,Bool) Bool (b,d) (b,d) + -- @ + -- + -- Simply '&&'-ing the /valid/ signals in the forward direction, and + -- duplicating the /ready/ signal in the backward direction is however not + -- enough. We also need to make sure that @f@ does not update its output when + -- @g@'s output is invalid and visa versa, as @h@ can only consume its input + -- when both @f@ and @g@ are producing valid data. @g@'s /ready/ port is hence + -- only asserted when @h@ is ready and @f@ is producing /valid/ data. And @f@'s + -- ready port is only asserted when @h@ is ready and @g@ is producing valid + -- data. @f@ and @g@ will hence be proceeding in /lock-step/. + -- + -- The 'lockStep' function ensures that all synchronisation signals are + -- properly connected: + -- + -- @ + -- (f \`@'parDF'@\` g) \`@'seqDF'@\` 'lockStep' \`@'seqDF'@\` h + -- @ + -- + -- <> + -- + -- __Note 1__: ensure that the components that you are synchronising have + -- buffered/delayed @ready@ and @valid@ signals, or 'lockStep' has the + -- potential to introduce combinational loops. You can do this by placing + -- 'fifoDF's on the parallel channels. Extending the above example, you would + -- write: + -- + -- @ + -- ((f \`@'seqDF'@\` 'fifoDF' d4 Nil) \`@'parDF'@\` (g \`@'seqDF'@\` 'fifoDF' d4 Nil)) \`@'seqDF'@\` 'lockStep' \`@'seqDF'@\` h + -- @ + -- + -- __Note 2__: 'lockStep' works for arbitrarily nested tuples. That is: + -- + -- @ + -- p :: 'DataFlow' Bool Bool ((b,d),d) z + -- + -- q :: 'DataFlow' ((Bool,Bool),Bool) ((Bool,Bool),Bool) ((a,c),c) ((b,d),d) + -- q = f \`@'parDF'@\` g \`@'parDF'@\` g + -- + -- r = q \`@'seqDF'@\` 'lockStep' \`@'seqDF'@\` p + -- @ + -- + -- Does the right thing. + lockStep :: DataFlow dom a Bool b b + + -- | Extend the synchronisation granularity from a single 'Bool'ean value. + -- + -- Given: + -- + -- @ + -- __f__ :: 'DataFlow' Bool Bool a b + -- __g__ :: 'DataFlow' Bool Bool c d + -- __h__ :: 'DataFlow' Bool Bool (p,q) (a,c) + -- @ + -- + -- We /cannot/ simply write: + -- + -- @ + -- h \`@'seqDF'@\` (f \`@'parDF'@\` g) + -- @ + -- + -- because, @f \`parDF\` g@, has type, @'DataFlow' (Bool,Bool) (Bool,Bool) (a,c) (b,d)@, + -- which does not match the expected synchronisation granularity of @h@. We + -- need a circuit in between that has the type: + -- + -- @ + -- 'DataFlow' Bool (Bool,Bool) (a,c) (a,c) + -- @ + -- + -- Simply '&&'-ing the /ready/ signals in the backward direction, and + -- duplicating the /valid/ signal in the forward direction is however not + -- enough. We need to make sure that @f@ does not consume values when @g@ is + -- not /ready/ and visa versa, because @h@ cannot update the values of its + -- output tuple independently. @f@'s /valid/ port is hence only asserted when + -- @h@ is valid and @g@ is ready to receive new values. @g@'s /valid/ port is + -- only asserted when @h@ is valid and @f@ is ready to receive new values. + -- @f@ and @g@ will hence be proceeding in /lock-step/. + -- + -- The 'stepLock' function ensures that all synchronisation signals are + -- properly connected: + -- + -- @ + -- h \`@'seqDF'@\` 'stepLock' \`@'seqDF'@\` (f \`@'parDF'@\` g) + -- @ + -- + -- <> + -- + -- __Note 1__: ensure that the components that you are synchronising have + -- buffered/delayed @ready@ and @valid@ signals, or 'stepLock' has the + -- potential to introduce combinational loops. You can do this by placing + -- 'fifoDF's on the parallel channels. Extending the above example, you would + -- write: + -- + -- @ + -- h \`@'seqDF'@\` 'stepLock' \`@'seqDF'@\` ((`fifoDF` d4 Nil \`@'seqDF'@\` f) \`@'parDF'@\` (`fifoDF` d4 Nil \`@'seqDF'@\` g)) + -- @ + -- + -- __Note 2__: 'stepLock' works for arbitrarily nested tuples. That is: + -- + -- @ + -- p :: 'DataFlow' Bool Bool z ((a,c),c) + -- + -- q :: 'DataFlow' ((Bool,Bool),Bool) ((Bool,Bool),Bool) ((a,c),c) ((b,d),d) + -- q = f \`@'parDF'@\` g \`@'parDF'@\` g + -- + -- r = p \`@'seqDF'@\` 'stepLock' \`@'seqDF'@\` q + -- @ + -- + -- Does the right thing. + stepLock :: DataFlow dom Bool a b b + +instance LockStep Bool c where + lockStep = idDF + stepLock = idDF + +instance (LockStep a x, LockStep b y) => LockStep (a,b) (x,y) where + lockStep = (lockStep `parDF` lockStep) `seqDF` + (DF (\xy xyV rdy -> let (xV,yV) = unbundle xyV + val = xV .&&. yV + xR = yV .&&. rdy + yR = xV .&&. rdy + xyR = bundle (xR,yR) + in (xy,val,xyR))) + + stepLock = (DF (\xy val xyR -> let (xR,yR) = unbundle xyR + rdy = xR .&&. yR + xV = val .&&. yR + yV = val .&&. xR + xyV = bundle (xV,yV) + in (xy,xyV,rdy))) `seqDF` (stepLock `parDF` stepLock) + +instance (LockStep en a, KnownNat n) => LockStep (Vec n en) (Vec n a) where + lockStep = parNDF (repeat lockStep) `seqDF` + DF (\xs vals rdy -> + let val = (and . (True :>)) <$> vals + rdys = allReady <$> rdy <*> (repeat . (:< True) <$> vals) + in (xs,val,rdys) + ) + stepLock = + DF (\xs val rdys -> + let rdy = (and . (True :>)) <$> rdys + vals = allReady <$> val <*> (repeat . (:< True) <$> rdys) + in (xs,vals,rdy) + ) `seqDF` parNDF (repeat stepLock) + +allReady :: KnownNat n + => Bool + -> Vec n (Vec (n+1) Bool) + -> Vec n Bool +allReady b vs = map (and . (b :>) . tail) (smap (flip rotateLeftS) vs) diff --git a/src/Clash/Prelude/Mealy.hs b/src/Clash/Prelude/Mealy.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Prelude/Mealy.hs @@ -0,0 +1,130 @@ +{-| + Copyright : (C) 2013-2016, University of Twente, + 2017 , Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Whereas the output of a Moore machine depends on the /previous state/, the + output of a Mealy machine depends on /current transition/. + + Mealy machines are strictly more expressive, but may impose stricter timing + requirements. +-} + +{-# LANGUAGE FlexibleContexts #-} + +{-# LANGUAGE Safe #-} + +module Clash.Prelude.Mealy + ( -- * Mealy machine synchronised to the system clock + mealy + , mealyB + , (<^>) + ) +where + +import qualified Clash.Explicit.Mealy as E +import Clash.Signal + +{- $setup +>>> :set -XDataKinds -XTypeApplications +>>> import Clash.Prelude +>>> :{ +let macT s (x,y) = (s',s) + where + s' = x * y + s + mac = mealy macT 0 +:} + +-} + +-- | Create a synchronous function from a combinational function describing +-- a mealy machine +-- +-- @ +-- macT +-- :: Int -- Current state +-- -> (Int,Int) -- Input +-- -> (Int,Int) -- (Updated state, output) +-- macT s (x,y) = (s',s) +-- where +-- s' = x * y + s +-- +-- mac :: HiddenClockReset domain gated synchronous => 'Signal' domain (Int, Int) -> 'Signal' domain Int +-- mac = 'mealy' macT 0 +-- @ +-- +-- >>> simulate mac [(1,1),(2,2),(3,3),(4,4)] +-- [0,1,5,14... +-- ... +-- +-- Synchronous sequential functions can be composed just like their +-- combinational counterpart: +-- +-- @ +-- dualMac +-- :: HiddenClockReset domain gated synchronous +-- => ('Signal' domain Int, 'Signal' domain Int) +-- -> ('Signal' domain Int, 'Signal' domain Int) +-- -> 'Signal' domain Int +-- dualMac (a,b) (x,y) = s1 + s2 +-- where +-- s1 = 'mealy' mac 0 ('Clash.Signal.bundle' (a,x)) +-- s2 = 'mealy' mac 0 ('Clash.Signal.bundle' (b,y)) +-- @ +mealy :: HiddenClockReset domain gated synchronous + => (s -> i -> (s,o)) -- ^ Transfer function in mealy machine form: + -- @state -> input -> (newstate,output)@ + -> s -- ^ Initial state + -> (Signal domain i -> Signal domain o) + -- ^ Synchronous sequential function with input and output matching that + -- of the mealy machine +mealy = hideClockReset E.mealy +{-# INLINE mealy #-} + +-- | A version of 'mealy' that does automatic 'Bundle'ing +-- +-- Given a function @f@ of type: +-- +-- @ +-- __f__ :: Int -> (Bool, Int) -> (Int, (Int, Bool)) +-- @ +-- +-- When we want to make compositions of @f@ in @g@ using 'mealy', we have to +-- write: +-- +-- @ +-- g a b c = (b1,b2,i2) +-- where +-- (i1,b1) = 'Clash.Signal.unbundle' ('mealy' f 0 ('Clash.Signal.bundle' (a,b))) +-- (i2,b2) = 'Clash.Signal.unbundle' ('mealy' f 3 ('Clash.Signal.bundle' (i1,c))) +-- @ +-- +-- Using 'mealyB' however we can write: +-- +-- @ +-- g a b c = (b1,b2,i2) +-- where +-- (i1,b1) = 'mealyB' f 0 (a,b) +-- (i2,b2) = 'mealyB' f 3 (i1,c) +-- @ +mealyB :: (Bundle i, Bundle o, HiddenClockReset domain gated synchronous) + => (s -> i -> (s,o)) -- ^ Transfer function in mealy machine form: + -- @state -> input -> (newstate,output)@ + -> s -- ^ Initial state + -> (Unbundled domain i -> Unbundled domain o) + -- ^ Synchronous sequential function with input and output matching that + -- of the mealy machine +mealyB = hideClockReset E.mealyB +{-# INLINE mealyB #-} + +-- | Infix version of 'mealyB' +(<^>) :: (Bundle i, Bundle o, HiddenClockReset domain gated synchronous) + => (s -> i -> (s,o)) -- ^ Transfer function in mealy machine form: + -- @state -> input -> (newstate,output)@ + -> s -- ^ Initial state + -> (Unbundled domain i -> Unbundled domain o) + -- ^ Synchronous sequential function with input and output matching that + -- of the mealy machine +(<^>) = mealyB +{-# INLINE (<^>) #-} diff --git a/src/Clash/Prelude/Moore.hs b/src/Clash/Prelude/Moore.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Prelude/Moore.hs @@ -0,0 +1,143 @@ +{-| + Copyright : (C) 2013-2016, University of Twente + 2017 , Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Whereas the output of a Mealy machine depends on /current transition/, the + output of a Moore machine depends on the /previous state/. + + Moore machines are strictly less expressive, but may impose laxer timing + requirements. +-} + +{-# LANGUAGE FlexibleContexts #-} + +{-# LANGUAGE Safe #-} + +module Clash.Prelude.Moore + ( -- * Moore machine + moore + , mooreB + , medvedev + , medvedevB + ) +where + +import qualified Clash.Explicit.Moore as E +import Clash.Signal + +{- $setup +>>> :set -XDataKinds -XTypeApplications +>>> import Clash.Prelude +>>> :{ +let macT s (x,y) = x * y + s + mac = moore macT id 0 +:} + +-} + + +-- | Create a synchronous function from a combinational function describing +-- a moore machine +-- +-- @ +-- macT :: Int -- Current state +-- -> (Int,Int) -- Input +-- -> Int -- Updated state +-- macT s (x,y) = x * y + s +-- +-- mac :: HiddenClockReset domain gated synchronous => 'Signal' domain (Int, Int) -> 'Signal' domain Int +-- mac = 'moore' mac id 0 +-- @ +-- +-- >>> simulate mac [(1,1),(2,2),(3,3),(4,4)] +-- [0,1,5,14... +-- ... +-- +-- Synchronous sequential functions can be composed just like their +-- combinational counterpart: +-- +-- @ +-- dualMac +-- :: HiddenClockReset domain gated synchronous +-- => ('Signal' domain Int, 'Signal' domain Int) +-- -> ('Signal' domain Int, 'Signal' domain Int) +-- -> 'Signal' domain Int +-- dualMac (a,b) (x,y) = s1 + s2 +-- where +-- s1 = 'moore' mac id 0 ('Clash.Signal.bundle' (a,x)) +-- s2 = 'moore' mac id 0 ('Clash.Signal.bundle' (b,y)) +-- @ +moore + :: HiddenClockReset domain gated synchronous + => (s -> i -> s) -- ^ Transfer function in moore machine form: + -- @state -> input -> newstate@ + -> (s -> o) -- ^ Output function in moore machine form: + -- @state -> output@ + -> s -- ^ Initial state + -> (Signal domain i -> Signal domain o) + -- ^ Synchronous sequential function with input and output matching that + -- of the moore machine +moore = hideClockReset E.moore +{-# INLINE moore #-} + + +-- | Create a synchronous function from a combinational function describing +-- a moore machine without any output logic +medvedev + :: HiddenClockReset domain gated synchronous + => (s -> i -> s) + -> s + -> (Signal domain i -> Signal domain s) +medvedev tr st = moore tr id st +{-# INLINE medvedev #-} + +-- | A version of 'moore' that does automatic 'Bundle'ing +-- +-- Given a functions @t@ and @o@ of types: +-- +-- @ +-- __t__ :: Int -> (Bool, Int) -> Int +-- __o__ :: Int -> (Int, Bool) +-- @ +-- +-- When we want to make compositions of @t@ and @o@ in @g@ using 'moore', we have to +-- write: +-- +-- @ +-- g a b c = (b1,b2,i2) +-- where +-- (i1,b1) = 'Clash.Signal.unbundle' ('moore' t o 0 ('Clash.Signal.bundle' (a,b))) +-- (i2,b2) = 'Clash.Signal.unbundle' ('moore' t o 3 ('Clash.Signal.bundle' (i1,c))) +-- @ +-- +-- Using 'mooreB' however we can write: +-- +-- @ +-- g a b c = (b1,b2,i2) +-- where +-- (i1,b1) = 'mooreB' t o 0 (a,b) +-- (i2,b2) = 'mooreB' t o 3 (i1,c) +-- @ +mooreB + :: (Bundle i, Bundle o,HiddenClockReset domain gated synchronous) + => (s -> i -> s) -- ^ Transfer function in moore machine form: + -- @state -> input -> newstate@ + -> (s -> o) -- ^ Output function in moore machine form: + -- @state -> output@ + -> s -- ^ Initial state + -> (Unbundled domain i -> Unbundled domain o) + -- ^ Synchronous sequential function with input and output matching that + -- of the moore machine +mooreB = hideClockReset E.mooreB +{-# INLINE mooreB #-} + +-- | A version of 'medvedev' that does automatic 'Bundle'ing +medvedevB + :: (Bundle i, Bundle s, HiddenClockReset domain gated synchronous) + => (s -> i -> s) + -> s + -> (Unbundled domain i -> Unbundled domain s) +medvedevB tr st = mooreB tr id st +{-# INLINE medvedevB #-} diff --git a/src/Clash/Prelude/RAM.hs b/src/Clash/Prelude/RAM.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Prelude/RAM.hs @@ -0,0 +1,80 @@ +{-| +Copyright : (C) 2015-2016, University of Twente, + 2017 , Myrtle Software Ltd, Google Inc. +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij + +RAM primitives with a combinational read port. +-} + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +{-# LANGUAGE Safe #-} + +{-# OPTIONS_HADDOCK show-extensions #-} + +module Clash.Prelude.RAM + ( -- * RAM synchronised to an arbitrary clock + asyncRam + , asyncRamPow2 + ) +where + +import GHC.TypeLits (KnownNat) +import GHC.Stack (HasCallStack, withFrozenCallStack) + +import qualified Clash.Explicit.RAM as E +import Clash.Promoted.Nat (SNat) +import Clash.Signal +import Clash.Sized.Unsigned (Unsigned) + + +-- | Create a RAM with space for @n@ elements. +-- +-- * __NB__: Initial content of the RAM is 'undefined' +-- +-- Additional helpful information: +-- +-- * See "Clash.Prelude.BlockRam#usingrams" for more information on how to use a +-- RAM. +asyncRam + :: (Enum addr, HiddenClock domain gated, HasCallStack) + => SNat n + -- ^ Size @n@ of the RAM + -> Signal domain addr + -- ^ Read address @r@ + -> Signal domain (Maybe (addr, a)) + -- ^ (write address @w@, value to write) + -> Signal domain a + -- ^ Value of the @RAM@ at address @r@ +asyncRam = \sz rd wrM -> withFrozenCallStack + (hideClock (\clk -> E.asyncRam clk clk sz rd wrM)) +{-# INLINE asyncRam #-} + +-- | Create a RAM with space for 2^@n@ elements +-- +-- * __NB__: Initial content of the RAM is 'undefined' +-- +-- Additional helpful information: +-- +-- * See "Clash.Prelude.BlockRam#usingrams" for more information on how to use a +-- RAM. +asyncRamPow2 + :: (KnownNat n, HiddenClock domain gated, HasCallStack) + => Signal domain (Unsigned n) + -- ^ Read address @r@ + -> Signal domain (Maybe (Unsigned n, a)) + -- ^ (write address @w@, value to write) + -> Signal domain a + -- ^ Value of the @RAM@ at address @r@ +asyncRamPow2 = \rd wrM -> withFrozenCallStack + (hideClock (\clk -> E.asyncRamPow2 clk clk rd wrM)) +{-# INLINE asyncRamPow2 #-} diff --git a/src/Clash/Prelude/ROM.hs b/src/Clash/Prelude/ROM.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Prelude/ROM.hs @@ -0,0 +1,120 @@ +{-| +Copyright : (C) 2015-2016, University of Twente, + 2017 , Google Inc. +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij + +ROMs +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeOperators #-} + +{-# LANGUAGE Safe #-} + +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} +{-# OPTIONS_HADDOCK show-extensions #-} + +module Clash.Prelude.ROM + ( -- * Asynchronous ROM + asyncRom + , asyncRomPow2 + -- * Synchronous ROM synchronised to an arbitrary clock + , rom + , romPow2 + -- * Internal + , asyncRom# + ) +where + +import Data.Array ((!),listArray) +import GHC.TypeLits (KnownNat, type (^)) +import Prelude hiding (length) + +import qualified Clash.Explicit.ROM as E +import Clash.Signal +import Clash.Sized.Unsigned (Unsigned) +import Clash.Sized.Vector (Vec, length, toList) + +-- | An asynchronous/combinational ROM with space for @n@ elements +-- +-- Additional helpful information: +-- +-- * See "Clash.Sized.Fixed#creatingdatafiles" and "Clash.Prelude.BlockRam#usingrams" +-- for ideas on how to use ROMs and RAMs +asyncRom :: (KnownNat n, Enum addr) + => Vec n a -- ^ ROM content + -- + -- __NB:__ must be a constant + -> addr -- ^ Read address @rd@ + -> a -- ^ The value of the ROM at address @rd@ +asyncRom = \content rd -> asyncRom# content (fromEnum rd) +{-# INLINE asyncRom #-} + +-- | An asynchronous/combinational ROM with space for 2^@n@ elements +-- +-- Additional helpful information: +-- +-- * See "Clash.Sized.Fixed#creatingdatafiles" and "Clash.Prelude.BlockRam#usingrams" +-- for ideas on how to use ROMs and RAMs +asyncRomPow2 :: KnownNat n + => Vec (2^n) a -- ^ ROM content + -- + -- __NB:__ must be a constant + -> Unsigned n -- ^ Read address @rd@ + -> a -- ^ The value of the ROM at address @rd@ +asyncRomPow2 = asyncRom +{-# INLINE asyncRomPow2 #-} + +-- | asyncROM primitive +asyncRom# :: KnownNat n + => Vec n a -- ^ ROM content + -- + -- __NB:__ must be a constant + -> Int -- ^ Read address @rd@ + -> a -- ^ The value of the ROM at address @rd@ +asyncRom# content rd = arr ! rd + where + szI = length content + arr = listArray (0,szI-1) (toList content) +{-# NOINLINE asyncRom# #-} + +-- | A ROM with a synchronous read port, with space for @n@ elements +-- +-- * __NB__: Read value is delayed by 1 cycle +-- * __NB__: Initial output value is 'undefined' +-- +-- Additional helpful information: +-- +-- * See "Clash.Sized.Fixed#creatingdatafiles" and "Clash.Prelude.BlockRam#usingrams" +-- for ideas on how to use ROMs and RAMs +rom + :: (KnownNat n, KnownNat m, HiddenClock domain gated) + => Vec n a -- ^ ROM content + -- + -- __NB:__ must be a constant + -> Signal domain (Unsigned m) -- ^ Read address @rd@ + -> Signal domain a -- ^ The value of the ROM at address @rd@ +rom = hideClock E.rom +{-# INLINE rom #-} + +-- | A ROM with a synchronous read port, with space for 2^@n@ elements +-- +-- * __NB__: Read value is delayed by 1 cycle +-- * __NB__: Initial output value is 'undefined' +-- +-- Additional helpful information: +-- +-- * See "Clash.Sized.Fixed#creatingdatafiles" and "Clash.Prelude.BlockRam#usingrams" +-- for ideas on how to use ROMs and RAMs +romPow2 + :: (KnownNat n, HiddenClock domain gated) + => Vec (2^n) a -- ^ ROM content + -- + -- __NB:__ must be a constant + -> Signal domain (Unsigned n) -- ^ Read address @rd@ + -> Signal domain a -- ^ The value of the ROM at address @rd@ +romPow2 = hideClock E.romPow2 +{-# INLINE romPow2 #-} diff --git a/src/Clash/Prelude/ROM/File.hs b/src/Clash/Prelude/ROM/File.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Prelude/ROM/File.hs @@ -0,0 +1,301 @@ +{-| +Copyright : (C) 2015-2016, University of Twente, + 2017 , Google Inc. +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij + += Initialising a ROM with a data file #usingromfiles# + +ROMs initialised with a data file. The BNF grammar for this data file is simple: + +@ +FILE = LINE+ +LINE = BIT+ +BIT = '0' + | '1' +@ + +Consecutive @LINE@s correspond to consecutive memory addresses starting at @0@. +For example, a data file @memory.bin@ containing the 9-bit unsigned number +@7@ to @13@ looks like: + +@ +000000111 +000001000 +000001001 +000001010 +000001011 +000001100 +000001101 +@ + +We can instantiate a synchronous ROM using the content of the above file like +so: + +@ +f :: HiddenClock domain => Signal domain (Unsigned 3) -> Signal domain (Unsigned 9) +f rd = 'Clash.Class.BitPack.unpack' '<$>' 'romFile' d7 \"memory.bin\" rd +@ + +And see that it works as expected: + +@ +__>>> import qualified Data.List as L__ +__>>> L.tail $ sampleN 4 $ f (fromList [3..5])__ +[10,11,12] +@ + +However, we can also interpret the same data as a tuple of a 6-bit unsigned +number, and a 3-bit signed number: + +@ +g :: HiddenClock domain => Signal domain (Unsigned 3) -> Signal domain (Unsigned 6,Signed 3) +g rd = 'Clash.Class.BitPack.unpack' '<$>' 'romFile' d7 \"memory.bin\" rd +@ + +And then we would see: + +@ +__>>> import qualified Data.List as L__ +__>>> L.tail $ sampleN 4 $ g (fromList [3..5])__ +[(1,2),(1,3)(1,-4)] +@ +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +{-# LANGUAGE Unsafe #-} + +{-# OPTIONS_HADDOCK show-extensions #-} + +module Clash.Prelude.ROM.File + ( -- * Asynchronous ROM + asyncRomFile + , asyncRomFilePow2 + -- * Synchronous ROM synchronised to an arbitrary clock + , romFile + , romFilePow2 + -- * Internal + , asyncRomFile# + ) +where + +import Data.Array (listArray,(!)) +import GHC.TypeLits (KnownNat) +import System.IO.Unsafe (unsafePerformIO) + +import Clash.Explicit.BlockRam.File (initMem) +import qualified Clash.Explicit.ROM.File as E +import Clash.Promoted.Nat (SNat (..), pow2SNat, snatToNum) +import Clash.Signal +import Clash.Sized.BitVector (BitVector) +import Clash.Sized.Unsigned (Unsigned) + +-- | An asynchronous/combinational ROM with space for @n@ elements +-- +-- * __NB__: This function might not work for specific combinations of +-- code-generation backends and hardware targets. Please check the support table +-- below: +-- +-- @ +-- | VHDL | Verilog | SystemVerilog | +-- ===============+==========+==========+===============+ +-- Altera/Quartus | Broken | Works | Works | +-- Xilinx/ISE | Works | Works | Works | +-- ASIC | Untested | Untested | Untested | +-- ===============+==========+==========+===============+ +-- @ +-- +-- Additional helpful information: +-- +-- * See "Clash.Prelude.ROM.File#usingromfiles" for more information on how +-- to instantiate a ROM with the contents of a data file. +-- * See "Clash.Sized.Fixed#creatingdatafiles" for ideas on how to create your +-- own data files. +-- * When you notice that 'asyncRomFile' is significantly slowing down your +-- simulation, give it a /monomorphic/ type signature. So instead of leaving +-- the type to be inferred: +-- +-- @ +-- myRomData = asyncRomFile d512 "memory.bin" +-- @ +-- +-- or giving it a /polymorphic/ type signature: +-- +-- @ +-- myRomData :: Enum addr => addr -> BitVector 16 +-- myRomData = asyncRomFile d512 "memory.bin" +-- @ +-- +-- you __should__ give it a /monomorphic/ type signature: +-- +-- @ +-- myRomData :: Unsigned 9 -> BitVector 16 +-- myRomData = asyncRomFile d512 "memory.bin" +-- @ +asyncRomFile + :: (KnownNat m, Enum addr) + => SNat n -- ^ Size of the ROM + -> FilePath -- ^ File describing the content of the ROM + -> addr -- ^ Read address @rd@ + -> BitVector m -- ^ The value of the ROM at address @rd@ +asyncRomFile sz file = asyncRomFile# sz file . fromEnum +-- Leave 'asyncRom' eta-reduced, see Note [Eta-reduction and unsafePerformIO initMem] +{-# INLINE asyncRomFile #-} + +-- Note [Eta-reduction and unsafePerformIO initMem] +-- +-- The 'initMem' function initializes a @[BitVector n]@ from file. Ideally, +-- we want this IO action to happen only once. When we call 'unsafePerformIO' +-- on @initMem file@, it becomes a thunk in that function, so is hence evaluated +-- only once. However, me must ensure that any code calling using of the +-- @unsafePerformIO (initMem file)@ thunk also becomes a thunk. We do this by +-- eta-reducing function where needed so that a thunk is returned. +-- +-- For example, instead of writing: +-- +-- > asyncRomFile# sz file rd = (content ! rd) +-- > where +-- > mem = unsafePerformIO (initMem file) +-- > content = listArray (0,szI-1) mem +-- > szI = snatToNum sz +-- +-- We write: +-- +-- > asyncRomFile# sz file = (content !) +-- > where +-- > mem = unsafePerformIO (initMem file) +-- > content = listArray (0,szI-1) mem +-- > szI = snatToNum sz +-- +-- Where instead of returning the BitVector defined by @(content ! rd)@, we +-- return the function (thunk) @(content !)@. + +-- | An asynchronous/combinational ROM with space for 2^@n@ elements +-- +-- * __NB__: This function might not work for specific combinations of +-- code-generation backends and hardware targets. Please check the support table +-- below: +-- +-- @ +-- | VHDL | Verilog | SystemVerilog | +-- ===============+==========+==========+===============+ +-- Altera/Quartus | Broken | Works | Works | +-- Xilinx/ISE | Works | Works | Works | +-- ASIC | Untested | Untested | Untested | +-- ===============+==========+==========+===============+ +-- @ +-- +-- Additional helpful information: +-- +-- * See "Clash.Prelude.ROM.File#usingromfiles" for more information on how +-- to instantiate a ROM with the contents of a data file. +-- * See "Clash.Sized.Fixed#creatingdatafiles" for ideas on how to create your +-- own data files. +-- * When you notice that 'asyncRomFilePow2' is significantly slowing down your +-- simulation, give it a /monomorphic/ type signature. So instead of leaving the +-- type to be inferred: +-- +-- @ +-- myRomData = asyncRomFilePow2 "memory.bin" +-- @ +-- +-- you __should__ give it a /monomorphic/ type signature: +-- +-- @ +-- myRomData :: Unsigned 9 -> BitVector 16 +-- myRomData = asyncRomFilePow2 "memory.bin" +-- @ +asyncRomFilePow2 + :: forall n m + . (KnownNat m, KnownNat n) + => FilePath -- ^ File describing the content of the ROM + -> Unsigned n -- ^ Read address @rd@ + -> BitVector m -- ^ The value of the ROM at address @rd@ +asyncRomFilePow2 = asyncRomFile (pow2SNat (SNat @ n)) +{-# INLINE asyncRomFilePow2 #-} + +-- | asyncROMFile primitive +asyncRomFile# + :: KnownNat m + => SNat n -- ^ Size of the ROM + -> FilePath -- ^ File describing the content of the ROM + -> Int -- ^ Read address @rd@ + -> BitVector m -- ^ The value of the ROM at address @rd@ +asyncRomFile# sz file = (content !) -- Leave "(content !)" eta-reduced, see + where -- Note [Eta-reduction and unsafePerformIO initMem] + mem = unsafePerformIO (initMem file) + content = listArray (0,szI-1) mem + szI = snatToNum sz +{-# NOINLINE asyncRomFile# #-} + +-- | A ROM with a synchronous read port, with space for @n@ elements +-- +-- * __NB__: Read value is delayed by 1 cycle +-- * __NB__: Initial output value is 'undefined' +-- * __NB__: This function might not work for specific combinations of +-- code-generation backends and hardware targets. Please check the support table +-- below: +-- +-- @ +-- | VHDL | Verilog | SystemVerilog | +-- ===============+==========+==========+===============+ +-- Altera/Quartus | Broken | Works | Works | +-- Xilinx/ISE | Works | Works | Works | +-- ASIC | Untested | Untested | Untested | +-- ===============+==========+==========+===============+ +-- @ +-- +-- Additional helpful information: +-- +-- * See "Clash.Prelude.ROM.File#usingromfiles" for more information on how +-- to instantiate a ROM with the contents of a data file. +-- * See "Clash.Sized.Fixed#creatingdatafiles" for ideas on how to create your +-- own data files. +romFile + :: (KnownNat m, KnownNat n, HiddenClock domain gated) + => SNat n -- ^ Size of the ROM + -> FilePath -- ^ File describing the content of the ROM + -> Signal domain (Unsigned n) -- ^ Read address @rd@ + -> Signal domain (BitVector m) + -- ^ The value of the ROM at address @rd@ from the previous clock cycle +romFile = hideClock E.romFile +{-# INLINE romFile #-} + +-- | A ROM with a synchronous read port, with space for 2^@n@ elements +-- +-- * __NB__: Read value is delayed by 1 cycle +-- * __NB__: Initial output value is 'undefined' +-- * __NB__: This function might not work for specific combinations of +-- code-generation backends and hardware targets. Please check the support table +-- below: +-- +-- @ +-- | VHDL | Verilog | SystemVerilog | +-- ===============+==========+==========+===============+ +-- Altera/Quartus | Broken | Works | Works | +-- Xilinx/ISE | Works | Works | Works | +-- ASIC | Untested | Untested | Untested | +-- ===============+==========+==========+===============+ +-- @ +-- +-- Additional helpful information: +-- +-- * See "Clash.Prelude.ROM.File#usingromfiles" for more information on how +-- to instantiate a ROM with the contents of a data file. +-- * See "Clash.Sized.Fixed#creatingdatafiles" for ideas on how to create your +-- own data files. +romFilePow2 + :: forall n m domain gated + . (KnownNat m, KnownNat n, HiddenClock domain gated) + => FilePath -- ^ File describing the content of the ROM + -> Signal domain (Unsigned n) -- ^ Read address @rd@ + -> Signal domain (BitVector m) + -- ^ The value of the ROM at address @rd@ from the previous clock cycle +romFilePow2 = hideClock E.romFilePow2 +{-# INLINE romFilePow2 #-} diff --git a/src/Clash/Prelude/Safe.hs b/src/Clash/Prelude/Safe.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Prelude/Safe.hs @@ -0,0 +1,256 @@ +{-| + Copyright : (C) 2013-2016, University of Twente, + 2017 , Myrtle Software Ltd, Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + __This is the API only of "Clash.Prelude"__ + + CλaSH (pronounced ‘clash’) is a functional hardware description language that + borrows both its syntax and semantics from the functional programming language + Haskell. The merits of using a functional language to describe hardware comes + from the fact that combinational circuits can be directly modeled as + mathematical functions and that functional languages lend themselves very well + at describing and (de-)composing mathematical functions. + + This package provides: + + * Prelude library containing datatypes and functions for circuit design + + To use the library: + + * Import "Clash.Prelude" + * Additionally import "Clash.Explicit.Prelude" if you want to design + explicitly clocked circuits in a multi-clock setting + + For now, "Clash.Prelude" is also the best starting point for exploring the + library. A preliminary version of a tutorial can be found in "Clash.Tutorial". + Some circuit examples can be found in "Clash.Examples". +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} + +{-# LANGUAGE Safe #-} + +{-# OPTIONS_HADDOCK show-extensions #-} + +module Clash.Prelude.Safe + ( -- * Creating synchronous sequential circuits + mealy + , mealyB + , (<^>) + , moore + , mooreB + , registerB + -- * ROMs + , asyncRom + , asyncRomPow2 + , rom + , romPow2 + -- * RAM primitives with a combinational read port + , asyncRam + , asyncRamPow2 + -- * BlockRAM primitives + , blockRam + , blockRamPow2 + -- ** BlockRAM read/write conflict resolution + , readNew + -- * Utility functions + , isRising + , isFalling + , riseEvery + , oscillate + -- * Exported modules + -- ** Synchronous signals + , module Clash.Signal + , module Clash.Signal.Delayed + -- ** DataFlow interface + , module Clash.Prelude.DataFlow + -- ** Datatypes + -- *** Bit vectors + , module Clash.Sized.BitVector + , module Clash.Prelude.BitIndex + , module Clash.Prelude.BitReduction + -- *** Arbitrary-width numbers + , module Clash.Sized.Signed + , module Clash.Sized.Unsigned + , module Clash.Sized.Index + -- *** Fixed point numbers + , module Clash.Sized.Fixed + -- *** Fixed size vectors + , module Clash.Sized.Vector + -- *** Perfect depth trees + , module Clash.Sized.RTree + -- ** Annotations + , module Clash.Annotations.TopEntity + -- ** Type-level natural numbers + , module GHC.TypeLits + , module GHC.TypeLits.Extra + , module Clash.Promoted.Nat + , module Clash.Promoted.Nat.Literals + , module Clash.Promoted.Nat.TH + -- ** Type classes + -- *** Clash + , module Clash.Class.BitPack + , module Clash.Class.Num + , module Clash.Class.Resize + -- *** Other + , module Control.Applicative + , module Data.Bits + -- ** Exceptions + , module Clash.XException + , E.undefined + -- ** Named types + , module Clash.NamedTypes + -- ** Hidden arguments + , module Clash.Hidden + -- ** Haskell Prelude + -- $hiding + , module Prelude + ) +where + +import Control.Applicative +import Data.Bits +import GHC.TypeLits +import GHC.TypeLits.Extra +import Prelude hiding + ((++), (!!), concat, drop, foldl, foldl1, foldr, foldr1, head, init, iterate, + last, length, map, repeat, replicate, reverse, scanl, scanr, splitAt, tail, + take, unzip, unzip3, zip, zip3, zipWith, zipWith3, undefined) + +import Clash.Annotations.TopEntity +import Clash.Class.BitPack +import Clash.Class.Num +import Clash.Class.Resize +import Clash.Hidden +import Clash.NamedTypes +import Clash.Prelude.BitIndex +import Clash.Prelude.BitReduction +import Clash.Prelude.BlockRam +import qualified Clash.Explicit.Prelude.Safe as E +import Clash.Prelude.Mealy (mealy, mealyB, (<^>)) +import Clash.Prelude.Moore (moore, mooreB) +import Clash.Prelude.RAM (asyncRam,asyncRamPow2) +import Clash.Prelude.ROM (asyncRom,asyncRomPow2,rom,romPow2) +import Clash.Prelude.DataFlow +import Clash.Promoted.Nat +import Clash.Promoted.Nat.TH +import Clash.Promoted.Nat.Literals +import Clash.Sized.BitVector +import Clash.Sized.Fixed +import Clash.Sized.Index +import Clash.Sized.RTree +import Clash.Sized.Signed +import Clash.Sized.Unsigned +import Clash.Sized.Vector +import Clash.Signal +import Clash.Signal.Delayed +import Clash.XException + +{- $setup +>>> :set -XFlexibleContexts -XTypeApplications +>>> let rP = registerB (8,8) +-} + +{- $hiding +"Clash.Prelude" re-exports most of the Haskell "Prelude" with the exception of +the following: (++), (!!), concat, drop, foldl, foldl1, foldr, foldr1, head, +init, iterate, last, length, map, repeat, replicate, reverse, scanl, scanr, +splitAt, tail, take, unzip, unzip3, zip, zip3, zipWith, zipWith3. + +It instead exports the identically named functions defined in terms of +'Clash.Sized.Vector.Vec' at "Clash.Sized.Vector". +-} + +-- | Create a 'register' function for product-type like signals (e.g. '(Signal a, Signal b)') +-- +-- > rP :: HiddenClockReset domain gated synchronous +-- > => (Signal domain Int, Signal domain Int) +-- > -> (Signal domain Int, Signal domain Int) +-- > rP = registerB (8,8) +-- +-- >>> simulateB rP [(1,1),(2,2),(3,3)] :: [(Int,Int)] +-- [(8,8),(1,1),(2,2),(3,3)... +-- ... +registerB + :: (HiddenClockReset domain gated synchronous, Bundle a) + => a + -> Unbundled domain a + -> Unbundled domain a +registerB = hideClockReset E.registerB +infixr 3 `registerB` +{-# INLINE registerB #-} + +-- | Give a pulse when the 'Signal' goes from 'minBound' to 'maxBound' +isRising + :: (HiddenClockReset domain gated synchronous, Bounded a, Eq a) + => a -- ^ Starting value + -> Signal domain a + -> Signal domain Bool +isRising = hideClockReset E.isRising +{-# INLINE isRising #-} + +-- | Give a pulse when the 'Signal' goes from 'maxBound' to 'minBound' +isFalling + :: (HiddenClockReset domain gated synchronous, Bounded a, Eq a) + => a -- ^ Starting value + -> Signal domain a + -> Signal domain Bool +isFalling = hideClockReset E.isFalling +{-# INLINE isFalling #-} + +-- | Give a pulse every @n@ clock cycles. This is a useful helper function when +-- combined with functions like @'Clash.Signal.regEn'@ or @'Clash.Signal.mux'@, +-- in order to delay a register by a known amount. +-- +-- To be precise: the given signal will be @'False'@ for the next @n-1@ cycles, +-- followed by a single @'True'@ value: +-- +-- >>> Prelude.last (sampleN 1024 (riseEvery d1024)) == True +-- True +-- >>> Prelude.or (sampleN 1023 (riseEvery d1024)) == False +-- True +-- +-- For example, to update a counter once every 10 million cycles: +-- +-- @ +-- counter = 'Clash.Signal.regEn' 0 ('riseEvery' ('SNat' :: 'SNat' 10000000)) (counter + 1) +-- @ +riseEvery + :: HiddenClockReset domain gated synchronous + => SNat n + -> Signal domain Bool +riseEvery = hideClockReset E.riseEvery +{-# INLINE riseEvery #-} + +-- | Oscillate a @'Bool'@ for a given number of cycles. This is a convenient +-- function when combined with something like @'regEn'@, as it allows you to +-- easily hold a register value for a given number of cycles. The input @'Bool'@ +-- determines what the initial value is. +-- +-- To oscillate on an interval of 5 cycles: +-- +-- >>> sampleN 10 (oscillate False d5) +-- [False,False,False,False,False,True,True,True,True,True] +-- +-- To oscillate between @'True'@ and @'False'@: +-- +-- >>> sampleN 10 (oscillate False d1) +-- [False,True,False,True,False,True,False,True,False,True] +-- +-- An alternative definition for the above could be: +-- +-- >>> let osc' = register False (not <$> osc') +-- >>> let sample' = sampleN 200 +-- >>> sample' (oscillate False d1) == sample' osc' +-- True +oscillate + :: HiddenClockReset domain gated synchronous + => Bool + -> SNat n + -> Signal domain Bool +oscillate = hideClockReset E.oscillate +{-# INLINE oscillate #-} diff --git a/src/Clash/Prelude/Testbench.hs b/src/Clash/Prelude/Testbench.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Prelude/Testbench.hs @@ -0,0 +1,117 @@ +{-| +Copyright : (C) 2013-2016, University of Twente, + 2017 , Google Inc. +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij +-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# LANGUAGE Unsafe #-} + +{-# OPTIONS_HADDOCK show-extensions #-} + +module Clash.Prelude.Testbench + ( -- * Testbench functions for circuits + assert + , stimuliGenerator + , outputVerifier + ) +where + +import GHC.TypeLits (KnownNat) + +import qualified Clash.Explicit.Testbench as E +import Clash.Signal + (HiddenClockReset, Signal, hideClockReset) +import Clash.Sized.Vector (Vec) +import Clash.XException (ShowX) + +{- $setup +>>> :set -XTemplateHaskell -XDataKinds -XTypeApplications +>>> import Clash.Prelude +>>> let testInput = stimuliGenerator $(listToVecTH [(1::Int),3..21]) +>>> let expectedOutput = outputVerifier $(listToVecTH ([70,99,2,3,4,5,7,8,9,10]::[Int])) +-} + +-- | Compares the first two 'Signal's for equality and logs a warning when they +-- are not equal. The second 'Signal' is considered the expected value. This +-- function simply returns the third 'Signal' unaltered as its result. This +-- function is used by 'outputVerifier'. +-- +-- +-- __NB__: This function /can/ be used in synthesizable designs. +assert + :: (Eq a,ShowX a,HiddenClockReset domain gated synchronous) + => String -- ^ Additional message + -> Signal domain a -- ^ Checked value + -> Signal domain a -- ^ Expected value + -> Signal domain b -- ^ Return value + -> Signal domain b +assert = hideClockReset E.assert +{-# INLINE assert #-} + +-- | To be used as one of the functions to create the \"magical\" 'testInput' +-- value, which the CλaSH compiler looks for to create the stimulus generator +-- for the generated VHDL testbench. +-- +-- Example: +-- +-- @ +-- testInput +-- :: HiddenClockReset domain gated synchronous +-- => 'Signal' domain Int +-- testInput = 'stimuliGenerator' $('Clash.Sized.Vector.listToVecTH' [(1::Int),3..21]) +-- @ +-- +-- >>> sampleN 13 testInput +-- [1,3,5,7,9,11,13,15,17,19,21,21,21] +stimuliGenerator + :: (KnownNat l, HiddenClockReset domain gated synchronous) + => Vec l a -- ^ Samples to generate + -> Signal domain a -- ^ Signal of given samples +stimuliGenerator = hideClockReset E.stimuliGenerator +{-# INLINE stimuliGenerator #-} + +-- | To be used as one of the functions to generate the \"magical\" 'expectedOutput' +-- function, which the CλaSH compiler looks for to create the signal verifier +-- for the generated VHDL testbench. +-- +-- Example: +-- +-- @ +-- expectedOutput +-- :: HiddenClockReset domain gated synchronous +-- -> 'Signal' domain Int -> 'Signal' domain Bool +-- expectedOutput = 'outputVerifier' $('Clash.Sized.Vector.listToVecTH' ([70,99,2,3,4,5,7,8,9,10]::[Int])) +-- @ +-- +-- >>> import qualified Data.List as List +-- >>> sampleN 12 (expectedOutput (fromList ([0..10] List.++ [10,10,10]))) +-- +-- cycle(system10000): 0, outputVerifier +-- expected value: 70, not equal to actual value: 0 +-- [False +-- cycle(system10000): 1, outputVerifier +-- expected value: 99, not equal to actual value: 1 +-- ,False,False,False,False,False +-- cycle(system10000): 6, outputVerifier +-- expected value: 7, not equal to actual value: 6 +-- ,False +-- cycle(system10000): 7, outputVerifier +-- expected value: 8, not equal to actual value: 7 +-- ,False +-- cycle(system10000): 8, outputVerifier +-- expected value: 9, not equal to actual value: 8 +-- ,False +-- cycle(system10000): 9, outputVerifier +-- expected value: 10, not equal to actual value: 9 +-- ,False,True,True] +outputVerifier + :: (KnownNat l, Eq a, ShowX a, HiddenClockReset domain gated synchronous) + => Vec l a -- ^ Samples to compare with + -> Signal domain a -- ^ Signal to verify + -> Signal domain Bool -- ^ Indicator that all samples are verified +outputVerifier = hideClockReset E.outputVerifier +{-# INLINE outputVerifier #-} diff --git a/src/Clash/Promoted/Nat.hs b/src/Clash/Promoted/Nat.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Promoted/Nat.hs @@ -0,0 +1,528 @@ +{-| +Copyright : (C) 2013-2016, University of Twente, + 2016 , Myrtle Software Ltd +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij +-} + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RankNTypes #-} + +{-# LANGUAGE Trustworthy #-} + +{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise -fplugin GHC.TypeLits.KnownNat.Solver #-} +{-# OPTIONS_HADDOCK show-extensions #-} + +module Clash.Promoted.Nat + ( -- * Singleton natural numbers + -- ** Data type + SNat (..) + -- ** Construction + , snatProxy + , withSNat + -- ** Conversion + , snatToInteger, snatToNum + -- ** Arithmetic + , addSNat, mulSNat, powSNat + -- *** Partial + , subSNat, divSNat, modSNat, flogBaseSNat, clogBaseSNat, logBaseSNat + -- *** Specialised + , pow2SNat + -- * Unary/Peano-encoded natural numbers + -- ** Data type + , UNat (..) + -- ** Construction + , toUNat + -- ** Conversion + , fromUNat + -- ** Arithmetic + , addUNat, mulUNat, powUNat + -- *** Partial + , predUNat, subUNat + -- * Base-2 encoded natural numbers + -- ** Data type + , BNat (..) + -- ** Construction + , toBNat + -- ** Conversion + , fromBNat + -- ** Pretty printing base-2 encoded natural numbers + , showBNat + -- ** Arithmetic + , succBNat, addBNat, mulBNat, powBNat + -- *** Partial + , predBNat, div2BNat, div2Sub1BNat, log2BNat + -- ** Normalisation + , stripZeros + -- * Constraints on natural numbers + , leToPlus + , leToPlusKN + , plusToLe + , plusToLeKN + ) +where + +import GHC.TypeLits (KnownNat, Nat, type (+), type (-), type (*), + type (^), type (<=), natVal) +import GHC.TypeLits.Extra (CLog, FLog, Div, Log, Mod) +import Language.Haskell.TH (appT, conT, litT, numTyLit, sigE) +import Language.Haskell.TH.Syntax (Lift (..)) +import Unsafe.Coerce (unsafeCoerce) +import Clash.XException (ShowX (..), showsPrecXWith) + +{- $setup +>>> :set -XBinaryLiterals +>>> import Clash.Promoted.Nat.Literals (d789) +-} + +-- | Singleton value for a type-level natural number 'n' +-- +-- * "Clash.Promoted.Nat.Literals" contains a list of predefined 'SNat' literals +-- * "Clash.Promoted.Nat.TH" has functions to easily create large ranges of new +-- 'SNat' literals +data SNat (n :: Nat) where + SNat :: KnownNat n => SNat n + +instance Lift (SNat n) where + lift s = sigE [| SNat |] + (appT (conT ''SNat) (litT $ numTyLit (snatToInteger s))) + +-- | Create an @`SNat` n@ from a proxy for /n/ +snatProxy :: KnownNat n => proxy n -> SNat n +snatProxy _ = SNat + +instance Show (SNat n) where + show p@SNat = 'd' : show (natVal p) + +instance ShowX (SNat n) where + showsPrecX = showsPrecXWith showsPrec + +{-# INLINE withSNat #-} +-- | Supply a function with a singleton natural 'n' according to the context +withSNat :: KnownNat n => (SNat n -> a) -> a +withSNat f = f SNat + +{-# INLINE snatToInteger #-} +-- | Reify the type-level 'Nat' @n@ to it's term-level 'Integer' representation. +snatToInteger :: SNat n -> Integer +snatToInteger p@SNat = natVal p + +-- | Reify the type-level 'Nat' @n@ to it's term-level 'Num'ber. +snatToNum :: Num a => SNat n -> a +snatToNum p@SNat = fromInteger (natVal p) +{-# INLINE snatToNum #-} + +-- | Unary representation of a type-level natural +-- +-- __NB__: Not synthesisable +data UNat :: Nat -> * where + UZero :: UNat 0 + USucc :: UNat n -> UNat (n + 1) + +instance KnownNat n => Show (UNat n) where + show x = 'u':show (natVal x) + +instance KnownNat n => ShowX (UNat n) where + showsPrecX = showsPrecXWith showsPrec + +-- | Convert a singleton natural number to its unary representation +-- +-- __NB__: Not synthesisable +toUNat :: SNat n -> UNat n +toUNat p@SNat = fromI (natVal p) + where + fromI :: Integer -> UNat m + fromI 0 = unsafeCoerce UZero + fromI n = unsafeCoerce (USucc (fromI (n - 1))) + +-- | Convert a unary-encoded natural number to its singleton representation +-- +-- __NB__: Not synthesisable +fromUNat :: UNat n -> SNat n +fromUNat UZero = SNat :: SNat 0 +fromUNat (USucc x) = addSNat (fromUNat x) (SNat :: SNat 1) + +-- | Add two unary-encoded natural numbers +-- +-- __NB__: Not synthesisable +addUNat :: UNat n -> UNat m -> UNat (n + m) +addUNat UZero y = y +addUNat x UZero = x +addUNat (USucc x) y = USucc (addUNat x y) + +-- | Multiply two unary-encoded natural numbers +-- +-- __NB__: Not synthesisable +mulUNat :: UNat n -> UNat m -> UNat (n * m) +mulUNat UZero _ = UZero +mulUNat _ UZero = UZero +mulUNat (USucc x) y = addUNat y (mulUNat x y) + +-- | Power of two unary-encoded natural numbers +-- +-- __NB__: Not synthesisable +powUNat :: UNat n -> UNat m -> UNat (n ^ m) +powUNat _ UZero = USucc UZero +powUNat x (USucc y) = mulUNat x (powUNat x y) + +-- | Predecessor of a unary-encoded natural number +-- +-- __NB__: Not synthesisable +predUNat :: UNat (n+1) -> UNat n +predUNat (USucc x) = x + +-- | Subtract two unary-encoded natural numbers +-- +-- __NB__: Not synthesisable +subUNat :: UNat (m+n) -> UNat n -> UNat m +subUNat x UZero = x +subUNat (USucc x) (USucc y) = subUNat x y +subUNat UZero _ = error "impossible: 0 + (n + 1) ~ 0" + +-- | Add two singleton natural numbers +addSNat :: SNat a -> SNat b -> SNat (a+b) +addSNat SNat SNat = SNat +{-# INLINE addSNat #-} +infixl 6 `addSNat` + +-- | Subtract two singleton natural numbers +subSNat :: SNat (a+b) -> SNat b -> SNat a +subSNat SNat SNat = SNat +{-# INLINE subSNat #-} +infixl 6 `subSNat` + +-- | Multiply two singleton natural numbers +mulSNat :: SNat a -> SNat b -> SNat (a*b) +mulSNat SNat SNat = SNat +{-# INLINE mulSNat #-} +infixl 7 `mulSNat` + +-- | Power of two singleton natural numbers +powSNat :: SNat a -> SNat b -> SNat (a^b) +powSNat SNat SNat = SNat +{-# NOINLINE powSNat #-} +infixr 8 `powSNat` + +-- | Division of two singleton natural numbers +divSNat :: (1 <= b) => SNat a -> SNat b -> SNat (Div a b) +divSNat SNat SNat = SNat +{-# INLINE divSNat #-} +infixl 7 `divSNat` + +-- | Modulo of two singleton natural numbers +modSNat :: (1 <= b) => SNat a -> SNat b -> SNat (Mod a b) +modSNat SNat SNat = SNat +{-# INLINE modSNat #-} +infixl 7 `modSNat` + +-- | Floor of the logarithm of a natural number +flogBaseSNat :: (2 <= base, 1 <= x) + => SNat base -- ^ Base + -> SNat x + -> SNat (FLog base x) +flogBaseSNat SNat SNat = SNat +{-# NOINLINE flogBaseSNat #-} + +-- | Ceiling of the logarithm of a natural number +clogBaseSNat :: (2 <= base, 1 <= x) + => SNat base -- ^ Base + -> SNat x + -> SNat (CLog base x) +clogBaseSNat SNat SNat = SNat +{-# NOINLINE clogBaseSNat #-} + +-- | Exact integer logarithm of a natural number +-- +-- __NB__: Only works when the argument is a power of the base +logBaseSNat :: (FLog base x ~ CLog base x) + => SNat base -- ^ Base + -> SNat x + -> SNat (Log base x) +logBaseSNat SNat SNat = SNat +{-# NOINLINE logBaseSNat #-} + +-- | Power of two of a singleton natural number +pow2SNat :: SNat a -> SNat (2^a) +pow2SNat SNat = SNat +{-# INLINE pow2SNat #-} + +-- | Base-2 encoded natural number +-- +-- * __NB__: The LSB is the left/outer-most constructor: +-- * __NB__: Not synthesisable +-- +-- >>> B0 (B1 (B1 BT)) +-- b6 +-- +-- == Constructors +-- +-- * Starting/Terminating element: +-- +-- @ +-- __BT__ :: 'BNat' 0 +-- @ +-- +-- * Append a zero (/0/): +-- +-- @ +-- __B0__ :: 'BNat' n -> 'BNat' (2 '*' n) +-- @ +-- +-- * Append a one (/1/): +-- +-- @ +-- __B1__ :: 'BNat' n -> 'BNat' ((2 '*' n) '+' 1) +-- @ +data BNat :: Nat -> * where + BT :: BNat 0 + B0 :: BNat n -> BNat (2*n) + B1 :: BNat n -> BNat ((2*n) + 1) + +instance KnownNat n => Show (BNat n) where + show x = 'b':show (natVal x) + +instance KnownNat n => ShowX (BNat n) where + showsPrecX = showsPrecXWith showsPrec + +-- | Show a base-2 encoded natural as a binary literal +-- +-- __NB__: The LSB is shown as the right-most bit +-- +-- >>> d789 +-- d789 +-- >>> toBNat d789 +-- b789 +-- >>> showBNat (toBNat d789) +-- "0b1100010101" +-- >>> 0b1100010101 :: Integer +-- 789 +showBNat :: BNat n -> String +showBNat = go [] + where + go :: String -> BNat m -> String + go xs BT = "0b" ++ xs + go xs (B0 x) = go ('0':xs) x + go xs (B1 x) = go ('1':xs) x + +-- | Convert a singleton natural number to its base-2 representation +-- +-- __NB__: Not synthesisable +toBNat :: SNat n -> BNat n +toBNat s@SNat = toBNat' (natVal s) + where + toBNat' :: Integer -> BNat m + toBNat' 0 = unsafeCoerce BT + toBNat' n = case n `divMod` 2 of + (n',1) -> unsafeCoerce (B1 (toBNat' n')) + (n',_) -> unsafeCoerce (B0 (toBNat' n')) + +-- | Convert a base-2 encoded natural number to its singleton representation +-- +-- __NB__: Not synthesisable +fromBNat :: BNat n -> SNat n +fromBNat BT = SNat :: SNat 0 +fromBNat (B0 x) = mulSNat (SNat :: SNat 2) (fromBNat x) +fromBNat (B1 x) = addSNat (mulSNat (SNat :: SNat 2) (fromBNat x)) + (SNat :: SNat 1) + +-- | Add two base-2 encoded natural numbers +-- +-- __NB__: Not synthesisable +addBNat :: BNat n -> BNat m -> BNat (n+m) +addBNat (B0 a) (B0 b) = B0 (addBNat a b) +addBNat (B0 a) (B1 b) = B1 (addBNat a b) +addBNat (B1 a) (B0 b) = B1 (addBNat a b) +addBNat (B1 a) (B1 b) = B0 (succBNat (addBNat a b)) +addBNat BT b = b +addBNat a BT = a + +-- | Multiply two base-2 encoded natural numbers +-- +-- __NB__: Not synthesisable +mulBNat :: BNat n -> BNat m -> BNat (n*m) +mulBNat BT _ = BT +mulBNat _ BT = BT +mulBNat (B0 a) b = B0 (mulBNat a b) +mulBNat (B1 a) b = addBNat (B0 (mulBNat a b)) b + +-- | Power of two base-2 encoded natural numbers +-- +-- __NB__: Not synthesisable +powBNat :: BNat n -> BNat m -> BNat (n^m) +powBNat _ BT = B1 BT +powBNat a (B0 b) = let z = powBNat a b + in mulBNat z z +powBNat a (B1 b) = let z = powBNat a b + in mulBNat a (mulBNat z z) + +-- | Successor of a base-2 encoded natural number +-- +-- __NB__: Not synthesisable +succBNat :: BNat n -> BNat (n+1) +succBNat BT = B1 BT +succBNat (B0 a) = B1 a +succBNat (B1 a) = B0 (succBNat a) + +-- | Predecessor of a base-2 encoded natural number +-- +-- __NB__: Not synthesisable +predBNat :: BNat (n+1) -> (BNat n) +predBNat (B1 a) = case stripZeros a of + BT -> BT + a' -> B0 a' +predBNat (B0 x) = B1 (go x) + where + go :: BNat m -> BNat (m-1) + go (B1 a) = case stripZeros a of + BT -> BT + a' -> B0 a' + go (B0 a) = B1 (go a) + go BT = error "impossible: 0 ~ 0 - 1" + +-- | Divide a base-2 encoded natural number by 2 +-- +-- __NB__: Not synthesisable +div2BNat :: BNat (2*n) -> BNat n +div2BNat BT = BT +div2BNat (B0 x) = x +div2BNat (B1 _) = error "impossible: 2*n ~ 2*n+1" + +-- | Subtract 1 and divide a base-2 encoded natural number by 2 +-- +-- __NB__: Not synthesisable +div2Sub1BNat :: BNat (2*n+1) -> BNat n +div2Sub1BNat (B1 x) = x +div2Sub1BNat _ = error "impossible: 2*n+1 ~ 2*n" + +-- | Get the log2 of a base-2 encoded natural number +-- +-- __NB__: Not synthesisable +log2BNat :: BNat (2^n) -> BNat n +log2BNat (B1 x) = case stripZeros x of + BT -> BT + _ -> error "impossible: 2^n ~ 2x+1" +log2BNat (B0 x) = succBNat (log2BNat x) + +-- | Strip non-contributing zero's from a base-2 encoded natural number +-- +-- >>> B1 (B0 (B0 (B0 BT))) +-- b1 +-- >>> showBNat (B1 (B0 (B0 (B0 BT)))) +-- "0b0001" +-- >>> showBNat (stripZeros (B1 (B0 (B0 (B0 BT))))) +-- "0b1" +-- >>> stripZeros (B1 (B0 (B0 (B0 BT)))) +-- b1 +-- +-- __NB__: Not synthesisable +stripZeros :: BNat n -> BNat n +stripZeros BT = BT +stripZeros (B1 x) = B1 (stripZeros x) +stripZeros (B0 BT) = BT +stripZeros (B0 x) = case stripZeros x of + BT -> BT + k -> B0 k + +-- | Change a function that has an argument with an @(n + k)@ constraint to a +-- function with an argument that has an @(k <= n)@ constraint. +-- +-- __NB__ It is the dual to 'plusToLe' +-- +-- === __Examples__ +-- +-- Example 1 +-- +-- @ +-- f :: Index (n+1) -> Index (n + 1) -> Bool +-- +-- g :: (1 '<=' n) => Index n -> Index n -> Bool +-- g a b = 'leToPlus' \@1 $ \\a' -> 'leToPlus' \@1 $ \\b' -> f a' b' +-- @ +-- +-- Example 2 +-- +-- @ +-- import Data.Bifunctor.Flip +-- +-- head :: Vec (n + 1) a -> a +-- +-- head' :: (1 '<=' n) => Vec n a -> a +-- head' a = 'leToPlus' \@1 (Flip a) (head . runFlip) +-- @ +leToPlus + :: forall (k :: Nat) (n :: Nat) f r + . (k <= n) + => f n + -- ^ Argument with the @(k <= n)@ constraint + -> (forall m . f (m + k) -> r) + -- ^ Function with the @(n + k)@ constraint + -> r +leToPlus a f = f @ (n-k) a +{-# INLINE leToPlus #-} + +-- | Same as 'leToPlus' with added 'KnownNat' constraints +leToPlusKN + :: forall (k :: Nat) (n :: Nat) f r + . (k <= n, KnownNat n, KnownNat k) + => f n + -- ^ Argument with the @(k <= n)@ constraint + -> (forall m . KnownNat m => f (m + k) -> r) + -- ^ Function with the @(n + k)@ constraint + -> r +leToPlusKN a f = f @ (n-k) a +{-# INLINE leToPlusKN #-} + +-- | Change a function that has an argument with an @(k <= n)@ constraint to a +-- function with an argument that has an @(n + k)@ constraint. +-- +-- __NB__ It is the dual to 'leToPlus' +-- +-- === __Examples__ +-- +-- Example 1 +-- +-- @ +-- f :: (1 '<=' n) => Index n -> Index n -> Bool +-- +-- g :: Index (n + 1) -> Index (n + 1) -> Bool +-- g a b = 'plusToLe' \@1 $ \\a' -> 'plusToLe' \@1 $ \\b' -> f a' b' +-- @ +-- +-- Example 2 +-- +-- @ +-- import Datal.Bifunctor.Flip +-- +-- fold :: (1 '<=' n) => (a -> a -> a) -> Vec n a -> a +-- +-- fold' :: (a -> a -> a) -> Vec (n+1) a -> a +-- fold' f a = 'plusToLe' \@1 (Flip a) (fold f . runFlip) +-- @ +plusToLe + :: forall (k :: Nat) n f r + . f (n + k) + -- ^ Argument with the @(n + k)@ constraint + -> (forall m . (k <= m) => f m -> r) + -- ^ Function with the @(k <= n)@ constraint + -> r +plusToLe a f = f @(n + k) a +{-# INLINE plusToLe #-} + +-- | Same as 'plusToLe' with added 'KnownNat' constraints +plusToLeKN + :: forall (k :: Nat) n f r + . (KnownNat n, KnownNat k) + => f (n + k) + -- ^ Argument with the @(n + k)@ constraint + -> (forall m . (KnownNat m, k <= m) => f m -> r) + -- ^ Function with the @(k <= n)@ constraint + -> r +plusToLeKN a f = f @(n + k) a diff --git a/src/Clash/Promoted/Nat/Literals.hs b/src/Clash/Promoted/Nat/Literals.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Promoted/Nat/Literals.hs @@ -0,0 +1,32 @@ +{-| +Copyright : (C) 2013-2016, University of Twente +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij + +Predefined 'SNat' singleton literals in the range [0 .. 1024] + +Defines: + +@ +d0 = SNat :: SNat 0 +d1 = SNat :: SNat 1 +d2 = SNat :: SNat 2 +... +d1024 = SNat :: SNat 1024 +@ + +You can generate more 'SNat' literals using 'decLiteralsD' from "Clash.Promoted.Nat.TH" +-} + +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DataKinds #-} + +{-# LANGUAGE Trustworthy #-} + +{-# OPTIONS_HADDOCK show-extensions #-} + +module Clash.Promoted.Nat.Literals where + +import Clash.Promoted.Nat.TH + +$(decLiteralsD 0 1024) diff --git a/src/Clash/Promoted/Nat/TH.hs b/src/Clash/Promoted/Nat/TH.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Promoted/Nat/TH.hs @@ -0,0 +1,63 @@ +{-| +Copyright : (C) 2013-2016, University of Twente +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij +-} + +{-# LANGUAGE TemplateHaskell #-} + +{-# LANGUAGE Trustworthy #-} + +{-# OPTIONS_HADDOCK show-extensions #-} + +module Clash.Promoted.Nat.TH + ( -- * Declare a single @d\@ literal + decLiteralD + -- * Declare ranges of @d\@ literals + , decLiteralsD + ) +where + +import Language.Haskell.TH +import Clash.Promoted.Nat + +{- $setup +>>> :set -XDataKinds +>>> let d1111 = SNat :: SNat 1111 +>>> let d1200 = SNat :: SNat 1200 +>>> let d1201 = SNat :: SNat 1201 +>>> let d1202 = SNat :: SNat 1202 +-} + +-- | Create an 'SNat' literal +-- +-- > $(decLiteralD 1111) +-- +-- >>> :t d1111 +-- d1111 :: SNat 1111 +-- +decLiteralD :: Integer + -> Q [Dec] +decLiteralD n = do + let suffix = if n < 0 then error ("Can't make negative SNat: " ++ show n) else show n + valName = mkName $ 'd':suffix + sig <- sigD valName (appT (conT ''SNat) (litT (numTyLit n))) + val <- valD (varP valName) (normalB [| SNat |]) [] + return [ sig, val ] + +-- | Create a range of 'SNat' literals +-- +-- > $(decLiteralsD 1200 1202) +-- +-- >>> :t d1200 +-- d1200 :: SNat 1200 +-- >>> :t d1201 +-- d1201 :: SNat 1201 +-- >>> :t d1202 +-- d1202 :: SNat 1202 +-- +decLiteralsD :: Integer + -> Integer + -> Q [Dec] +decLiteralsD from to = + fmap concat $ sequence $ [ decLiteralD n | n <- [from..to] ] diff --git a/src/Clash/Promoted/Nat/Unsafe.hs b/src/Clash/Promoted/Nat/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Promoted/Nat/Unsafe.hs @@ -0,0 +1,21 @@ +{-| +Copyright : (C) 2015-2016, University of Twente +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij +-} + +{-# LANGUAGE Unsafe #-} + +module Clash.Promoted.Nat.Unsafe + (unsafeSNat) +where + +import Data.Reflection (reifyNat) +import Unsafe.Coerce (unsafeCoerce) + +import Clash.Promoted.Nat (SNat, snatProxy) + +-- | I hope you know what you're doing +unsafeSNat :: Integer -> SNat k +unsafeSNat i = reifyNat i $ (\p -> unsafeCoerce (snatProxy p)) +{-# NOINLINE unsafeSNat #-} diff --git a/src/Clash/Promoted/Symbol.hs b/src/Clash/Promoted/Symbol.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Promoted/Symbol.hs @@ -0,0 +1,38 @@ +{-| +Copyright : (C) 2013-2016, University of Twente +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} + +{-# LANGUAGE Safe #-} + +{-# OPTIONS_HADDOCK show-extensions #-} + +module Clash.Promoted.Symbol + (SSymbol (..), ssymbolProxy, ssymbolToString) +where + +import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) + +-- | Singleton value for a type-level string @s@ +data SSymbol (s :: Symbol) where + SSymbol :: KnownSymbol s => SSymbol s + +instance Show (SSymbol s) where + show s@SSymbol = symbolVal s + +{-# INLINE ssymbolProxy #-} +-- | Create a singleton symbol literal @'SSymbol' s@ from a proxy for +-- /s/ +ssymbolProxy :: KnownSymbol s => proxy s -> SSymbol s +ssymbolProxy _ = SSymbol + +{-# INLINE ssymbolToString #-} +-- | Reify the type-level 'Symbol' @s@ to it's term-level 'String' +-- representation. +ssymbolToString :: SSymbol s -> String +ssymbolToString s@SSymbol = symbolVal s diff --git a/src/Clash/Signal.hs b/src/Clash/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Signal.hs @@ -0,0 +1,768 @@ +{-| +Copyright : (C) 2013-2016, University of Twente, + 2016 , Myrtle Software, + 2017 , Google Inc. +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij + +CλaSH has synchronous 'Signal's in the form of: + +@ +'Signal' (domain :: 'Domain') a +@ + +Where /a/ is the type of the value of the 'Signal', for example /Int/ or /Bool/, +and /domain/ is the /clock-/ (and /reset-/) domain to which the memory elements +manipulating these 'Signal's belong. + +The type-parameter, /domain/, is of the kind 'Domain' which has types of the +following shape: + +@ +data Domain = Dom { domainName :: 'GHC.TypeLits.Symbol', clkPeriod :: 'GHC.TypeLits.Nat' } +@ + +Where /domainName/ is a type-level string ('GHC.TypeLits.Symbol') representing +the name of the /clock-/ (and /reset-/) domain, and /clkPeriod/ is a type-level +natural number ('GHC.TypeLits.Nat') representing the clock period (in __ps__) +of the clock lines in the /clock-domain/. + +* __NB__: \"Bad things\"™ happen when you actually use a clock period of @0@, +so do __not__ do that! +* __NB__: You should be judicious using a clock with period of @1@ as you can +never create a clock that goes any faster! +-} + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +{-# LANGUAGE Trustworthy #-} + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_HADDOCK show-extensions #-} + +module Clash.Signal + ( -- * Synchronous signals + Signal + , Domain (..) + , System + -- * Clock + , Clock + , ClockKind (..) + -- * Reset + , Reset + , ResetKind (..) + , unsafeFromAsyncReset + , unsafeToAsyncReset + , fromSyncReset + , unsafeToSyncReset + , resetSynchronizer + -- * Hidden clocks and resets + -- $hiddenclockandreset + + -- ** Hidden clock + , HiddenClock + , hideClock + , exposeClock + , withClock + , hasClock + -- ** Hidden reset + , HiddenReset + , hideReset + , exposeReset + , withReset + , hasReset + -- ** Hidden clock and reset + , HiddenClockReset + , hideClockReset + , exposeClockReset + , withClockReset + , SystemClockReset + -- * Basic circuit functions + , delay + , register + , regMaybe + , regEn + , mux + -- * Simulation and testbench functions + , clockGen + , tbClockGen + , asyncResetGen + , syncResetGen + , systemClockGen + , tbSystemClockGen + , systemResetGen + -- * Boolean connectives + , (.&&.), (.||.) + -- * Product/Signal isomorphism + , Bundle(..) + -- * Simulation functions (not synthesisable) + , simulate + , simulateB + -- ** lazy versions + , simulate_lazy + , simulateB_lazy + -- * List \<-\> Signal conversion (not synthesisable) + , sample + , sampleN + , fromList + -- ** lazy versions + , sample_lazy + , sampleN_lazy + , fromList_lazy + -- * QuickCheck combinators + , testFor + -- * Type classes + -- ** 'Eq'-like + , (.==.), (./=.) + -- ** 'Ord'-like + , (.<.), (.<=.), (.>=.), (.>.) + ) +where + +import Control.DeepSeq (NFData) +import GHC.Stack (HasCallStack, withFrozenCallStack) +import GHC.TypeLits (KnownNat, KnownSymbol) +import Data.Bits (Bits) -- Haddock only +import Data.Maybe (isJust, fromJust) +import Prelude +import Test.QuickCheck (Property, property) +import Unsafe.Coerce (unsafeCoerce) + +import Clash.Explicit.Signal + (System, resetSynchronizer, systemClockGen, systemResetGen, tbSystemClockGen) +import qualified Clash.Explicit.Signal as S +import Clash.Hidden +import Clash.Promoted.Nat (SNat (..)) +import Clash.Promoted.Symbol (SSymbol (..)) +import Clash.Signal.Bundle (Bundle (..)) +import Clash.Signal.Internal hiding + (sample, sample_lazy, sampleN, sampleN_lazy, simulate, simulate_lazy, testFor) +import qualified Clash.Signal.Internal as S + +{- $setup +>>> :set -XFlexibleContexts -XTypeApplications +>>> import Clash.XException (printX) +>>> import Control.Applicative (liftA2) +>>> let oscillate = register False (not <$> oscillate) +>>> let count = regEn 0 oscillate (count + 1) +>>> :{ +sometimes1 = s where + s = register Nothing (switch <$> s) + switch Nothing = Just 1 + switch _ = Nothing +:} + +>>> :{ +countSometimes = s where + s = regMaybe 0 (plusM (pure <$> s) sometimes1) + plusM = liftA2 (liftA2 (+)) +:} + +-} + +-- * Hidden clock and reset arguments + +{- $hiddenclockandreset #hiddenclockandreset# +Clocks and resets are by default implicitly routed to their components. You can +see from the type of a component whether it has hidden clock or reset +arguments: + +It has a hidden clock when it has a: + +@ +f :: 'HiddenClock' domain gated => ... +@ + +Constraint. + +Or it has a hidden reset when it has a: + +@ +g :: 'HiddenReset' domain synchronous => ... +@ + +Constraint. + +Or it has both a hidden clock argument and a hidden reset argument when it +has a: + +@ +h :: 'HiddenClockReset' domain gated synchronous => .. +@ + +Constraint. + +Given a component with an explicit clock and reset arguments, you can turn them +into hidden arguments using 'hideClock' and 'hideReset'. So given a: + +@ +f :: Clock domain gated -> Reset domain synchronous -> Signal domain a -> ... +@ + +You hide the clock and reset arguments by: + +@ +-- g :: 'HiddenClockReset' domain gated synchronous => Signal domain a -> ... +g = 'hideClockReset' f +@ + +Or, alternatively, by: + +@ +-- h :: HiddenClockReset domain gated synchronous => Signal domain a -> ... +h = f 'hasClock' 'hasReset' +@ + +=== Assigning explicit clock and reset arguments to hidden clocks and resets + +Given a component: + +@ +f :: HiddenClockReset domain gated synchronous + => Signal domain Int + -> Signal domain Int +@ + +which has hidden clock and routed reset arguments, we expose those hidden +arguments so that we can explicitly apply them: + +@ +-- g :: Clock domain gated -> Reset domain synchronous -> Signal domain Int -> Signal domain Int +g = 'exposeClockReset' f +@ + +or, alternatively, by: + +@ +-- h :: Clock domain gated -> Reset domain synchronous -> Signal domain Int -> Signal domain Int +h clk rst = withClock clk rst f +@ + +Similarly, there are 'exposeClock' and 'exposeReset' to connect just expose +the hidden clock or the hidden reset argument. + +You will need to explicitly apply clocks and resets when you want to use +components such as PPLs and 'resetSynchronizer': + +@ +topEntity + :: Clock System Source + -> Reset System Asynchronous + -> Signal System Int + -> Signal System Int +topEntity clk rst = + let (pllOut,pllStable) = 'Clash.Intel.ClockGen.altpll' (SSymbol \@\"altpll50\") clk rst + rstSync = 'resetSynchronizer' pllOut ('unsafeToAsyncReset' pllStable) + in 'exposeClockReset' f pllOut rstSync +@ + +or, using the alternative method: + +@ +topEntity2 + :: Clock System Source + -> Reset System Asynchronous + -> Signal System Int + -> Signal System Int +topEntity2 clk rst = + let (pllOut,pllStable) = 'Clash.Intel.ClockGen.altpll' (SSymbol \@\"altpll50\") clk rst + rstSync = 'resetSynchronizer' pllOut ('unsafeToAsyncReset' pllStable) + in 'withClockReset' pllOut rstSync f +@ + +-} + +-- | A /constraint/ that indicates the component has a hidden 'Clock' +-- +--