diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,66 @@ # Changelog for the Clash project +## 1.10.2 *Sep 4th, 2026* + +Highlights: +* On a large representative circuit, this release reduces total runtime by 80% compared to 1.10.0; smaller circuits also recover from some previous performance regressions. See the [Clash benchmark results](https://clash-lang.github.io/clash-benchmarks/?machine=oele&branch=clash-lang/clash-compiler@1.10) for the comparison. + +Performance: +* The `clash-lib` compile-time evaluator no longer projects the entire global binding map into a fresh heap on (virtually) every invocation. In the representative benchmark, this reduced runtime by about 27%. See [#3323](https://github.com/clash-lang/clash-compiler/pull/3323). +* The `clash-ghc` compile-time evaluator peels elements from a literal `BitVector` via `unconcatBitVector#` directly as literals, rather than leaving residual `split#` calls for later rewrite passes. This speeds up normalization of designs that convert large `BitVector` constants to vectors. See [#3323](https://github.com/clash-lang/clash-compiler/pull/3323). +* In `clash-lib`, the Core-type-to-HWType translation used by representability queries during normalization is memoized across the rewrite session rather than recomputed for every query. This speeds up normalization of designs with large or deeply nested types. See [#3323](https://github.com/clash-lang/clash-compiler/pull/3323). +* The conversion from GHC Core to Clash Core in `clash-ghc` is faster on large designs: type-constructor annotations are pre-checked on the interned name, the accumulated TyCon map is no longer re-inserted at every occurrence, and global-variable types are converted once and cached. See [#3323](https://github.com/clash-lang/clash-compiler/pull/3323). +* Identifier-only free-variable folds in `clash-lib` now skip unnecessary type traversal, yielding about 2% faster normalization. See [#3327](https://github.com/clash-lang/clash-compiler/pull/3327). +* In the `clash-ghc`/`clash-lib` blackbox compilation path, blackbox functions and Haskell template functions now share a single Hint (GHC) session, and each distinct function is compiled exactly once. In larger designs, this reduced load time by about 20% and end-to-end runtime by about 2%. See [#3337](https://github.com/clash-lang/clash-compiler/pull/3337). +* In `clash-lib`, alpha-equivalence checks on `Term` and `Type` no longer compute free variables. Microbenchmarks show substantial speedups; end-to-end tests show a modest 2.5% improvement in normalization runtime. See [#3335](https://github.com/clash-lang/clash-compiler/pull/3335). +* In `clash-lib`, the cleanup phase that flattens the function hierarchy now runs the evaluator-backed transformations (`reduceConst`, `reduceNonRepPrim`) and the transformations that piggyback on their output as one bottom-up pass per flattening iteration, rather than during every settle round of the inner fixed-point loop. On larger designs, this produced about a 30% end-to-end improvement without changing generated HDL. See [#3338](https://github.com/clash-lang/clash-compiler/pull/3338). +* In `clash-ghc`, GHC-to-Clash type conversion is memoized by GHC type, with unchanged output. Types repeat extensively across binders, and converting one evaluates family-instance reductions and name conversions per node. On larger designs, this roughly halved loading time. See [#3340](https://github.com/clash-lang/clash-compiler/pull/3340). +* In `clash-lib`, `reduceNonRepPrim` dispatches on the primitive's name through a `HashMap` of handlers rather than walking a chain of string comparisons. On larger designs, this produced about a 6% end-to-end improvement. See [#3339](https://github.com/clash-lang/clash-compiler/pull/3339). +* In `clash-lib`, beta-reduction in the `appProp` transformation now uses a sharing-preserving substitution that leaves unchanged subterms untouched instead of rebuilding every visited node. Output is unchanged. See [#3341](https://github.com/clash-lang/clash-compiler/pull/3341). +* In `clash-lib`, the inlining transformations (`inlineWorkFree`, `inlineSmall`, `bindConstantVar`) now run cheap binder-only guards before computing type information, skip attempts at inner application-spine nodes, and stop measuring term size once it exceeds the inline limit. On larger designs, this reduced compiler runtime by about 8%. See [#3356](https://github.com/clash-lang/clash-compiler/pull/3356). + +Added: +* Blackboxes `~SYM`s can now be referenced by name + + Instead of doing: + ``` + signal ~GENSYM[foo][3] : ..; + signal ~GENSYM[bar][4] : ..; + + .. <= ~SYM[3] - ~SYM[4]; + ``` + + You can now refer to SYMbols by name: + ``` + signal ~SYM[foo] : ..; + signal ~SYM[bar] : ..; + + .. <= ~SYM[foo] - ~SYM[bar]; + ``` + + The old behaviour with `~GENSYM` and the numeric references is still fully supported. + + See [#3325](https://github.com/clash-lang/clash-compiler/issues/3325), implemented in [#3326](https://github.com/clash-lang/clash-compiler/pull/3326). +* `clash-lib` now provides `Hashable Term` and `Hashable Type` instances. These were removed in Clash 1.4.7 due to a faulty implementation, but are now back. They hash modulo alpha equivalence, and so agree with `Eq Term` and `Eq Type`: alpha-equivalent terms hash alike. See [#3336](https://github.com/clash-lang/clash-compiler/pull/3336). + +Changed: +* `clash-cosim` and `clash-ffi` packages have been removed from the `clash-compiler` repository and moved to standalone archived repositories. See [#3330](https://github.com/clash-lang/clash-compiler/pull/3330). +* The `clash` command-line flag `-fclash-debug-count-transformations` now also reports how often each transformation was attempted (counters suffixed `!try`), next to the existing applied-rewrite counts. See [#3356](https://github.com/clash-lang/clash-compiler/pull/3356). + +Fixed: +* In `clash-lib`, alpha-equivalence on terms now compares the `NameMod` and `Attributes` of a tick under the enclosing renaming environment, instead of in isolation. See [#3335](https://github.com/clash-lang/clash-compiler/pull/3335). +* In `clash-lib`, `freshenTm` now renames inside of an `Attributes` tick, added by `Clash.Annotations.SynthesisAttributes.annotateReg`. See [#3335](https://github.com/clash-lang/clash-compiler/pull/3335). +* In `clash-lib`, alpha-equivalence and alpha-comparison on terms now compare the types of `Rec` let binders, which they previously ignored. A `NonRec` binder's type is pinned down by its right-hand side, so it does not need comparing, but a `Rec` binder may occur in its own right-hand side, so its type is not determined by the right-hand side: `let x = x in x` is the same term whether `x` is an `Int` or a `Bool`. `eqTerm` already compared them, so `Eq Term` and `eqTerm` disagreed on such terms. See [#3335](https://github.com/clash-lang/clash-compiler/pull/3335). +* In `clash-lib`, `Ord Term` and `Ord Type` now behave lawfully. Comparison used to rename each pair of binders to a variable free in neither argument, preferring the left one, so which name an occurrence resolved to depended on which argument came first: `compare` on `forall a. forall b. b` and `forall c. forall d. c` returned `GT` whichever way round they were passed. See [#3335](https://github.com/clash-lang/clash-compiler/pull/3335). +* In `clash-lib`, `reduceNonRepPrim` now pierces through type families, `newtype`s and `Signal` constructors when determining a primitive's result type. See [#3339](https://github.com/clash-lang/clash-compiler/pull/3339). +* In `clash-lib`, the disjoint expression consolidation (DEC) transformation created non-exhaustive case-expressions when the consolidated function was not applied in every alternative. When constant propagation later reduced such a case-expression, compilation failed with `Clash error call: scrutinise: ...`. The argument-selecting case-expressions now carry a default alternative for the branches in which the consolidated function is not used [#2770](https://github.com/clash-lang/clash-compiler/issues/2770). See [#3344](https://github.com/clash-lang/clash-compiler/pull/3344). +* In `clash-ghc`, type family applications no longer get stuck when the top entity's module is loaded from an interface file and nothing else in the design causes the interfaces holding the needed family instances to be read. This made designs mentioning e.g. `BitVector (BitSize Bool)` behind another type family fail with `Cannot reduce to an integer`. See [#1534](https://github.com/clash-lang/clash-compiler/issues/1534), fixed in [#3343](https://github.com/clash-lang/clash-compiler/pull/3343). +* In `clash-lib`, `reduceNonRepPrim` now correctly accounts for non-work primitives returning a zero-length `Vec` and under-applied ones. See [#3348](https://github.com/clash-lang/clash-compiler/issues/3348), fixed in [#3349](https://github.com/clash-lang/clash-compiler/pull/3349). +* Name-shadowing warnings caused by blackboxes re-using identifiers has been fixed. See [#3273](https://github.com/clash-lang/clash-compiler/issues/3273), fixed in [#3353](https://github.com/clash-lang/clash-compiler/pull/3353). +* In `clash-ghc`, Clash no longer enables `-dynamic-too` when the build is already dynamic, which made GHC emit an `-Winconsistent-flags` warning. See [#3354](https://github.com/clash-lang/clash-compiler/issues/3354), fixed in [#3358](https://github.com/clash-lang/clash-compiler/pull/3358). +* In `clash-lib`, the SystemVerilog backend no longer emits out-of-bounds array indices when a nested modifier selects a half of an `RTree`. The size of a tree half was computed as `(d-1)^2` instead of `2^(d-1)`, so for an `RTree 3` the right half was emitted as `[4:8]` on an array whose valid indices are `0..7`. See [#3359](https://github.com/clash-lang/clash-compiler/issues/3359), fixed in [#3360](https://github.com/clash-lang/clash-compiler/pull/3360). +* In `clash-lib` and `clash-ghc`, structural equality and ordering now account for the names and types of variables, including in `eqTerm` and `eqType`, instead of relying only on variable uniques. See [#3361](https://github.com/clash-lang/clash-compiler/issues/3361), fixed in [#3362](https://github.com/clash-lang/clash-compiler/pull/3362). + ## 1.10.1 *Aug 27th, 2026* Highlights: diff --git a/clash-lib.cabal b/clash-lib.cabal --- a/clash-lib.cabal +++ b/clash-lib.cabal @@ -1,6 +1,6 @@ Cabal-version: 2.2 Name: clash-lib -Version: 1.10.1 +Version: 1.10.2 Synopsis: Clash: a functional hardware description language - As a library Description: Clash is a functional hardware description language that borrows both its @@ -155,7 +155,7 @@ base16-bytestring >= 0.1.1 && < 1.1, binary >= 0.8.5 && < 0.11, bytestring >= 0.10.0.2 && < 0.13, - clash-prelude == 1.10.1, + clash-prelude == 1.10.2, containers >= 0.6.7 && < 0.9, cryptohash-sha256 >= 0.11 && < 0.12, data-default >= 0.7 && < 0.9, @@ -412,6 +412,7 @@ containers, data-default, deepseq, + hashable, haskell-src-exts, ghc, lens, @@ -426,7 +427,9 @@ transformers, unordered-containers - Other-Modules: Clash.Tests.Core.FreeVars + Other-Modules: Clash.Tests.Core.AlphaEquivalence + Clash.Tests.Core.FreeVars + Clash.Tests.Core.StructuralEquivalence Clash.Tests.Core.Subst Clash.Tests.Core.TermLiteral Clash.Tests.Core.TermLiteral.Types diff --git a/prims/vhdl/Clash_Explicit_BlockRam_File.primitives.yaml b/prims/vhdl/Clash_Explicit_BlockRam_File.primitives.yaml --- a/prims/vhdl/Clash_Explicit_BlockRam_File.primitives.yaml +++ b/prims/vhdl/Clash_Explicit_BlockRam_File.primitives.yaml @@ -21,16 +21,16 @@ ~GENSYM[~COMPNAME_blockRamFile][1] : block type ~GENSYM[RamType][7] is array(natural range <>) of bit_vector(~LIT[1]-1 downto 0); - impure function ~GENSYM[InitRamFromFile][2] (RamFileName : in string) return ~SYM[7] is - FILE RamFile : text open read_mode is RamFileName; - variable RamFileLine : line; - variable RAM : ~SYM[7](0 to ~LIT[5]-1); + impure function ~GENSYM[InitRamFromFile][2] (~SYM[RamFileName] : in string) return ~SYM[7] is + FILE ~SYM[RamFile] : text open read_mode is ~SYM[RamFileName]; + variable ~SYM[RamFileLine] : line; + variable ~SYM[RAM_contents] : ~SYM[7](0 to ~LIT[5]-1); begin - for i in RAM'range loop - readline(RamFile,RamFileLine); - read(RamFileLine,RAM(i)); + for ~SYM[i] in ~SYM[RAM_contents]'range loop + readline(~SYM[RamFile],~SYM[RamFileLine]); + read(~SYM[RamFileLine],~SYM[RAM_contents](~SYM[i])); end loop; - return RAM; + return ~SYM[RAM_contents]; end function; signal ~GENSYM[RAM][3] : ~SYM[7](0 to ~LIT[5]-1) := ~SYM[2](~FILE[~LIT[6]]); diff --git a/prims/vhdl/Clash_Explicit_ROM_File.primitives.yaml b/prims/vhdl/Clash_Explicit_ROM_File.primitives.yaml --- a/prims/vhdl/Clash_Explicit_ROM_File.primitives.yaml +++ b/prims/vhdl/Clash_Explicit_ROM_File.primitives.yaml @@ -16,22 +16,22 @@ ~GENSYM[~COMPNAME_romFile][0] : block type ~GENSYM[RomType][4] is array(natural range <>) of bit_vector(~LIT[0]-1 downto 0); - impure function ~GENSYM[InitRomFromFile][1] (RomFileName : in string) return ~SYM[4] is - FILE RomFile : text open read_mode is RomFileName; - variable RomFileLine : line; - variable ROM : ~SYM[4](0 to ~LIT[4]-1); + impure function ~GENSYM[InitRomFromFile][1] (~SYM[RomFileName] : in string) return ~SYM[4] is + FILE ~SYM[RomFile] : text open read_mode is ~SYM[RomFileName]; + variable ~SYM[RomFileLine] : line; + variable ~SYM[ROM_contents] : ~SYM[4](0 to ~LIT[4]-1); begin - for i in ROM'range loop - readline(RomFile,RomFileLine); - read(RomFileLine,ROM(i)); + for ~SYM[i] in ~SYM[ROM_contents]'range loop + readline(~SYM[RomFile],~SYM[RomFileLine]); + read(~SYM[RomFileLine],~SYM[ROM_contents](~SYM[i])); end loop; - return ROM; + return ~SYM[ROM_contents]; end function; signal ~GENSYM[ROM][2] : ~SYM[4](0 to ~LIT[4]-1) := ~SYM[1](~FILE[~LIT[5]]); signal ~GENSYM[rd][3] : integer range 0 to ~LIT[4]-1; begin - ~SYM[3] <=to_integer(~VAR[rdI][6](31 downto 0)) + ~SYM[3] <= to_integer(~VAR[rdI][6](31 downto 0)) -- pragma translate_off mod ~LIT[4] -- pragma translate_on diff --git a/prims/vhdl/Clash_Prelude_ROM_File.primitives.yaml b/prims/vhdl/Clash_Prelude_ROM_File.primitives.yaml --- a/prims/vhdl/Clash_Prelude_ROM_File.primitives.yaml +++ b/prims/vhdl/Clash_Prelude_ROM_File.primitives.yaml @@ -12,16 +12,16 @@ ~GENSYM[asyncROMFile][0] : block type ~GENSYM[RomType][4] is array(natural range <>) of bit_vector(~LIT[0]-1 downto 0); - impure function ~GENSYM[InitRomFromFile][1] (RomFileName : in string) return ~SYM[4] is - FILE RomFile : text open read_mode is RomFileName; - variable RomFileLine : line; - variable ROM : ~SYM[4](0 to ~LIT[1]-1); + impure function ~GENSYM[InitRomFromFile][1] (~SYM[RomFileName] : in string) return ~SYM[4] is + FILE ~SYM[RomFile] : text open read_mode is ~SYM[RomFileName]; + variable ~SYM[RomFileLine] : line; + variable ~SYM[ROM_contents] : ~SYM[4](0 to ~LIT[1]-1); begin - for i in ROM'range loop - readline(RomFile,RomFileLine); - read(RomFileLine,ROM(i)); + for ~SYM[i] in ~SYM[ROM_contents]'range loop + readline(~SYM[RomFile],~SYM[RomFileLine]); + read(~SYM[RomFileLine],~SYM[ROM_contents](~SYM[i])); end loop; - return ROM; + return ~SYM[ROM_contents]; end function; signal ~GENSYM[ROM][2] : ~SYM[4](0 to ~LIT[1]-1) := ~SYM[1](~FILE[~LIT[2]]); diff --git a/prims/vhdl/Clash_Sized_Internal_BitVector.primitives.yaml b/prims/vhdl/Clash_Sized_Internal_BitVector.primitives.yaml --- a/prims/vhdl/Clash_Sized_Internal_BitVector.primitives.yaml +++ b/prims/vhdl/Clash_Sized_Internal_BitVector.primitives.yaml @@ -118,32 +118,32 @@ type: 'reduceAnd# :: KnownNat n => BitVector n -> Bit' template: |- - -- reduceAnd begin, + -- reduceAnd begin ~IF~SIZE[~TYP[1]]~THEN - ~GENSYM[reduceAnd][0] : block - function and_reduce (arg : std_logic_vector) return std_logic is - variable upper, lower : std_logic; - variable half : integer; - variable argi : std_logic_vector (arg'length - 1 downto 0); - variable result : std_logic; + ~SYM[reduceAnd] : block + function ~SYM[and_reduce] (~SYM[arg] : std_logic_vector) return std_logic is + variable ~SYM[upper], ~SYM[lower] : std_logic; + variable ~SYM[half] : integer; + variable ~SYM[argi] : std_logic_vector (~SYM[arg]'length - 1 downto 0); + variable ~SYM[result] : std_logic; begin - if (arg'length < 1) then - result := '1'; + if (~SYM[arg]'length < 1) then + ~SYM[result] := '1'; else - argi := arg; - if (argi'length = 1) then - result := argi(argi'left); + ~SYM[argi] := ~SYM[arg]; + if (~SYM[argi]'length = 1) then + ~SYM[result] := ~SYM[argi](~SYM[argi]'left); else - half := (argi'length + 1) / 2; -- lsb-biased tree - upper := and_reduce (argi (argi'left downto half)); - lower := and_reduce (argi (half - 1 downto argi'right)); - result := upper and lower; + ~SYM[half] := (~SYM[argi]'length + 1) / 2; -- lsb-biased tree + ~SYM[upper] := ~SYM[and_reduce] (~SYM[argi] (~SYM[argi]'left downto ~SYM[half])); + ~SYM[lower] := ~SYM[and_reduce] (~SYM[argi] (~SYM[half] - 1 downto ~SYM[argi]'right)); + ~SYM[result] := ~SYM[upper] and ~SYM[lower]; end if; end if; - return result; + return ~SYM[result]; end; begin - ~RESULT <= and_reduce(~ARG[1]); + ~RESULT <= ~SYM[and_reduce](~ARG[1]); end block;~ELSE ~RESULT <= '1';~FI -- reduceAnd end @@ -155,29 +155,29 @@ template: |- -- reduceOr begin ~IF~SIZE[~TYP[1]]~THEN ~GENSYM[reduceOr][0] : block - function or_reduce (arg : std_logic_vector) return std_logic is - variable upper, lower : std_logic; - variable half : integer; - variable argi : std_logic_vector (arg'length - 1 downto 0); - variable result : std_logic; + function ~SYM[or_reduce] (~SYM[arg] : std_logic_vector) return std_logic is + variable ~SYM[upper], ~SYM[lower] : std_logic; + variable ~SYM[half] : integer; + variable ~SYM[argi] : std_logic_vector (~SYM[arg]'length - 1 downto 0); + variable ~SYM[result] : std_logic; begin - if (arg'length < 1) then - result := '0'; + if (~SYM[arg]'length < 1) then + ~SYM[result] := '0'; else - argi := arg; - if (argi'length = 1) then - result := argi(argi'left); + ~SYM[argi] := ~SYM[arg]; + if (~SYM[argi]'length = 1) then + ~SYM[result] := ~SYM[argi](~SYM[argi]'left); else - half := (argi'length + 1) / 2; -- lsb-biased tree - upper := or_reduce (argi (argi'left downto half)); - lower := or_reduce (argi (half - 1 downto argi'right)); - result := upper or lower; + ~SYM[half] := (~SYM[argi]'length + 1) / 2; -- lsb-biased tree + ~SYM[upper] := ~SYM[or_reduce] (~SYM[argi] (~SYM[argi]'left downto ~SYM[half])); + ~SYM[lower] := ~SYM[or_reduce] (~SYM[argi] (~SYM[half] - 1 downto ~SYM[argi]'right)); + ~SYM[result] := ~SYM[upper] or ~SYM[lower]; end if; end if; - return result; + return ~SYM[result]; end; begin - ~RESULT <= or_reduce(~ARG[1]); + ~RESULT <= ~SYM[or_reduce](~ARG[1]); end block;~ELSE ~RESULT <= '0'; ~FI -- reduceOr end @@ -189,29 +189,29 @@ template: |- -- reduceXor begin ~IF~SIZE[~TYP[1]]~THEN ~GENSYM[reduceXor][0] : block - function xor_reduce (arg : std_logic_vector) return std_logic is - variable upper, lower : std_logic; - variable half : integer; - variable argi : std_logic_vector (arg'length - 1 downto 0); - variable result : std_logic; + function ~SYM[xor_reduce] (~SYM[arg] : std_logic_vector) return std_logic is + variable ~SYM[upper], ~SYM[lower] : std_logic; + variable ~SYM[half] : integer; + variable ~SYM[argi] : std_logic_vector (~SYM[arg]'length - 1 downto 0); + variable ~SYM[result] : std_logic; begin - if (arg'length < 1) then - result := '0'; + if (~SYM[arg]'length < 1) then + ~SYM[result] := '0'; else - argi := arg; - if (argi'length = 1) then - result := argi(argi'left); + ~SYM[argi] := ~SYM[arg]; + if (~SYM[argi]'length = 1) then + ~SYM[result] := ~SYM[argi](~SYM[argi]'left); else - half := (argi'length + 1) / 2; -- lsb-biased tree - upper := xor_reduce (argi (argi'left downto half)); - lower := xor_reduce (argi (half - 1 downto argi'right)); - result := upper xor lower; + ~SYM[half] := (~SYM[argi]'length + 1) / 2; -- lsb-biased tree + ~SYM[upper] := ~SYM[xor_reduce] (~SYM[argi] (~SYM[argi]'left downto ~SYM[half])); + ~SYM[lower] := ~SYM[xor_reduce] (~SYM[argi] (~SYM[half] - 1 downto ~SYM[argi]'right)); + ~SYM[result] := ~SYM[upper] xor ~SYM[lower]; end if; end if; - return result; + return ~SYM[result]; end; begin - ~RESULT <= xor_reduce(~ARG[1]); + ~RESULT <= ~SYM[xor_reduce](~ARG[1]); end block;~ELSE ~RESULT <= '0';~FI -- reduceXor end diff --git a/prims/vhdl/Clash_Sized_Vector.primitives.yaml b/prims/vhdl/Clash_Sized_Vector.primitives.yaml --- a/prims/vhdl/Clash_Sized_Vector.primitives.yaml +++ b/prims/vhdl/Clash_Sized_Vector.primitives.yaml @@ -116,10 +116,10 @@ template: |- -- imap begin ~GENSYM[imap][0] : block - function ~GENSYM[max][6] (l,r : in natural) return natural is + function ~GENSYM[max][6] (~SYM[l],~SYM[r] : in natural) return natural is begin - if l > r then return l; - else return r; + if ~SYM[l] > ~SYM[r] then return ~SYM[l]; + else return ~SYM[r]; end if; end function; begin @@ -217,7 +217,7 @@ begin ~SYM[2](~LENGTH[~TYP[2]]) <= ~ARG[1]; - foldr_loop : for ~GENSYM[i][3] in 0 to (~LENGTH[~TYP[2]] - 1) generate~IF ~VIVADO ~THEN~IF~SIZE[~TYP[2]]~THEN + ~SYM[foldr_loop] : for ~GENSYM[i][3] in 0 to (~LENGTH[~TYP[2]] - 1) generate~IF ~VIVADO ~THEN~IF~SIZE[~TYP[2]]~THEN signal ~GENSYM[foldr_in][4] : ~TYPEL[~TYP[2]];~ELSE ~FI begin~IF~SIZE[~TYP[2]]~THEN ~SYM[4] <= fromSLV(~VAR[vec][2](~SYM[3]));~ELSE ~FI diff --git a/prims/vhdl/GHC_Prim.primitives.yaml b/prims/vhdl/GHC_Prim.primitives.yaml --- a/prims/vhdl/GHC_Prim.primitives.yaml +++ b/prims/vhdl/GHC_Prim.primitives.yaml @@ -361,725 +361,845 @@ ~GENSYM[popCnt8][0] : block -- given a level and a depth, calculate the corresponding index into the -- intermediate array - function ~GENSYM[depth2Index][1] (levels,depth : in natural) return natural is - begin - return (2 ** levels - 2 ** depth); - end function; - - constant ~GENSYM[width][2] : natural := 8; - constant ~GENSYM[levels][3] : natural := natural (ceil (log2 (real (~SYM[2])))); - type ~GENSYM[popCnt_res_vec][4] is array (natural range <>) of unsigned(~SYM[3] downto 0); - signal ~GENSYM[intermediate][5] : ~SYM[4](0 to (2*~SYM[2])-2); - begin - -- put input into the first half of the intermediate array - ~GENSYM[make_array][6]: for ~GENSYM[i][7] in 0 to (~SYM[2] - 1) generate - ~SYM[5](~SYM[7]) <= resize(~VAR[input][0](~SYM[7] downto ~SYM[7]),~SYM[3]+1); - end generate; - - -- Create the tree of adders - ~GENSYM[make_tree][8] : if ~SYM[3] /= 0 generate - ~GENSYM[tree_depth][9] : for ~GENSYM[d][10] in ~SYM[3]-1 downto 0 generate - ~GENSYM[tree_depth_loop][11] : for ~GENSYM[i][12] in 0 to (natural(2**~SYM[10]) - 1) generate - ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+1)+~SYM[12]) <= - ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])) + - ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])+1); - end generate; - end generate; - end generate; - - -- The last element of the intermediate array holds the result - ~RESULT <= resize(~SYM[5]((2*~SYM[2])-2),~SIZE[~TYPO]); - end block; - -- popCnt8 end -- BlackBox: - name: GHC.Prim.popCnt16# - kind: Declaration - type: 'popCnt16 :: Word# - -> Word#' - template: |- - -- popCnt16 begin - ~GENSYM[popCnt16][0] : block - -- given a level and a depth, calculate the corresponding index into the - -- intermediate array - function ~GENSYM[depth2Index][1] (levels,depth : in natural) return natural is - begin - return (2 ** levels - 2 ** depth); - end function; - - constant ~GENSYM[width][2] : natural := 16; - constant ~GENSYM[levels][3] : natural := natural (ceil (log2 (real (~SYM[2])))); - type ~GENSYM[popCnt_res_vec][4] is array (natural range <>) of unsigned(~SYM[3] downto 0); - signal ~GENSYM[intermediate][5] : ~SYM[4](0 to (2*~SYM[2])-2); - begin - -- put input into the first half of the intermediate array - ~GENSYM[make_array][6]: for ~GENSYM[i][7] in 0 to (~SYM[2] - 1) generate - ~SYM[5](~SYM[7]) <= resize(~VAR[input][0](~SYM[7] downto ~SYM[7]),~SYM[3]+1); - end generate; - - -- Create the tree of adders - ~GENSYM[make_tree][8] : if ~SYM[3] /= 0 generate - ~GENSYM[tree_depth][9] : for ~GENSYM[d][10] in ~SYM[3]-1 downto 0 generate - ~GENSYM[tree_depth_loop][11] : for ~GENSYM[i][12] in 0 to (natural(2**~SYM[10]) - 1) generate - ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+1)+~SYM[12]) <= - ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])) + - ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])+1); - end generate; - end generate; - end generate; - - -- The last element of the intermediate array holds the result - ~RESULT <= resize(~SYM[5]((2*~SYM[2])-2),~SIZE[~TYPO]); - end block; - -- popCnt16 end -- BlackBox: - name: GHC.Prim.popCnt32# - kind: Declaration - type: 'popCnt32 :: Word# - -> Word#' - template: |- - -- popCnt32 begin - ~GENSYM[popCnt32][0] : block - -- given a level and a depth, calculate the corresponding index into the - -- intermediate array - function ~GENSYM[depth2Index][1] (levels,depth : in natural) return natural is - begin - return (2 ** levels - 2 ** depth); - end function; - - constant ~GENSYM[width][2] : natural := 32; - constant ~GENSYM[levels][3] : natural := natural (ceil (log2 (real (~SYM[2])))); - type ~GENSYM[popCnt_res_vec][4] is array (natural range <>) of unsigned(~SYM[3] downto 0); - signal ~GENSYM[intermediate][5] : ~SYM[4](0 to (2*~SYM[2])-2); - begin - -- put input into the first half of the intermediate array - ~GENSYM[make_array][6]: for ~GENSYM[i][7] in 0 to (~SYM[2] - 1) generate - ~SYM[5](~SYM[7]) <= resize(~VAR[input][0](~SYM[7] downto ~SYM[7]),~SYM[3]+1); - end generate; - - -- Create the tree of adders - ~GENSYM[make_tree][8] : if ~SYM[3] /= 0 generate - ~GENSYM[tree_depth][9] : for ~GENSYM[d][10] in ~SYM[3]-1 downto 0 generate - ~GENSYM[tree_depth_loop][11] : for ~GENSYM[i][12] in 0 to (natural(2**~SYM[10]) - 1) generate - ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+1)+~SYM[12]) <= - ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])) + - ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])+1); - end generate; - end generate; - end generate; - - -- The last element of the intermediate array holds the result - ~RESULT <= resize(~SYM[5]((2*~SYM[2])-2),~SIZE[~TYPO]); - end block; - -- popCnt32 end -- BlackBox: - name: GHC.Prim.popCnt64# - kind: Declaration - type: 'popCnt64 :: Word# - -> Word#' - template: |- - -- popCnt64 begin - ~GENSYM[popCnt64][0] : block - -- given a level and a depth, calculate the corresponding index into the - -- intermediate array - function ~GENSYM[depth2Index][1] (levels,depth : in natural) return natural is - begin - return (2 ** levels - 2 ** depth); - end function; - - constant ~GENSYM[width][2] : natural := 64; - constant ~GENSYM[levels][3] : natural := natural (ceil (log2 (real (~SYM[2])))); - type ~GENSYM[popCnt_res_vec][4] is array (natural range <>) of unsigned(~SYM[3] downto 0); - signal ~GENSYM[intermediate][5] : ~SYM[4](0 to (2*~SYM[2])-2); - begin - -- put input into the first half of the intermediate array - ~GENSYM[make_array][6]: for ~GENSYM[i][7] in 0 to (~SYM[2] - 1) generate - ~SYM[5](~SYM[7]) <= resize(~VAR[input][0](~SYM[7] downto ~SYM[7]),~SYM[3]+1); - end generate; - - -- Create the tree of adders - ~GENSYM[make_tree][8] : if ~SYM[3] /= 0 generate - ~GENSYM[tree_depth][9] : for ~GENSYM[d][10] in ~SYM[3]-1 downto 0 generate - ~GENSYM[tree_depth_loop][11] : for ~GENSYM[i][12] in 0 to (natural(2**~SYM[10]) - 1) generate - ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+1)+~SYM[12]) <= - ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])) + - ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])+1); - end generate; - end generate; - end generate; - - -- The last element of the intermediate array holds the result - ~RESULT <= resize(~SYM[5]((2*~SYM[2])-2),~SIZE[~TYPO]); - end block; - -- popCnt64 end -- BlackBox: - name: GHC.Prim.popCnt# - kind: Declaration - type: 'popCnt :: Word# - -> Word#' - template: |- - -- popCnt begin - ~GENSYM[popCnt][0] : block - -- given a level and a depth, calculate the corresponding index into the - -- intermediate array - function ~GENSYM[depth2Index][1] (levels,depth : in natural) return natural is - begin - return (2 ** levels - 2 ** depth); - end function; - - constant ~GENSYM[width][2] : natural := ~SIZE[~TYPO]; - constant ~GENSYM[levels][3] : natural := natural (ceil (log2 (real (~SYM[2])))); - type ~GENSYM[popCnt_res_vec][4] is array (natural range <>) of unsigned(~SYM[3] downto 0); - signal ~GENSYM[intermediate][5] : ~SYM[4](0 to (2*~SYM[2])-2); - begin - -- put input into the first half of the intermediate array - ~GENSYM[make_array][6]: for ~GENSYM[i][7] in 0 to (~SYM[2] - 1) generate - ~SYM[5](~SYM[7]) <= resize(~VAR[input][0](~SYM[7] downto ~SYM[7]),~SYM[3]+1); - end generate; - - -- Create the tree of adders - ~GENSYM[make_tree][8] : if ~SYM[3] /= 0 generate - ~GENSYM[tree_depth][9] : for ~GENSYM[d][10] in ~SYM[3]-1 downto 0 generate - ~GENSYM[tree_depth_loop][11] : for ~GENSYM[i][12] in 0 to (natural(2**~SYM[10]) - 1) generate - ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+1)+~SYM[12]) <= - ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])) + - ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])+1); - end generate; - end generate; - end generate; - - -- The last element of the intermediate array holds the result - ~RESULT <= resize(~SYM[5]((2*~SYM[2])-2),~SIZE[~TYPO]); - end block; - -- popCnt end -- BlackBox: - name: GHC.Prim.clz8# - kind: Declaration - type: 'clz8 :: Word# -> - Word#' - template: |- - -- clz8 begin - ~GENSYM[clz8][0] : block - function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is - begin - case a is - when "00" => return "10"; - when "01" => return "01"; - when "10" => return "00"; - when others => return "00"; - end case; - end function; - - function ~GENSYM[clzi][2] ( - constant n : in natural; - constant i : in unsigned) return unsigned is - variable v : unsigned(i'length-1 downto 0):=i; - begin - if v(n-1+n)='0' then - return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); - else - return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); - end if; - end function; - - function ~GENSYM[clz8][3] (constant v : unsigned(0 to 7)) return unsigned is - variable e : unsigned(0 to 7); -- 8 - variable a : unsigned(0 to 2*3-1); -- 6 - begin - for i in 0 to 3 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; - for i in 0 to 1 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; - return ~SYM[2](3,a(0 to 5)); - end function; - begin - ~RESULT <= resize(~SYM[3](~VAR[][0](7 downto 0)),~SIZE[~TYPO]); - end block; - -- clz8 end -- BlackBox: - name: GHC.Prim.clz16# - kind: Declaration - type: 'clz16 :: Word# - -> Word#' - template: |- - -- clz16 begin - ~GENSYM[clz16][0] : block - function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is - begin - case a is - when "00" => return "10"; - when "01" => return "01"; - when "10" => return "00"; - when others => return "00"; - end case; - end function; - - function ~GENSYM[clzi][2] ( - constant n : in natural; - constant i : in unsigned) return unsigned is - variable v : unsigned(i'length-1 downto 0):=i; - begin - if v(n-1+n)='0' then - return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); - else - return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); - end if; - end function; - - function ~GENSYM[clz16][3] (constant v : unsigned(0 to 15)) return unsigned is - variable e : unsigned(0 to 15); -- 16 - variable a : unsigned(0 to 4*3-1); -- 12 - variable b : unsigned(0 to 2*4-1); -- 8 - begin - for i in 0 to 7 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; - for i in 0 to 3 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; - for i in 0 to 1 loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop; - return ~SYM[2](4,b(0 to 7)); - end function; - begin - ~RESULT <= resize(~SYM[3](~VAR[][0](15 downto 0)),~SIZE[~TYPO]); - end block; - -- clz16 end -- BlackBox: - name: GHC.Prim.clz32# - kind: Declaration - type: 'clz32 :: Word# - -> Word#' - template: |- - -- clz32 begin - ~GENSYM[clz32][0] : block - function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is - begin - case a is - when "00" => return "10"; - when "01" => return "01"; - when "10" => return "00"; - when others => return "00"; - end case; - end function; - - function ~GENSYM[clzi][2] ( - constant n : in natural; - constant i : in unsigned) return unsigned is - variable v : unsigned(i'length-1 downto 0):=i; - begin - if v(n-1+n)='0' then - return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); - else - return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); - end if; - end function; - - function ~GENSYM[clz32][3] (constant v : unsigned(0 to 31)) return unsigned is - variable e : unsigned(0 to 31); -- 32 - variable a : unsigned(0 to 8*3-1); -- 24 - variable b : unsigned(0 to 4*4-1); -- 16 - variable c : unsigned(0 to 2*5-1); -- 10 - begin - for i in 0 to 15 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; - for i in 0 to 7 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; - for i in 0 to 3 loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop; - for i in 0 to 1 loop c(i*5 to i*5+4):=~SYM[2](4,b(i*8 to i*8+7)); end loop; - return ~SYM[2](5,c(0 to 9)); - end function; - begin - ~RESULT <= resize(~SYM[3](~VAR[][0](31 downto 0)),~SIZE[~TYPO]); - end block; - -- clz32 end -- BlackBox: - name: GHC.Prim.clz64# - kind: Declaration - type: 'clz64 :: Word# - -> Word#' - template: |- - -- clz64 begin - ~GENSYM[clz64][0] : block - function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is - begin - case a is - when "00" => return "10"; - when "01" => return "01"; - when "10" => return "00"; - when others => return "00"; - end case; - end function; - - function ~GENSYM[clzi][2] ( - constant n : in natural; - constant i : in unsigned) return unsigned is - variable v : unsigned(i'length-1 downto 0):=i; - begin - if v(n-1+n)='0' then - return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); - else - return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); - end if; - end function; - - function ~GENSYM[clz64][3] (constant v : unsigned(0 to 63)) return unsigned is - variable e : unsigned(0 to 63); -- 64 - variable a : unsigned(0 to 16*3-1); -- 48 - variable b : unsigned(0 to 8*4-1); -- 32 - variable c : unsigned(0 to 4*5-1); -- 20 - variable d : unsigned(0 to 2*6-1); -- 12 - begin - for i in 0 to 31 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; - for i in 0 to 15 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; - for i in 0 to 7 loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop; - for i in 0 to 3 loop c(i*5 to i*5+4):=~SYM[2](4,b(i*8 to i*8+7)); end loop; - for i in 0 to 1 loop d(i*6 to i*6+5):=~SYM[2](5,c(i*10 to i*10+9)); end loop; - return ~SYM[2](6,d(0 to 11)); - end function; - begin - ~RESULT <= resize(~SYM[3](~ARG[0]),~SIZE[~TYPO]); - end block; - -- clz64 end -- BlackBox: - name: GHC.Prim.clz# - kind: Declaration - type: 'clz :: Word# -> - Word#' - template: |- - -- clz begin - ~GENSYM[clz][0] : block - function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is - begin - case a is - when "00" => return "10"; - when "01" => return "01"; - when "10" => return "00"; - when others => return "00"; - end case; - end function; - - function ~GENSYM[clzi][2] ( - constant n : in natural; - constant i : in unsigned) return unsigned is - variable v : unsigned(i'length-1 downto 0):=i; - begin - if v(n-1+n)='0' then - return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); - else - return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); - end if; - end function; - ~IF ~IW64 ~THEN - function ~GENSYM[clz64][3] (constant v : unsigned(0 to 63)) return unsigned is - variable e : unsigned(0 to 63); -- 64 - variable a : unsigned(0 to 16*3-1); -- 48 - variable b : unsigned(0 to 8*4-1); -- 32 - variable c : unsigned(0 to 4*5-1); -- 20 - variable d : unsigned(0 to 2*6-1); -- 12 - begin - for i in 0 to 31 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; - for i in 0 to 15 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; - for i in 0 to 7 loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop; - for i in 0 to 3 loop c(i*5 to i*5+4):=~SYM[2](4,b(i*8 to i*8+7)); end loop; - for i in 0 to 1 loop d(i*6 to i*6+5):=~SYM[2](5,c(i*10 to i*10+9)); end loop; - return ~SYM[2](6,d(0 to 11)); - end function; - ~ELSE - function ~GENSYM[clz32][4] (constant v : unsigned(0 to 31)) return unsigned is - variable e : unsigned(0 to 31); -- 32 - variable a : unsigned(0 to 8*3-1); -- 24 - variable b : unsigned(0 to 4*4-1); -- 16 - variable c : unsigned(0 to 2*5-1); -- 10 - begin - for i in 0 to 15 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; - for i in 0 to 7 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; - for i in 0 to 3 loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop; - for i in 0 to 1 loop c(i*5 to i*5+4):=~SYM[2](4,b(i*8 to i*8+7)); end loop; - return ~SYM[2](5,c(0 to 9)); - end function; - ~FI - begin - ~IF ~IW64 ~THEN - ~RESULT <= resize(~SYM[3](~ARG[0]),~SIZE[~TYPO]); - ~ELSE - ~RESULT <= resize(~SYM[4](~ARG[0]),~SIZE[~TYPO]); - ~FI - end block; - -- clz end -- BlackBox: - name: GHC.Prim.ctz8# - kind: Declaration - type: 'ctz8 :: Word# -> - Word#' - template: |- - -- ctz8 begin - ~GENSYM[ctz8][0] : block - function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is - begin - case a is - when "00" => return "10"; - when "01" => return "01"; - when "10" => return "00"; - when others => return "00"; - end case; - end function; - - function ~GENSYM[clzi][2] ( - constant n : in natural; - constant i : in unsigned) return unsigned is - variable v : unsigned(i'length-1 downto 0):=i; - begin - if v(n-1+n)='0' then - return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); - else - return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); - end if; - end function; - - function ~GENSYM[clz8][3] (constant v : unsigned(0 to 7)) return unsigned is - variable e : unsigned(0 to 7); -- 8 - variable a : unsigned(0 to 2*3-1); -- 6 - begin - for i in 0 to 3 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; - for i in 0 to 1 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; - return ~SYM[2](3,a(0 to 5)); - end function; - - signal ~GENSYM[w_reversed][5] : ~TYP[0]; - begin - ~GENSYM[reverse_loop][6] : for ~GENSYM[n][7] in ~VAR[w][0]'range generate - ~SYM[5](~VAR[w][0]'high - ~SYM[7]) <= ~VAR[w][0](~SYM[7]); - end generate; - ~IF ~IW64 ~THEN - ~RESULT <= resize(~SYM[3](~SYM[5](63 downto 56)),~SIZE[~TYPO]); - ~ELSE - ~RESULT <= resize(~SYM[3](~SYM[5](31 downto 24)),~SIZE[~TYPO]); - ~FI - end block; - -- ctz8 end -- BlackBox: - name: GHC.Prim.ctz16# - kind: Declaration - type: 'ctz16 :: Word# - -> Word#' - template: |- - -- ctz16 begin - ~GENSYM[ctz16][0] : block - function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is - begin - case a is - when "00" => return "10"; - when "01" => return "01"; - when "10" => return "00"; - when others => return "00"; - end case; - end function; - - function ~GENSYM[clzi][2] ( - constant n : in natural; - constant i : in unsigned) return unsigned is - variable v : unsigned(i'length-1 downto 0):=i; - begin - if v(n-1+n)='0' then - return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); - else - return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); - end if; - end function; - - function ~GENSYM[clz16][3] (constant v : unsigned(0 to 15)) return unsigned is - variable e : unsigned(0 to 15); -- 16 - variable a : unsigned(0 to 4*3-1); -- 12 - variable b : unsigned(0 to 2*4-1); -- 8 - begin - for i in 0 to 7 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; - for i in 0 to 3 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; - for i in 0 to 1 loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop; - return ~SYM[2](4,b(0 to 7)); - end function; - - signal ~GENSYM[w_reversed][5] : ~TYP[0]; - begin - ~GENSYM[reverse_loop][6] : for ~GENSYM[n][7] in ~VAR[w][0]'range generate - ~SYM[5](~VAR[w][0]'high - ~SYM[7]) <= ~VAR[w][0](~SYM[7]); - end generate; - ~IF ~IW64 ~THEN - ~RESULT <= resize(~SYM[3](~SYM[5](63 downto 48)),~SIZE[~TYPO]); - ~ELSE - ~RESULT <= resize(~SYM[3](~SYM[5](31 downto 16)),~SIZE[~TYPO]); - ~FI - end block; - -- ctz16 end -- BlackBox: - name: GHC.Prim.ctz32# - kind: Declaration - type: 'ctz32 :: Word# - -> Word#' - template: |- - -- ctz32 begin - ~GENSYM[ctz32][0] : block - function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is - begin - case a is - when "00" => return "10"; - when "01" => return "01"; - when "10" => return "00"; - when others => return "00"; - end case; - end function; - - function ~GENSYM[clzi][2] ( - constant n : in natural; - constant i : in unsigned) return unsigned is - variable v : unsigned(i'length-1 downto 0):=i; - begin - if v(n-1+n)='0' then - return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); - else - return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); - end if; - end function; - - function ~GENSYM[clz32][3] (constant v : unsigned(0 to 31)) return unsigned is - variable e : unsigned(0 to 31); -- 32 - variable a : unsigned(0 to 8*3-1); -- 24 - variable b : unsigned(0 to 4*4-1); -- 16 - variable c : unsigned(0 to 2*5-1); -- 10 - begin - for i in 0 to 15 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; - for i in 0 to 7 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; - for i in 0 to 3 loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop; - for i in 0 to 1 loop c(i*5 to i*5+4):=~SYM[2](4,b(i*8 to i*8+7)); end loop; - return ~SYM[2](5,c(0 to 9)); - end function; - - signal ~GENSYM[w_reversed][5] : ~TYP[0]; - begin - ~GENSYM[reverse_loop][6] : for ~GENSYM[n][7] in ~VAR[w][0]'range generate - ~SYM[5](~VAR[w][0]'high - ~SYM[7]) <= ~VAR[w][0](~SYM[7]); - end generate; - ~IF ~IW64 ~THEN - ~RESULT <= resize(~SYM[3](~SYM[5](63 downto 32)),~SIZE[~TYPO]); - ~ELSE - ~RESULT <= resize(~SYM[3](~SYM[5]),~SIZE[~TYPO]); - ~FI - end block; - -- ctz32 end -- BlackBox: - name: GHC.Prim.ctz64# - kind: Declaration - type: 'ctz64 :: Word# - -> Word#' - template: |- - -- ctz64 begin - ~GENSYM[ctz64][0] : block - function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is - begin - case a is - when "00" => return "10"; - when "01" => return "01"; - when "10" => return "00"; - when others => return "00"; - end case; - end function; - - function ~GENSYM[clzi][2] ( - constant n : in natural; - constant i : in unsigned) return unsigned is - variable v : unsigned(i'length-1 downto 0):=i; - begin - if v(n-1+n)='0' then - return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); - else - return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); - end if; - end function; - - function ~GENSYM[clz64][3] (constant v : unsigned(0 to 63)) return unsigned is - variable e : unsigned(0 to 63); -- 64 - variable a : unsigned(0 to 16*3-1); -- 48 - variable b : unsigned(0 to 8*4-1); -- 32 - variable c : unsigned(0 to 4*5-1); -- 20 - variable d : unsigned(0 to 2*6-1); -- 12 - begin - for i in 0 to 31 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; - for i in 0 to 15 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; - for i in 0 to 7 loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop; - for i in 0 to 3 loop c(i*5 to i*5+4):=~SYM[2](4,b(i*8 to i*8+7)); end loop; - for i in 0 to 1 loop d(i*6 to i*6+5):=~SYM[2](5,c(i*10 to i*10+9)); end loop; - return ~SYM[2](6,d(0 to 11)); - end function; - - signal ~GENSYM[w_reversed][5] : ~TYP[0]; - begin - ~GENSYM[reverse_loop][6] : for ~GENSYM[n][7] in ~VAR[w][0]'range generate - ~SYM[5](~VAR[w][0]'high - ~SYM[7]) <= ~VAR[w][0](~SYM[7]); - end generate; - - ~RESULT <= resize(~SYM[3](~SYM[5]),~SIZE[~TYPO]); - end block; - -- ctz64 end -- BlackBox: - name: GHC.Prim.ctz# - kind: Declaration - type: 'ctz :: Word# -> - Word#' - template: |- - -- ctz begin - ~GENSYM[ctz][0] : block - function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is - begin - case a is - when "00" => return "10"; - when "01" => return "01"; - when "10" => return "00"; - when others => return "00"; - end case; - end function; - - function ~GENSYM[clzi][2] ( - constant n : in natural; - constant i : in unsigned) return unsigned is - variable v : unsigned(i'length-1 downto 0):=i; - begin - if v(n-1+n)='0' then - return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); - else - return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); - end if; - end function; - - ~IF ~IW64 ~THEN - function ~GENSYM[clz64][3] (constant v : unsigned(0 to 63)) return unsigned is - variable e : unsigned(0 to 63); -- 64 - variable a : unsigned(0 to 16*3-1); -- 48 - variable b : unsigned(0 to 8*4-1); -- 32 - variable c : unsigned(0 to 4*5-1); -- 20 - variable d : unsigned(0 to 2*6-1); -- 12 - begin - for i in 0 to 31 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; - for i in 0 to 15 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; - for i in 0 to 7 loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop; - for i in 0 to 3 loop c(i*5 to i*5+4):=~SYM[2](4,b(i*8 to i*8+7)); end loop; - for i in 0 to 1 loop d(i*6 to i*6+5):=~SYM[2](5,c(i*10 to i*10+9)); end loop; - return ~SYM[2](6,d(0 to 11)); - end function; - ~ELSE - function ~GENSYM[clz32][4] (constant v : unsigned(0 to 31)) return unsigned is - variable e : unsigned(0 to 31); -- 32 - variable a : unsigned(0 to 8*3-1); -- 24 - variable b : unsigned(0 to 4*4-1); -- 16 - variable c : unsigned(0 to 2*5-1); -- 10 - begin - for i in 0 to 15 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; - for i in 0 to 7 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; - for i in 0 to 3 loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop; - for i in 0 to 1 loop c(i*5 to i*5+4):=~SYM[2](4,b(i*8 to i*8+7)); end loop; - return ~SYM[2](5,c(0 to 9)); - end function; - ~FI - - signal ~GENSYM[w_reversed][6] : ~TYP[0]; - begin - ~GENSYM[reverse_loop][7] : for ~GENSYM[n][8] in ~VAR[w][0]'range generate - ~SYM[6](~VAR[w][0]'high - ~SYM[8]) <= ~VAR[w][0](~SYM[8]); - end generate; - ~IF ~IW64 ~THEN - ~RESULT <= resize(~SYM[3](~SYM[6]),~SIZE[~TYPO]); - ~ELSE - ~RESULT <= resize(~SYM[4](~SYM[6]),~SIZE[~TYPO]); - ~FI + function ~GENSYM[depth2Index][1] (~SYM[levelsIn],~SYM[depthIn] : in natural) return natural is + begin + return (2 ** ~SYM[levelsIn] - 2 ** ~SYM[depthIn]); + end function; + + constant ~GENSYM[width][2] : natural := 8; + constant ~GENSYM[levels][3] : natural := natural (ceil (log2 (real (~SYM[2])))); + type ~GENSYM[popCnt_res_vec][4] is array (natural range <>) of unsigned(~SYM[3] downto 0); + signal ~GENSYM[intermediate][5] : ~SYM[4](0 to (2*~SYM[2])-2); + begin + -- put input into the first half of the intermediate array + ~GENSYM[make_array][6]: for ~GENSYM[i][7] in 0 to (~SYM[2] - 1) generate + ~SYM[5](~SYM[7]) <= resize(~VAR[input][0](~SYM[7] downto ~SYM[7]),~SYM[3]+1); + end generate; + + -- Create the tree of adders + ~GENSYM[make_tree][8] : if ~SYM[3] /= 0 generate + ~GENSYM[tree_depth][9] : for ~GENSYM[d][10] in ~SYM[3]-1 downto 0 generate + ~GENSYM[tree_depth_loop][11] : for ~GENSYM[i][12] in 0 to (natural(2**~SYM[10]) - 1) generate + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+1)+~SYM[12]) <= + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])) + + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])+1); + end generate; + end generate; + end generate; + + -- The last element of the intermediate array holds the result + ~RESULT <= resize(~SYM[5]((2*~SYM[2])-2),~SIZE[~TYPO]); + end block; + -- popCnt8 end +- BlackBox: + name: GHC.Prim.popCnt16# + kind: Declaration + type: 'popCnt16 :: Word# + -> Word#' + template: |- + -- popCnt16 begin + ~GENSYM[popCnt16][0] : block + -- given a level and a depth, calculate the corresponding index into the + -- intermediate array + function ~GENSYM[depth2Index][1] (~SYM[levelsIn],~SYM[depthIn] : in natural) return natural is + begin + return (2 ** ~SYM[levelsIn] - 2 ** ~SYM[depthIn]); + end function; + + constant ~GENSYM[width][2] : natural := 16; + constant ~GENSYM[levels][3] : natural := natural (ceil (log2 (real (~SYM[2])))); + type ~GENSYM[popCnt_res_vec][4] is array (natural range <>) of unsigned(~SYM[3] downto 0); + signal ~GENSYM[intermediate][5] : ~SYM[4](0 to (2*~SYM[2])-2); + begin + -- put input into the first half of the intermediate array + ~GENSYM[make_array][6]: for ~GENSYM[i][7] in 0 to (~SYM[2] - 1) generate + ~SYM[5](~SYM[7]) <= resize(~VAR[input][0](~SYM[7] downto ~SYM[7]),~SYM[3]+1); + end generate; + + -- Create the tree of adders + ~GENSYM[make_tree][8] : if ~SYM[3] /= 0 generate + ~GENSYM[tree_depth][9] : for ~GENSYM[d][10] in ~SYM[3]-1 downto 0 generate + ~GENSYM[tree_depth_loop][11] : for ~GENSYM[i][12] in 0 to (natural(2**~SYM[10]) - 1) generate + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+1)+~SYM[12]) <= + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])) + + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])+1); + end generate; + end generate; + end generate; + + -- The last element of the intermediate array holds the result + ~RESULT <= resize(~SYM[5]((2*~SYM[2])-2),~SIZE[~TYPO]); + end block; + -- popCnt16 end +- BlackBox: + name: GHC.Prim.popCnt32# + kind: Declaration + type: 'popCnt32 :: Word# + -> Word#' + template: |- + -- popCnt32 begin + ~GENSYM[popCnt32][0] : block + -- given a level and a depth, calculate the corresponding index into the + -- intermediate array + function ~GENSYM[depth2Index][1] (~SYM[levelsIn],~SYM[depthIn] : in natural) return natural is + begin + return (2 ** ~SYM[levelsIn] - 2 ** ~SYM[depthIn]); + end function; + + constant ~GENSYM[width][2] : natural := 32; + constant ~GENSYM[levels][3] : natural := natural (ceil (log2 (real (~SYM[2])))); + type ~GENSYM[popCnt_res_vec][4] is array (natural range <>) of unsigned(~SYM[3] downto 0); + signal ~GENSYM[intermediate][5] : ~SYM[4](0 to (2*~SYM[2])-2); + begin + -- put input into the first half of the intermediate array + ~GENSYM[make_array][6]: for ~GENSYM[i][7] in 0 to (~SYM[2] - 1) generate + ~SYM[5](~SYM[7]) <= resize(~VAR[input][0](~SYM[7] downto ~SYM[7]),~SYM[3]+1); + end generate; + + -- Create the tree of adders + ~GENSYM[make_tree][8] : if ~SYM[3] /= 0 generate + ~GENSYM[tree_depth][9] : for ~GENSYM[d][10] in ~SYM[3]-1 downto 0 generate + ~GENSYM[tree_depth_loop][11] : for ~GENSYM[i][12] in 0 to (natural(2**~SYM[10]) - 1) generate + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+1)+~SYM[12]) <= + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])) + + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])+1); + end generate; + end generate; + end generate; + + -- The last element of the intermediate array holds the result + ~RESULT <= resize(~SYM[5]((2*~SYM[2])-2),~SIZE[~TYPO]); + end block; + -- popCnt32 end +- BlackBox: + name: GHC.Prim.popCnt64# + kind: Declaration + type: 'popCnt64 :: Word# + -> Word#' + template: |- + -- popCnt64 begin + ~GENSYM[popCnt64][0] : block + -- given a level and a depth, calculate the corresponding index into the + -- intermediate array + function ~GENSYM[depth2Index][1] (~SYM[levelsIn],~SYM[depthIn] : in natural) return natural is + begin + return (2 ** ~SYM[levelsIn] - 2 ** ~SYM[depthIn]); + end function; + + constant ~GENSYM[width][2] : natural := 64; + constant ~GENSYM[levels][3] : natural := natural (ceil (log2 (real (~SYM[2])))); + type ~GENSYM[popCnt_res_vec][4] is array (natural range <>) of unsigned(~SYM[3] downto 0); + signal ~GENSYM[intermediate][5] : ~SYM[4](0 to (2*~SYM[2])-2); + begin + -- put input into the first half of the intermediate array + ~GENSYM[make_array][6]: for ~GENSYM[i][7] in 0 to (~SYM[2] - 1) generate + ~SYM[5](~SYM[7]) <= resize(~VAR[input][0](~SYM[7] downto ~SYM[7]),~SYM[3]+1); + end generate; + + -- Create the tree of adders + ~GENSYM[make_tree][8] : if ~SYM[3] /= 0 generate + ~GENSYM[tree_depth][9] : for ~GENSYM[d][10] in ~SYM[3]-1 downto 0 generate + ~GENSYM[tree_depth_loop][11] : for ~GENSYM[i][12] in 0 to (natural(2**~SYM[10]) - 1) generate + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+1)+~SYM[12]) <= + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])) + + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])+1); + end generate; + end generate; + end generate; + + -- The last element of the intermediate array holds the result + ~RESULT <= resize(~SYM[5]((2*~SYM[2])-2),~SIZE[~TYPO]); + end block; + -- popCnt64 end +- BlackBox: + name: GHC.Prim.popCnt# + kind: Declaration + type: 'popCnt :: Word# + -> Word#' + template: |- + -- popCnt begin + ~GENSYM[popCnt][0] : block + -- given a level and a depth, calculate the corresponding index into the + -- intermediate array + function ~GENSYM[depth2Index][1] (~SYM[levelsIn],~SYM[depthIn] : in natural) return natural is + begin + return (2 ** ~SYM[levelsIn] - 2 ** ~SYM[depthIn]); + end function; + + constant ~GENSYM[width][2] : natural := ~SIZE[~TYPO]; + constant ~GENSYM[levels][3] : natural := natural (ceil (log2 (real (~SYM[2])))); + type ~GENSYM[popCnt_res_vec][4] is array (natural range <>) of unsigned(~SYM[3] downto 0); + signal ~GENSYM[intermediate][5] : ~SYM[4](0 to (2*~SYM[2])-2); + begin + -- put input into the first half of the intermediate array + ~GENSYM[make_array][6]: for ~GENSYM[i][7] in 0 to (~SYM[2] - 1) generate + ~SYM[5](~SYM[7]) <= resize(~VAR[input][0](~SYM[7] downto ~SYM[7]),~SYM[3]+1); + end generate; + + -- Create the tree of adders + ~GENSYM[make_tree][8] : if ~SYM[3] /= 0 generate + ~GENSYM[tree_depth][9] : for ~GENSYM[d][10] in ~SYM[3]-1 downto 0 generate + ~GENSYM[tree_depth_loop][11] : for ~GENSYM[i][12] in 0 to (natural(2**~SYM[10]) - 1) generate + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+1)+~SYM[12]) <= + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])) + + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])+1); + end generate; + end generate; + end generate; + + -- The last element of the intermediate array holds the result + ~RESULT <= resize(~SYM[5]((2*~SYM[2])-2),~SIZE[~TYPO]); + end block; + -- popCnt end +- BlackBox: + name: GHC.Prim.clz8# + kind: Expression + type: 'clz8 :: Word# -> Word#' + imports: + - ~INCLUDENAME[0].all + includes: + - name: clz8 + extension: vhdl + template: |- + -- helper function of GHC.Prim.clz8# + library IEEE; + use IEEE.STD_LOGIC_1164.ALL; + use IEEE.NUMERIC_STD.ALL; + package ~INCLUDENAME[0] is + function clz8 (constant v : unsigned(0 to 7)) return unsigned; + end; + + package body ~INCLUDENAME[0] is + function enc (constant a : unsigned(1 downto 0)) return unsigned is + begin + case a is + when "00" => return "10"; + when "01" => return "01"; + when "10" => return "00"; + when others => return "00"; + end case; + end function; + + function clzi ( + constant n : in natural; + constant i : in unsigned) return unsigned is + variable v : unsigned(i'length-1 downto 0):=i; + begin + if v(n-1+n)='0' then + return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); + else + return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); + end if; + end function; + + function clz8 (constant v : unsigned(0 to 7)) return unsigned is + variable e : unsigned(0 to 7); -- 8 + variable a : unsigned(0 to 2*3-1); -- 6 + begin + for i in 0 to 3 loop e(i*2 to i*2+1):=enc(v(i*2 to i*2+1)); end loop; + for i in 0 to 1 loop a(i*3 to i*3+2):=clzi(2,e(i*4 to i*4+3)); end loop; + return clzi(3,a(0 to 5)); + end function; + end; + template: resize(~INCLUDENAME[0].clz8(~VAR[][0](7 downto 0)),~SIZE[~TYPO]) +- BlackBox: + name: GHC.Prim.clz16# + kind: Expression + type: 'clz16 :: Word# -> Word#' + imports: + - ~INCLUDENAME[0].all + includes: + - name: clz16 + extension: vhdl + template: |- + -- helper function of GHC.Prim.clz16# + library IEEE; + use IEEE.STD_LOGIC_1164.ALL; + use IEEE.NUMERIC_STD.ALL; + package ~INCLUDENAME[0] is + function clz16 (constant v : unsigned(0 to 15)) return unsigned; + end; + + package body ~INCLUDENAME[0] is + function enc (constant a : unsigned(1 downto 0)) return unsigned is + begin + case a is + when "00" => return "10"; + when "01" => return "01"; + when "10" => return "00"; + when others => return "00"; + end case; + end function; + + function clzi ( + constant n : in natural; + constant i : in unsigned) return unsigned is + variable v : unsigned(i'length-1 downto 0):=i; + begin + if v(n-1+n)='0' then + return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); + else + return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); + end if; + end function; + + function clz16 (constant v : unsigned(0 to 15)) return unsigned is + variable e : unsigned(0 to 15); -- 16 + variable a : unsigned(0 to 4*3-1); -- 12 + variable b : unsigned(0 to 2*4-1); -- 8 + begin + for i in 0 to 7 loop e(i*2 to i*2+1):=enc(v(i*2 to i*2+1)); end loop; + for i in 0 to 3 loop a(i*3 to i*3+2):=clzi(2,e(i*4 to i*4+3)); end loop; + for i in 0 to 1 loop b(i*4 to i*4+3):=clzi(3,a(i*6 to i*6+5)); end loop; + return clzi(4,b(0 to 7)); + end function; + end; + template: resize(~INCLUDENAME[0].clz16(~VAR[][0](15 downto 0)),~SIZE[~TYPO]) +- BlackBox: + name: GHC.Prim.clz32# + kind: Expression + type: 'clz32 :: Word# -> Word#' + imports: + - ~INCLUDENAME[0].all + includes: + - name: clz32 + extension: vhdl + template: |- + -- helper function of GHC.Prim.clz32# + library IEEE; + use IEEE.STD_LOGIC_1164.ALL; + use IEEE.NUMERIC_STD.ALL; + package ~INCLUDENAME[0] is + function clz32 (constant v : unsigned(0 to 31)) return unsigned; + end; + + package body ~INCLUDENAME[0] is + function enc (constant a : unsigned(1 downto 0)) return unsigned is + begin + case a is + when "00" => return "10"; + when "01" => return "01"; + when "10" => return "00"; + when others => return "00"; + end case; + end function; + + function clzi ( + constant n : in natural; + constant i : in unsigned) return unsigned is + variable v : unsigned(i'length-1 downto 0):=i; + begin + if v(n-1+n)='0' then + return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); + else + return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); + end if; + end function; + + function clz32 (constant v : unsigned(0 to 31)) return unsigned is + variable e : unsigned(0 to 31); -- 32 + variable a : unsigned(0 to 8*3-1); -- 24 + variable b : unsigned(0 to 4*4-1); -- 16 + variable c : unsigned(0 to 2*5-1); -- 10 + begin + for i in 0 to 15 loop e(i*2 to i*2+1):=enc(v(i*2 to i*2+1)); end loop; + for i in 0 to 7 loop a(i*3 to i*3+2):=clzi(2,e(i*4 to i*4+3)); end loop; + for i in 0 to 3 loop b(i*4 to i*4+3):=clzi(3,a(i*6 to i*6+5)); end loop; + for i in 0 to 1 loop c(i*5 to i*5+4):=clzi(4,b(i*8 to i*8+7)); end loop; + return clzi(5,c(0 to 9)); + end function; + end; + template: resize(~INCLUDENAME[0].clz32(~VAR[][0](31 downto 0)),~SIZE[~TYPO]) + +- BlackBox: + name: GHC.Prim.clz64# + kind: Expression + type: 'clz64 :: Word# -> Word#' + imports: + - ~INCLUDENAME[0].all + includes: + - name: clz64 + extension: vhdl + template: |- + -- helper function of GHC.Prim.clz64# + library IEEE; + use IEEE.STD_LOGIC_1164.ALL; + use IEEE.NUMERIC_STD.ALL; + package ~INCLUDENAME[0] is + function clz64 (constant v : unsigned(0 to 63)) return unsigned; + end; + + package body ~INCLUDENAME[0] is + function enc (constant a : unsigned(1 downto 0)) return unsigned is + begin + case a is + when "00" => return "10"; + when "01" => return "01"; + when "10" => return "00"; + when others => return "00"; + end case; + end function; + + function clzi ( + constant n : in natural; + constant i : in unsigned) return unsigned is + variable v : unsigned(i'length-1 downto 0):=i; + begin + if v(n-1+n)='0' then + return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); + else + return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); + end if; + end function; + + function clz64 (constant v : unsigned(0 to 63)) return unsigned is + variable e : unsigned(0 to 63); -- 64 + variable a : unsigned(0 to 16*3-1); -- 48 + variable b : unsigned(0 to 8*4-1); -- 32 + variable c : unsigned(0 to 4*5-1); -- 20 + variable d : unsigned(0 to 2*6-1); -- 12 + begin + for i in 0 to 31 loop e(i*2 to i*2+1):=enc(v(i*2 to i*2+1)); end loop; + for i in 0 to 15 loop a(i*3 to i*3+2):=clzi(2,e(i*4 to i*4+3)); end loop; + for i in 0 to 7 loop b(i*4 to i*4+3):=clzi(3,a(i*6 to i*6+5)); end loop; + for i in 0 to 3 loop c(i*5 to i*5+4):=clzi(4,b(i*8 to i*8+7)); end loop; + for i in 0 to 1 loop d(i*6 to i*6+5):=clzi(5,c(i*10 to i*10+9)); end loop; + return clzi(6,d(0 to 11)); + end function; + end; + template: resize(~INCLUDENAME[0].clz64(~ARG[0]),~SIZE[~TYPO]) +- BlackBox: + name: GHC.Prim.clz# + kind: Expression + type: 'clz :: Word# -> Word#' + imports: + - ~INCLUDENAME[0].all + includes: + - name: clz + extension: vhdl + template: |- + -- helper function of GHC.Prim.clz# + library IEEE; + use IEEE.STD_LOGIC_1164.ALL; + use IEEE.NUMERIC_STD.ALL; + package ~INCLUDENAME[0] is + ~IF ~IW64 ~THEN + function clz (constant v : unsigned(0 to 63)) return unsigned; + ~ELSE + function clz (constant v : unsigned(0 to 31)) return unsigned; + ~FI + end; + + package body ~INCLUDENAME[0] is + function enc (constant a : unsigned(1 downto 0)) return unsigned is + begin + case a is + when "00" => return "10"; + when "01" => return "01"; + when "10" => return "00"; + when others => return "00"; + end case; + end function; + + function clzi ( + constant n : in natural; + constant i : in unsigned) return unsigned is + variable v : unsigned(i'length-1 downto 0):=i; + begin + if v(n-1+n)='0' then + return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); + else + return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); + end if; + end function; + ~IF ~IW64 ~THEN + function clz (constant v : unsigned(0 to 63)) return unsigned is + variable e : unsigned(0 to 63); -- 64 + variable a : unsigned(0 to 16*3-1); -- 48 + variable b : unsigned(0 to 8*4-1); -- 32 + variable c : unsigned(0 to 4*5-1); -- 20 + variable d : unsigned(0 to 2*6-1); -- 12 + begin + for i in 0 to 31 loop e(i*2 to i*2+1):=enc(v(i*2 to i*2+1)); end loop; + for i in 0 to 15 loop a(i*3 to i*3+2):=clzi(2,e(i*4 to i*4+3)); end loop; + for i in 0 to 7 loop b(i*4 to i*4+3):=clzi(3,a(i*6 to i*6+5)); end loop; + for i in 0 to 3 loop c(i*5 to i*5+4):=clzi(4,b(i*8 to i*8+7)); end loop; + for i in 0 to 1 loop d(i*6 to i*6+5):=clzi(5,c(i*10 to i*10+9)); end loop; + return clzi(6,d(0 to 11)); + end function; + ~ELSE + function clz (constant v : unsigned(0 to 31)) return unsigned is + variable e : unsigned(0 to 31); -- 32 + variable a : unsigned(0 to 8*3-1); -- 24 + variable b : unsigned(0 to 4*4-1); -- 16 + variable c : unsigned(0 to 2*5-1); -- 10 + begin + for i in 0 to 15 loop e(i*2 to i*2+1):=enc(v(i*2 to i*2+1)); end loop; + for i in 0 to 7 loop a(i*3 to i*3+2):=clzi(2,e(i*4 to i*4+3)); end loop; + for i in 0 to 3 loop b(i*4 to i*4+3):=clzi(3,a(i*6 to i*6+5)); end loop; + for i in 0 to 1 loop c(i*5 to i*5+4):=clzi(4,b(i*8 to i*8+7)); end loop; + return clzi(5,c(0 to 9)); + end function; + ~FI + end; + template: resize(~INCLUDENAME[0].clz(~ARG[0]),~SIZE[~TYPO]) +- BlackBox: + name: GHC.Prim.ctz8# + kind: Declaration + type: 'ctz8 :: Word# -> Word#' + imports: + - ~INCLUDENAME[0].all + includes: + - name: clz8 + comment: This is a copy of clz8, it's used to implement ctz8 + extension: vhdl + template: |- + -- helper function of GHC.Prim.clz8# + library IEEE; + use IEEE.STD_LOGIC_1164.ALL; + use IEEE.NUMERIC_STD.ALL; + package ~INCLUDENAME[0] is + function clz8 (constant v : unsigned(0 to 7)) return unsigned; + end; + + package body ~INCLUDENAME[0] is + function enc (constant a : unsigned(1 downto 0)) return unsigned is + begin + case a is + when "00" => return "10"; + when "01" => return "01"; + when "10" => return "00"; + when others => return "00"; + end case; + end function; + + function clzi ( + constant n : in natural; + constant i : in unsigned) return unsigned is + variable v : unsigned(i'length-1 downto 0):=i; + begin + if v(n-1+n)='0' then + return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); + else + return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); + end if; + end function; + + function clz8 (constant v : unsigned(0 to 7)) return unsigned is + variable e : unsigned(0 to 7); -- 8 + variable a : unsigned(0 to 2*3-1); -- 6 + begin + for i in 0 to 3 loop e(i*2 to i*2+1):=enc(v(i*2 to i*2+1)); end loop; + for i in 0 to 1 loop a(i*3 to i*3+2):=clzi(2,e(i*4 to i*4+3)); end loop; + return clzi(3,a(0 to 5)); + end function; + end; + template: |- + -- ctz8 begin + ~GENSYM[ctz8][0] : block + signal ~GENSYM[w_reversed][5] : ~TYP[0]; + begin + ~GENSYM[reverse_loop][6] : for ~GENSYM[n][7] in ~VAR[w][0]'range generate + ~SYM[5](~VAR[w][0]'high - ~SYM[7]) <= ~VAR[w][0](~SYM[7]); + end generate; + ~IF ~IW64 ~THEN + ~RESULT <= resize(~INCLUDENAME[0].clz8(~SYM[5](63 downto 56)),~SIZE[~TYPO]); + ~ELSE + ~RESULT <= resize(~INCLUDENAME[0].clz8(~SYM[5](31 downto 24)),~SIZE[~TYPO]); + ~FI + end block; + -- ctz8 end +- BlackBox: + name: GHC.Prim.ctz16# + kind: Declaration + type: 'ctz16 :: Word# -> Word#' + imports: + - ~INCLUDENAME[0].all + includes: + - name: clz16 + comment: This is a copy of clz16, it's used to implement ctz16 + extension: vhdl + template: |- + -- helper function of GHC.Prim.clz16# + library IEEE; + use IEEE.STD_LOGIC_1164.ALL; + use IEEE.NUMERIC_STD.ALL; + package ~INCLUDENAME[0] is + function clz16 (constant v : unsigned(0 to 15)) return unsigned; + end; + + package body ~INCLUDENAME[0] is + function enc (constant a : unsigned(1 downto 0)) return unsigned is + begin + case a is + when "00" => return "10"; + when "01" => return "01"; + when "10" => return "00"; + when others => return "00"; + end case; + end function; + + function clzi ( + constant n : in natural; + constant i : in unsigned) return unsigned is + variable v : unsigned(i'length-1 downto 0):=i; + begin + if v(n-1+n)='0' then + return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); + else + return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); + end if; + end function; + + function clz16 (constant v : unsigned(0 to 15)) return unsigned is + variable e : unsigned(0 to 15); -- 16 + variable a : unsigned(0 to 4*3-1); -- 12 + variable b : unsigned(0 to 2*4-1); -- 8 + begin + for i in 0 to 7 loop e(i*2 to i*2+1):=enc(v(i*2 to i*2+1)); end loop; + for i in 0 to 3 loop a(i*3 to i*3+2):=clzi(2,e(i*4 to i*4+3)); end loop; + for i in 0 to 1 loop b(i*4 to i*4+3):=clzi(3,a(i*6 to i*6+5)); end loop; + return clzi(4,b(0 to 7)); + end function; + end; + template: |- + -- ctz16 begin + ~GENSYM[ctz16][0] : block + signal ~GENSYM[w_reversed][5] : ~TYP[0]; + begin + ~GENSYM[reverse_loop][6] : for ~GENSYM[n][7] in ~VAR[w][0]'range generate + ~SYM[5](~VAR[w][0]'high - ~SYM[7]) <= ~VAR[w][0](~SYM[7]); + end generate; + ~IF ~IW64 ~THEN + ~RESULT <= resize(~INCLUDENAME[0].clz16(~SYM[5](63 downto 48)),~SIZE[~TYPO]); + ~ELSE + ~RESULT <= resize(~INCLUDENAME[0].clz16(~SYM[5](31 downto 16)),~SIZE[~TYPO]); + ~FI + end block; + -- ctz16 end +- BlackBox: + name: GHC.Prim.ctz32# + kind: Declaration + type: 'ctz32 :: Word# -> Word#' + imports: + - ~INCLUDENAME[0].all + includes: + - name: clz32 + comment: This is a copy of clz32, it's used to implement ctz32 + extension: vhdl + template: |- + -- helper function of GHC.Prim.clz32# + library IEEE; + use IEEE.STD_LOGIC_1164.ALL; + use IEEE.NUMERIC_STD.ALL; + package ~INCLUDENAME[0] is + function clz32 (constant v : unsigned(0 to 31)) return unsigned; + end; + + package body ~INCLUDENAME[0] is + function enc (constant a : unsigned(1 downto 0)) return unsigned is + begin + case a is + when "00" => return "10"; + when "01" => return "01"; + when "10" => return "00"; + when others => return "00"; + end case; + end function; + + function clzi ( + constant n : in natural; + constant i : in unsigned) return unsigned is + variable v : unsigned(i'length-1 downto 0):=i; + begin + if v(n-1+n)='0' then + return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); + else + return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); + end if; + end function; + + function clz32 (constant v : unsigned(0 to 31)) return unsigned is + variable e : unsigned(0 to 31); -- 32 + variable a : unsigned(0 to 8*3-1); -- 24 + variable b : unsigned(0 to 4*4-1); -- 16 + variable c : unsigned(0 to 2*5-1); -- 10 + begin + for i in 0 to 15 loop e(i*2 to i*2+1):=enc(v(i*2 to i*2+1)); end loop; + for i in 0 to 7 loop a(i*3 to i*3+2):=clzi(2,e(i*4 to i*4+3)); end loop; + for i in 0 to 3 loop b(i*4 to i*4+3):=clzi(3,a(i*6 to i*6+5)); end loop; + for i in 0 to 1 loop c(i*5 to i*5+4):=clzi(4,b(i*8 to i*8+7)); end loop; + return clzi(5,c(0 to 9)); + end function; + end; + template: |- + -- ctz32 begin + ~GENSYM[ctz32][0] : block + signal ~GENSYM[w_reversed][5] : ~TYP[0]; + begin + ~GENSYM[reverse_loop][6] : for ~GENSYM[n][7] in ~VAR[w][0]'range generate + ~SYM[5](~VAR[w][0]'high - ~SYM[7]) <= ~VAR[w][0](~SYM[7]); + end generate; + ~IF ~IW64 ~THEN + ~RESULT <= resize(~INCLUDENAME[0].clz32(~SYM[5](63 downto 32)),~SIZE[~TYPO]); + ~ELSE + ~RESULT <= resize(~INCLUDENAME[0].clz32(~SYM[5]),~SIZE[~TYPO]); + ~FI + end block; + -- ctz32 end +- BlackBox: + name: GHC.Prim.ctz64# + kind: Declaration + type: 'ctz64 :: Word# -> Word#' + imports: + - ~INCLUDENAME[0].all + includes: + - name: clz64 + comment: This is a copy of clz64, it's used to implement ctz64 + extension: vhdl + template: |- + -- helper function of GHC.Prim.clz64# + library IEEE; + use IEEE.STD_LOGIC_1164.ALL; + use IEEE.NUMERIC_STD.ALL; + package ~INCLUDENAME[0] is + function clz64 (constant v : unsigned(0 to 63)) return unsigned; + end; + + package body ~INCLUDENAME[0] is + function enc (constant a : unsigned(1 downto 0)) return unsigned is + begin + case a is + when "00" => return "10"; + when "01" => return "01"; + when "10" => return "00"; + when others => return "00"; + end case; + end function; + + function clzi ( + constant n : in natural; + constant i : in unsigned) return unsigned is + variable v : unsigned(i'length-1 downto 0):=i; + begin + if v(n-1+n)='0' then + return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); + else + return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); + end if; + end function; + + function clz64 (constant v : unsigned(0 to 63)) return unsigned is + variable e : unsigned(0 to 63); -- 64 + variable a : unsigned(0 to 16*3-1); -- 48 + variable b : unsigned(0 to 8*4-1); -- 32 + variable c : unsigned(0 to 4*5-1); -- 20 + variable d : unsigned(0 to 2*6-1); -- 12 + begin + for i in 0 to 31 loop e(i*2 to i*2+1):=enc(v(i*2 to i*2+1)); end loop; + for i in 0 to 15 loop a(i*3 to i*3+2):=clzi(2,e(i*4 to i*4+3)); end loop; + for i in 0 to 7 loop b(i*4 to i*4+3):=clzi(3,a(i*6 to i*6+5)); end loop; + for i in 0 to 3 loop c(i*5 to i*5+4):=clzi(4,b(i*8 to i*8+7)); end loop; + for i in 0 to 1 loop d(i*6 to i*6+5):=clzi(5,c(i*10 to i*10+9)); end loop; + return clzi(6,d(0 to 11)); + end function; + end; + template: |- + -- ctz64 begin + ~GENSYM[ctz64][0] : block + signal ~GENSYM[w_reversed][5] : ~TYP[0]; + begin + ~GENSYM[reverse_loop][6] : for ~GENSYM[n][7] in ~VAR[w][0]'range generate + ~SYM[5](~VAR[w][0]'high - ~SYM[7]) <= ~VAR[w][0](~SYM[7]); + end generate; + + ~RESULT <= resize(~INCLUDENAME[0].clz64(~SYM[5]),~SIZE[~TYPO]); + end block; + -- ctz64 end +- BlackBox: + name: GHC.Prim.ctz# + kind: Declaration + type: 'ctz :: Word# -> Word#' + imports: + - ~INCLUDENAME[0].all + includes: + - name: clz + comment: This is a copy of clz, it's used to implement ctz + extension: vhdl + template: |- + -- helper function of GHC.Prim.clz# + library IEEE; + use IEEE.STD_LOGIC_1164.ALL; + use IEEE.NUMERIC_STD.ALL; + package ~INCLUDENAME[0] is + ~IF ~IW64 ~THEN + function clz (constant v : unsigned(0 to 63)) return unsigned; + ~ELSE + function clz (constant v : unsigned(0 to 31)) return unsigned; + ~FI + end; + + package body ~INCLUDENAME[0] is + function enc (constant a : unsigned(1 downto 0)) return unsigned is + begin + case a is + when "00" => return "10"; + when "01" => return "01"; + when "10" => return "00"; + when others => return "00"; + end case; + end function; + + function clzi ( + constant n : in natural; + constant i : in unsigned) return unsigned is + variable v : unsigned(i'length-1 downto 0):=i; + begin + if v(n-1+n)='0' then + return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); + else + return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); + end if; + end function; + ~IF ~IW64 ~THEN + function clz (constant v : unsigned(0 to 63)) return unsigned is + variable e : unsigned(0 to 63); -- 64 + variable a : unsigned(0 to 16*3-1); -- 48 + variable b : unsigned(0 to 8*4-1); -- 32 + variable c : unsigned(0 to 4*5-1); -- 20 + variable d : unsigned(0 to 2*6-1); -- 12 + begin + for i in 0 to 31 loop e(i*2 to i*2+1):=enc(v(i*2 to i*2+1)); end loop; + for i in 0 to 15 loop a(i*3 to i*3+2):=clzi(2,e(i*4 to i*4+3)); end loop; + for i in 0 to 7 loop b(i*4 to i*4+3):=clzi(3,a(i*6 to i*6+5)); end loop; + for i in 0 to 3 loop c(i*5 to i*5+4):=clzi(4,b(i*8 to i*8+7)); end loop; + for i in 0 to 1 loop d(i*6 to i*6+5):=clzi(5,c(i*10 to i*10+9)); end loop; + return clzi(6,d(0 to 11)); + end function; + ~ELSE + function clz (constant v : unsigned(0 to 31)) return unsigned is + variable e : unsigned(0 to 31); -- 32 + variable a : unsigned(0 to 8*3-1); -- 24 + variable b : unsigned(0 to 4*4-1); -- 16 + variable c : unsigned(0 to 2*5-1); -- 10 + begin + for i in 0 to 15 loop e(i*2 to i*2+1):=enc(v(i*2 to i*2+1)); end loop; + for i in 0 to 7 loop a(i*3 to i*3+2):=clzi(2,e(i*4 to i*4+3)); end loop; + for i in 0 to 3 loop b(i*4 to i*4+3):=clzi(3,a(i*6 to i*6+5)); end loop; + for i in 0 to 1 loop c(i*5 to i*5+4):=clzi(4,b(i*8 to i*8+7)); end loop; + return clzi(5,c(0 to 9)); + end function; + ~FI + end; + template: |- + -- ctz begin + ~GENSYM[ctz][0] : block + signal ~GENSYM[w_reversed][6] : ~TYP[0]; + begin + ~GENSYM[reverse_loop][7] : for ~GENSYM[n][8] in ~VAR[w][0]'range generate + ~SYM[6](~VAR[w][0]'high - ~SYM[8]) <= ~VAR[w][0](~SYM[8]); + end generate; + ~RESULT <= resize(~INCLUDENAME[0].clz(~SYM[6]),~SIZE[~TYPO]); end block; -- ctz end - BlackBox: diff --git a/src/Clash/Backend/SystemVerilog.hs b/src/Clash/Backend/SystemVerilog.hs --- a/src/Clash/Backend/SystemVerilog.hs +++ b/src/Clash/Backend/SystemVerilog.hs @@ -1456,7 +1456,7 @@ where start = typeSize ty - 1 end = typeSize ty `div` 2 - lhsSz = (d-1)^(2 :: Int) + lhsSz = 2^(d-1) modifier offset mods (Indexed (ty@(RTree d argTy),1,1)) = case mods of Right {}:rest -> Just (Right (NRange (start+offset) offset):rest, RTree (d-1) argTy) @@ -1464,8 +1464,8 @@ _ -> Just (Left (NRange rhsS rhsE):mods,RTree (d-1) argTy) where start = (typeSize ty `div` 2) - 1 - rhsS = (d-1)^(2 :: Int) - rhsE = d^(2 :: Int)-1 + rhsS = 2^(d-1) + rhsE = 2^d - 1 -- This is a HACK for Clash.Netlist.Util.mkTopOutput -- Vector's don't have a 10'th constructor, this is just so that we can diff --git a/src/Clash/Core/DataCon.hs b/src/Clash/Core/DataCon.hs --- a/src/Clash/Core/DataCon.hs +++ b/src/Clash/Core/DataCon.hs @@ -24,7 +24,7 @@ import Control.DeepSeq (NFData(..)) import Data.Binary (Binary) import Data.Function (on) -import Data.Hashable (Hashable) +import Data.Hashable (Hashable (hashWithSalt)) import qualified Data.Text as Text import GHC.Generics (Generic) @@ -67,6 +67,9 @@ instance Ord DataCon where compare = compare `on` dcUniq + +instance Hashable DataCon where + hashWithSalt salt = hashWithSalt salt . dcUniq instance Uniquable DataCon where getUnique = dcUniq diff --git a/src/Clash/Core/Evaluator/Types.hs b/src/Clash/Core/Evaluator/Types.hs --- a/src/Clash/Core/Evaluator/Types.hs +++ b/src/Clash/Core/Evaluator/Types.hs @@ -3,7 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {-| - Copyright : (C) 2020-2024, QBayLogic B.V. + Copyright : (C) 2020-2026, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -35,6 +35,7 @@ import Clash.Core.VarEnv import Clash.Driver.Types (BindingMap, bindingTerm) import Clash.Pretty (ClashPretty(..), fromPretty, showDoc) +import Clash.Unique (getUnique) import Clash.Util.Supply (Supply) whnf' @@ -53,8 +54,7 @@ where toResult x = (mHeapPrim x, mHeapLocal x, mTerm x) - m = Machine ph gh lh [] ids is e - gh = mapVarEnv bindingTerm bm + m = Machine ph bm emptyVarEnv emptyVarSet lh [] ids is e -- | Evaluate to WHNF given an existing Heap and Stack whnf @@ -189,7 +189,16 @@ -- data Machine = Machine { mHeapPrim :: PrimHeap - , mHeapGlobal :: PureHeap + , mHeapGlobalBase :: BindingMap + -- ^ Immutable global bindings, projected to terms on demand in + -- 'heapLookup'. Kept as 'BindingMap' so 'whnf'' doesn't have to copy the + -- entire map on every invocation. + , mHeapGlobalOverlay :: PureHeap + -- ^ Global-heap entries added or updated during evaluation; shadows + -- 'mHeapGlobalBase' + , mHeapGlobalDeleted :: VarSet + -- ^ Global-heap entries deleted during evaluation (blackholing); shadows + -- both maps above , mHeapLocal :: PureHeap , mStack :: Stack , mSupply :: Supply @@ -198,7 +207,7 @@ } instance Show Machine where - show (Machine ph gh lh s _ _ x) = + show (Machine ph _ gh _ lh s _ _ x) = unlines [ "Machine:" , "" @@ -349,8 +358,10 @@ in m { mHeapPrim = (IntMap.insert i x gh, c) } heapLookup :: IdScope -> Id -> Machine -> Maybe Term -heapLookup GlobalId i m = - lookupVarEnv i $ mHeapGlobal m +heapLookup GlobalId i m + | elemVarSet i (mHeapGlobalDeleted m) = Nothing + | Just x <- lookupVarEnv i (mHeapGlobalOverlay m) = Just x + | otherwise = bindingTerm <$> lookupVarEnv i (mHeapGlobalBase m) heapLookup LocalId i m = lookupVarEnv i $ mHeapLocal m @@ -359,13 +370,17 @@ heapInsert :: IdScope -> Id -> Term -> Machine -> Machine heapInsert GlobalId i x m = - m { mHeapGlobal = extendVarEnv i x (mHeapGlobal m) } + m { mHeapGlobalOverlay = extendVarEnv i x (mHeapGlobalOverlay m) + , mHeapGlobalDeleted = delVarSetByKey (getUnique i) (mHeapGlobalDeleted m) + } heapInsert LocalId i x m = m { mHeapLocal = extendVarEnv i x (mHeapLocal m) } heapDelete :: IdScope -> Id -> Machine -> Machine heapDelete GlobalId i m = - m { mHeapGlobal = delVarEnv (mHeapGlobal m) i } + m { mHeapGlobalOverlay = delVarEnv (mHeapGlobalOverlay m) i + , mHeapGlobalDeleted = extendVarSet (mHeapGlobalDeleted m) i + } heapDelete LocalId i m = m { mHeapLocal = delVarEnv (mHeapLocal m) i } diff --git a/src/Clash/Core/FreeVars.hs b/src/Clash/Core/FreeVars.hs --- a/src/Clash/Core/FreeVars.hs +++ b/src/Clash/Core/FreeVars.hs @@ -1,6 +1,6 @@ {-| Copyright : (C) 2012-2016, University of Twente - 2021, QBayLogic B.V. + 2021-2026, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -26,6 +26,7 @@ -- * Internal , typeFreeVars' , termFreeVars' + , termFreeIds' ) where @@ -147,19 +148,19 @@ -- | Gives the free identifiers of a Term, implemented as a 'Fold' freeIds :: Fold Term Id -freeIds = termFreeVars' isId where +freeIds = termFreeIds' isId where isId (Id {}) = True isId _ = False -- | Calculate the /local/ free identifiers of an expression: the free -- identifiers that are not bound in the global environment. freeLocalIds :: Fold Term Id -freeLocalIds = termFreeVars' isLocalId +freeLocalIds = termFreeIds' isLocalId -- | Calculate the /global/ free identifiers of an expression: the free -- identifiers that are bound in the global environment. globalIds :: Fold Term Id -globalIds = termFreeVars' isGlobalId where +globalIds = termFreeIds' isGlobalId where isGlobalId (Id {idScope = GlobalId}) = True isGlobalId _ = False @@ -207,9 +208,42 @@ -> (Var a -> f (Var a)) -> Term -> f Term -termFreeVars' interesting f = go IntSet.empty where +termFreeVars' = termFreeVarsWorker True + +-- | Gives the "interesting" free identifiers in a Term, implemented as a +-- 'Fold'. Like 'termFreeVars'', but fold does not descend into the types of +-- variables and binders. +termFreeIds' + :: (Contravariant f, Applicative f) + => (forall b . Var b -> Bool) + -- ^ Predicate telling whether an identifier is interesting + -> (Var a -> f (Var a)) + -> Term + -> f Term +termFreeIds' = termFreeVarsWorker False + +-- | Worker for 'termFreeVars'' and 'termFreeIds''. Has option that selects +-- whether to descend into types or not. +termFreeVarsWorker + :: forall a f + . (Contravariant f, Applicative f) + => Bool + -- ^ Descend into the types of variables and binders? + -> (forall b . Var b -> Bool) + -- ^ Predicate telling whether a variable is interesting + -> (Var a -> f (Var a)) + -> Term + -> f Term +termFreeVarsWorker descendIntoTypes interesting f = go IntSet.empty where + -- Fold over a type only when descending into types; otherwise leave it as-is. + onType inScope ty + | descendIntoTypes = typeFreeVars' interesting inScope f ty + | otherwise = pure ty + go inLocalScope = \case - Var v -> v1 <* typeFreeVars' interesting inLocalScope1 f (varType v) + Var v + | descendIntoTypes -> v1 <* typeFreeVars' interesting inLocalScope1 f (varType v) + | otherwise -> v1 where isInteresting = interesting v vInScope = isLocalId v && varUniq v `IntSet.member` inLocalScope @@ -235,7 +269,7 @@ TyApp l r -> TyApp <$> go inLocalScope l - <*> typeFreeVars' interesting inLocalScope f r + <*> onType inLocalScope r Let (NonRec i x) e -> Let <$> (NonRec <$> goBndr inLocalScope i <*> go inLocalScope x) @@ -249,13 +283,13 @@ Case subj ty alts -> Case <$> go inLocalScope subj - <*> typeFreeVars' interesting inLocalScope f ty + <*> onType inLocalScope ty <*> traverse (goAlt inLocalScope) alts Cast tm t1 t2 -> Cast <$> go inLocalScope tm - <*> typeFreeVars' interesting inLocalScope f t1 - <*> typeFreeVars' interesting inLocalScope f t2 + <*> onType inLocalScope t1 + <*> onType inLocalScope t2 Tick tick tm -> Tick <$> goTick inLocalScope tick @@ -263,27 +297,30 @@ tm -> pure tm - goBndr inLocalScope v = - (\t -> v {varType = t}) <$> typeFreeVars' interesting inLocalScope f (varType v) + -- Fold over a binder's type only when descending; otherwise leave it as-is. + goBndr inLocalScope v + | descendIntoTypes = (\t -> v {varType = t}) <$> onType inLocalScope (varType v) + | otherwise = pure v goBind inLocalScope (l,r) = (,) <$> goBndr inLocalScope l <*> go inLocalScope r goAlt inLocalScope (pat,alt) = case pat of - DataPat dc tvs ids -> (,) <$> (DataPat <$> pure dc - <*> traverse (goBndr inLocalScope') tvs - <*> traverse (goBndr inLocalScope') ids) + DataPat dc tvs ids -> (,) <$> (DataPat dc + <$> traverse (goBndr inLocalScope') tvs + <*> traverse (goBndr inLocalScope') ids) <*> go inLocalScope' alt where inLocalScope' = foldr IntSet.insert (foldr IntSet.insert inLocalScope (map varUniq tvs)) (map varUniq ids) - _ -> (,) <$> pure pat <*> go inLocalScope alt + _ -> (,) pat <$> go inLocalScope alt goTick inLocalScope = \case - NameMod m ty -> NameMod m <$> typeFreeVars' interesting inLocalScope f ty - Attributes ty tm -> Attributes <$> typeFreeVars' interesting inLocalScope f ty + NameMod m ty -> NameMod m <$> onType inLocalScope ty + Attributes ty tm -> Attributes <$> onType inLocalScope ty <*> go inLocalScope tm tick -> pure tick +{-# INLINE termFreeVarsWorker #-} -- | Get the free variables of an expression and count the number of occurrences countFreeOccurances diff --git a/src/Clash/Core/HasFreeVars.hs b/src/Clash/Core/HasFreeVars.hs --- a/src/Clash/Core/HasFreeVars.hs +++ b/src/Clash/Core/HasFreeVars.hs @@ -61,6 +61,11 @@ freeVarsOf = Lens.foldMapOf freeLocalVars unitVarSet + -- "Override" default implementation: this one stops early instead of computing + -- every free variable first. + isClosed e = + getAll (Lens.foldMapOf freeLocalVars (const (All False)) e) + elemFreeVars v e = getAny (Lens.foldMapOf freeLocalVars (Any . (== v)) e) diff --git a/src/Clash/Core/Name.hs b/src/Clash/Core/Name.hs --- a/src/Clash/Core/Name.hs +++ b/src/Clash/Core/Name.hs @@ -26,7 +26,8 @@ import GHC.BasicTypes.Extra () import GHC.Generics (Generic) import GHC.SrcLoc.Extra () -import GHC.Types.SrcLoc (SrcSpan, noSrcSpan) +import GHC.Types.SrcLoc + (SrcSpan, leftmost_smallest, noSrcSpan) import Clash.Unique @@ -39,12 +40,32 @@ } deriving (Show,Generic,NFData,Binary) +-- | N.B.: Equality checking only compares uniques, which only identify a name +-- within one scope. If you want structural equality, use `eqName`. instance Eq (Name a) where (==) = (==) `on` nameUniq (/=) = (/=) `on` nameUniq +-- | N.B.: Comparison only looks at uniques, which only identify a name within +-- one scope. If you want structural comparison, use `ordName`. instance Ord (Name a) where compare = compare `on` nameUniq + +-- | Structural equality on 'Name's. See 'ordName'. +eqName :: Name a -> Name a -> Bool +eqName n1 n2 = ordName n1 n2 == EQ + +-- | Structural comparison on 'Name's: on top of the 'Ord' instance, which only +-- compares uniques, this compares every other field too. +-- +-- 'SrcSpan's are compared with 'leftmost_smallest', which treats all unhelpful +-- spans alike, matching how they are hashed in "Clash.Core.Subst". +ordName :: Name a -> Name a -> Ordering +ordName n1 n2 = + compare (nameUniq n1) (nameUniq n2) + <> compare (nameSort n1) (nameSort n2) + <> compare (nameOcc n1) (nameOcc n2) + <> leftmost_smallest (nameLoc n1) (nameLoc n2) instance Hashable (Name a) where hashWithSalt salt nm = hashWithSalt salt (nameUniq nm) diff --git a/src/Clash/Core/Subst.hs b/src/Clash/Core/Subst.hs --- a/src/Clash/Core/Subst.hs +++ b/src/Clash/Core/Subst.hs @@ -2,17 +2,18 @@ Copyright : (C) 2012-2016, University of Twente, 2017, Google Inc. 2021, QBayLogic B.V. + 2026, Martijn Bastiaan License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Capture-free substitution function for CoreHW -} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -46,6 +47,7 @@ -- ** Applying substitutions , substTm , maybeSubstTm + , unsafeSubstTm , substAlt , substId -- * Variable renaming @@ -57,9 +59,16 @@ , aeqType , aeqTerm , acmpTerm + , aeqTickInfo + , acmpTickInfo + , aeqTickInfoLevels + , acmpTickInfoLevels -- * Structural equivalence , eqTerm , eqType + , ordType + , eqVar + , ordVar ) where @@ -74,23 +83,26 @@ import Data.Hashable (Hashable (hashWithSalt)) import qualified Data.List as List import qualified Data.List.Extra as List +import Data.Maybe (fromMaybe) import Data.Ord (comparing) import GHC.Stack (HasCallStack) -import GHC.SrcLoc.Extra () -import GHC.TypeLits - (TypeError, ErrorMessage (Text, (:<>:))) +import GHC.SrcLoc.Extra () -- Hashable RealSrcSpan +import GHC.Types.SrcLoc + (SrcSpan (RealSrcSpan, UnhelpfulSpan), leftmost_smallest) import Clash.Core.HasFreeVars +import Clash.Core.Name (eqName, ordName) import Clash.Core.Pretty (ppr, fromPpr) import Clash.Core.Term - (Bind(..), Pat (..), Term (..), TickInfo (..), PrimInfo(primName)) + (Alt, Bind(..), Pat (..), Term (..), TickInfo (..), PrimInfo(primName)) import Clash.Core.Type (Type (..)) import Clash.Core.VarEnv -import Clash.Core.Var (Id, Var (..), TyVar, isGlobalId) +import Clash.Core.Var + (Id, Var (..), TyVar, isGlobalId, varKey) import qualified Clash.Data.UniqMap as UniqMap import Clash.Debug (debugIsOn) -import Clash.Util import Clash.Pretty +import Clash.Util -- * Subst @@ -587,6 +599,92 @@ goTick t@NoDeDup = t goTick (Attributes ty tm) = Attributes (substTy subst ty) (go tm) +-- | Like 'substTm', but doesn't account for shadowing or free variable capture. +-- +-- An example of shadowing: in @(x, \x -> x)@ with a substitution @x |-> 5@ +-- 'unsafeSubstTm' will yield @(5, \x -> 5)@, whereas a safe substitution would +-- yield @(5, \x -> x)@. +-- +-- An example of free variable capture: in @\x -> y@ and a substitution +-- @y |-> f x@, 'unsafeSubstTm' will yield @\x -> f x@, whereas a safe substitution +-- would yield @\x' -> f x@. +-- +-- You should therefore only use this function if: +-- +-- 1. No binder in the term binds variables in the domain of the local +-- substitution. +-- +-- 2. No binder in the term has the same unique as a local, free variable of any +-- replacement term in the range of either substitution. +-- +-- Both conditions hold if the term is deshadowed (see 'deShadowTerm') with +-- respect to an in-scope set that contains the domains of the substitutions +-- and the free variables of the replacement terms. +-- +-- Note that global substituations are always safe. They never have local free +-- variables and cannot be introduced through a binder. I.e., neither rule 1 +-- nor 2 applies. +unsafeSubstTm + :: VarEnv Term + -- ^ Substitution: global variable to replacement term + -> VarEnv Term + -- ^ Substitution: local variable to replacement term + -> Term + -- ^ Term to substitute in + -> Term +unsafeSubstTm globals locals = \term -> fromMaybe term (go term) + where + go :: Term -> Maybe Term + go = \case + Var v + | isGlobalId v -> lookupVarEnv v globals + | otherwise -> lookupVarEnv v locals + Lam v e -> Lam v <$> go e + TyLam tv e -> TyLam tv <$> go e + App l r -> case (go l, go r) of + (Nothing, Nothing) -> Nothing + (l1, r1) -> Just (App (fromMaybe l l1) (fromMaybe r r1)) + TyApp e ty -> (`TyApp` ty) <$> go e + Let bs body -> case (goBind bs, go body) of + (Nothing, Nothing) -> Nothing + (bs1, body1) -> Just (Let (fromMaybe bs bs1) (fromMaybe body body1)) + Case subject ty alternatives -> + case (go subject, goList goAlternative alternatives) of + (Nothing, Nothing) -> Nothing + (subject1, alternatives1) -> + Just (Case (fromMaybe subject subject1) ty + (fromMaybe alternatives alternatives1)) + Cast e t1 t2 -> (\e1 -> Cast e1 t1 t2) <$> go e + Tick tickInfo e -> case (goTickInfo tickInfo, go e) of + (Nothing, Nothing) -> Nothing + (tick1, e1) -> Just (Tick (fromMaybe tickInfo tick1) (fromMaybe e e1)) + Data{} -> Nothing + Literal{} -> Nothing + Prim{} -> Nothing + + goBind (NonRec v rhs) = NonRec v <$> go rhs + goBind (Rec bindings0) = Rec <$> goList goBinding bindings0 + + goBinding (v, rhs) = (,) v <$> go rhs + + goAlternative (pat, alternative) = (,) pat <$> go alternative + + -- Types contain no term variables, so of the tick constructors only + -- 'Attributes', which carries a term, needs a traversal. + goTickInfo (Attributes ty e) = Attributes ty <$> go e + goTickInfo SrcSpan{} = Nothing + goTickInfo NameMod{} = Nothing + goTickInfo DeDup = Nothing + goTickInfo NoDeDup = Nothing + + goList :: (a -> Maybe a) -> [a] -> Maybe [a] + goList f = goElements + where + goElements [] = Nothing + goElements (x:xs) = case (f x, goElements xs) of + (Nothing, Nothing) -> Nothing + (x1, xs1) -> Just (fromMaybe x x1 : fromMaybe xs xs1) + -- | Substitute within a case-alternative substAlt :: HasCallStack @@ -778,8 +876,9 @@ (is2,alts') -> (is2, Case subj' (substTy subst0 ty) alts') Cast e t1 t2 -> case go subst0 e of (is1, e') -> (is1, Cast e' (substTy subst0 t1) (substTy subst0 t2)) - Tick tick e -> case go subst0 e of - (is1, e') -> (is1, Tick (goTick subst0 tick) e') + Tick tick e -> case goTick subst0 tick of + (is1, tick') -> case go subst0 {substInScope = is1} e of + (is2, e') -> (is2, Tick tick' e') tm -> (substInScope subst0, tm) goBind subst0 (NonRec i x) = @@ -803,8 +902,13 @@ _ -> case go subst0 alt of (is1,alt') -> (is1,(pat,alt')) - goTick subst0 (NameMod m ty) = NameMod m (substTy subst0 ty) - goTick _ tick = tick + goTick subst0 t@(SrcSpan _) = (substInScope subst0, t) + goTick subst0 (NameMod m ty) = + (substInScope subst0, NameMod m (substTy subst0 ty)) + goTick subst0 t@DeDup = (substInScope subst0, t) + goTick subst0 t@NoDeDup = (substInScope subst0, t) + goTick subst0 (Attributes ty tm) = case go subst0 tm of + (is1, tm') -> (is1, Attributes (substTy subst0 ty) tm') -- * AEQ @@ -813,46 +917,31 @@ :: Type -> Type -> Bool -aeqType t1 t2 = acmpType' rnEnv t1 t2 == EQ - where - rnEnv = mkRnEnv (mkInScopeSet (freeVarsOf [t1,t2])) +aeqType t1 t2 = acmpType t1 t2 == EQ +{-# INLINE aeqType #-} -- | Alpha comparison for types acmpType :: Type -> Type -> Ordering -acmpType t1 t2 = acmpType' (mkRnEnv inScope) t1 t2 - where - inScope = mkInScopeSet (freeVarsOf [t1,t2]) +acmpType = acmpTypeLevels 0 emptyVarEnv emptyVarEnv --- | Alpha comparison for types. Faster than 'acmpType' as it doesn't need to --- calculate the free variables to create the 'InScopeSet' -acmpType' - :: RnEnv - -> Type - -> Type - -> Ordering -acmpType' = go - where - go env (VarTy tv1) (VarTy tv2) = compare (rnOccLTy env tv1) (rnOccRTy env tv2) - go _ (ConstTy c1) (ConstTy c2) = compare c1 c2 - go env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = - go env (varType tv1) (varType tv2) `thenCompare` go (rnTyBndr env tv1 tv2) t1 t2 - go env (AppTy s1 t1) (AppTy s2 t2) = - go env s1 s2 `thenCompare` go env t1 t2 - go _ (LitTy l1) (LitTy l2) = compare l1 l2 - go env (AnnType a1 t1) (AnnType a2 t2) = - compare a1 a2 `thenCompare` go env t1 t2 - go _ t1 t2 = compare (getRank t1) (getRank t2) +-- | Structural equality on 'Var's. See 'ordVar'. +eqVar :: Var a -> Var a -> Bool +eqVar v1 v2 = + v1 == v2 && + eqName (varName v1) (varName v2) && + eqType (varType v1) (varType v2) - getRank :: Type -> Word - getRank (VarTy {}) = 0 - getRank (LitTy {}) = 1 - getRank (ConstTy {}) = 2 - getRank (AnnType {}) = 3 - getRank (AppTy {}) = 4 - getRank (ForAllTy {}) = 5 +-- | Structural comparison on 'Var's: on top of the 'Ord' instance, which only +-- compares uniques (and scope), this compares the variable's name and its +-- type\/kind. +ordVar :: Var a -> Var a -> Ordering +ordVar v1 v2 = + compare (varKey v1) (varKey v2) `thenCompare` + ordName (varName v1) (varName v2) `thenCompare` + ordType (varType v1) (varType v2) -- | Structural equality on 'Type' eqType @@ -861,127 +950,79 @@ -> Bool eqType = go where - go (VarTy tv1) (VarTy tv2) = tv1 == tv2 + go (VarTy tv1) (VarTy tv2) = eqVar tv1 tv2 go (ConstTy c1) (ConstTy c2) = c1 == c2 - go (ForAllTy tv1 t1) (ForAllTy tv2 t2) = - tv1 == tv2 && go (varType tv1) (varType tv2) && go t1 t2 + go (ForAllTy tv1 t1) (ForAllTy tv2 t2) = eqVar tv1 tv2 && go t1 t2 go (AppTy s1 t1) (AppTy s2 t2) = go s1 s2 && go t1 t2 go (LitTy l1) (LitTy l2) = l1 == l2 go (AnnType a1 t1) (AnnType a2 t2) = a1 == a2 && go t1 t2 go _ _ = False +-- | Structural comparison on 'Type'. See 'eqType'. +ordType + :: Type + -> Type + -> Ordering +ordType = go + where + go (VarTy tv1) (VarTy tv2) = ordVar tv1 tv2 + go (ConstTy c1) (ConstTy c2) = compare c1 c2 + go (ForAllTy tv1 t1) (ForAllTy tv2 t2) = ordVar tv1 tv2 `thenCompare` go t1 t2 + go (AppTy s1 t1) (AppTy s2 t2) = go s1 s2 `thenCompare` go t1 t2 + go (LitTy l1) (LitTy l2) = compare l1 l2 + go (AnnType a1 t1) (AnnType a2 t2) = compare a1 a2 `thenCompare` go t1 t2 + go t1 t2 = compare (getRank t1) (getRank t2) + + getRank :: Type -> Word + getRank (VarTy {}) = 0 + getRank (LitTy {}) = 1 + getRank (ConstTy {}) = 2 + getRank (AnnType {}) = 3 + getRank (AppTy {}) = 4 + getRank (ForAllTy {}) = 5 + -- | Alpha equality for terms aeqTerm :: Term -> Term -> Bool -aeqTerm t1 t2 = aeqTerm' inScope t1 t2 - where - inScope = mkInScopeSet (freeVarsOf [t1,t2]) - --- | Alpha equality for terms. Faster than 'aeqTerm' as it doesn't need to --- calculate the free variables to create the 'InScopeSet' -aeqTerm' - :: InScopeSet - -- ^ Superset of variables in scope of the left and right term - -> Term - -> Term - -> Bool -aeqTerm' inScope t1 t2 = acmpTerm' inScope t1 t2 == EQ +aeqTerm t1 t2 = acmpTerm t1 t2 == EQ +{-# INLINE aeqTerm #-} --- | Alpha comparison for types +-- | Alpha comparison for terms acmpTerm :: Term -> Term -> Ordering -acmpTerm t1 t2 = acmpTerm' inScope t1 t2 - where - inScope = mkInScopeSet (freeVarsOf [t1,t2]) - --- | Alpha comparison for types. Faster than 'acmpTerm' as it doesn't need to --- calculate the free variables to create the 'InScopeSet' -acmpTerm' - :: InScopeSet - -- ^ Superset of variables in scope of the left and right term - -> Term - -> Term - -> Ordering -acmpTerm' inScope = go (mkRnEnv inScope) - where - thenCmpTm EQ rel = rel - thenCmpTm rel _ = rel - - go env (Var id1) (Var id2) = compare (rnOccLId env id1) (rnOccRId env id2) - go _ (Data dc1) (Data dc2) = compare dc1 dc2 - go _ (Literal l1) (Literal l2) = compare l1 l2 - go _ (Prim p1) (Prim p2) = comparing primName p1 p2 - go env (Lam b1 e1) (Lam b2 e2) = - acmpType' env (varType b1) (varType b2) `thenCompare` - go (rnTmBndr env b1 b2) e1 e2 - go env (TyLam b1 e1) (TyLam b2 e2) = - acmpType' env (varType b1) (varType b2) `thenCompare` - go (rnTyBndr env b1 b2) e1 e2 - go env (App l1 r1) (App l2 r2) = - go env l1 l2 `thenCompare` go env r1 r2 - go env (TyApp l1 r1) (TyApp l2 r2) = - go env l1 l2 `thenCompare` acmpType' env r1 r2 - go env (Let (NonRec i1 x1) e1) (Let (NonRec i2 x2) e2) = - go env x1 x2 `thenCompare` go (rnTmBndr env i1 i2) e1 e2 - go env (Let (Rec bs1) e1) (Let (Rec bs2) e2) = - compare (length bs1) (length bs2) `thenCompare` - foldr thenCmpTm EQ (zipWith (go env') rhs1 rhs2) `thenCompare` - go env' e1 e2 - where - (ids1,rhs1) = unzip bs1 - (ids2,rhs2) = unzip bs2 - env' = rnTmBndrs env ids1 ids2 - go env (Case e1 _ a1) (Case e2 _ a2) = - compare (length a1) (length a2) `thenCompare` - go env e1 e2 `thenCompare` - foldr thenCmpTm EQ (zipWith (goAlt env) a1 a2) - go env (Cast e1 l1 r1) (Cast e2 l2 r2) = - go env e1 e2 `thenCompare` - acmpType' env l1 l2 `thenCompare` - acmpType' env r1 r2 - go env (Tick t1 e1) (Tick t2 e2) = - compare t1 t2 `thenCompare` go env e1 e2 - go _ e1 e2 = compare (getRank e1) (getRank e2) +acmpTerm = + acmpTermLevels 0 emptyVarEnv emptyVarEnv emptyVarEnv emptyVarEnv - goAlt env (DataPat c1 tvs1 ids1,e1) (DataPat c2 tvs2 ids2,e2) = - compare c1 c2 `thenCompare` go env' e1 e2 - where - env' = rnTmBndrs (rnTyBndrs env tvs1 tvs2) ids1 ids2 - goAlt env (c1,e1) (c2,e2) = - compare c1 c2 `thenCompare` go env e1 e2 +-- | Alpha equality for ticks +aeqTickInfo + :: TickInfo + -> TickInfo + -> Bool +aeqTickInfo t1 t2 = acmpTickInfo t1 t2 == EQ +{-# INLINE aeqTickInfo #-} - getRank :: Term -> Word - getRank = \case - Var {} -> 0 - Data {} -> 1 - Literal {} -> 2 - Prim {} -> 3 - Cast {} -> 4 - App {} -> 5 - TyApp {} -> 6 - Lam {} -> 7 - TyLam {} -> 8 - Let NonRec{} _ -> 9 - Let Rec{} _ -> 10 - Case {} -> 11 - Tick {} -> 12 +-- | Alpha comparison for ticks +acmpTickInfo + :: TickInfo + -> TickInfo + -> Ordering +acmpTickInfo = + acmpTickInfoLevels 0 emptyVarEnv emptyVarEnv emptyVarEnv emptyVarEnv -- | Structural equality on 'Term' eqTerm :: Term -> Term -> Bool eqTerm = go where - go (Var id1) (Var id2) = id1 == id2 + go (Var id1) (Var id2) = eqVar id1 id2 go (Data dc1) (Data dc2) = dc1 == dc2 go (Literal l1) (Literal l2) = l1 == l2 go (Prim p1) (Prim p2) = primName p1 == primName p2 - go (Lam b1 e1) (Lam b2 e2) = - b1 == b2 && eqType (varType b1) (varType b2) && go e1 e2 - go (TyLam b1 e1) (TyLam b2 e2) = - b1 == b2 && eqType (varType b1) (varType b2) && go e1 e2 + go (Lam b1 e1) (Lam b2 e2) = eqVar b1 b2 && go e1 e2 + go (TyLam b1 e1) (TyLam b2 e2) = eqVar b1 b2 && go e1 e2 go (App l1 r1) (App l2 r2) = go l1 l2 && go r1 r2 go (TyApp l1 r1) (TyApp l2 r2) = go l1 l2 && eqType r1 r2 go (Let bs1 e1) (Let bs2 e2) = @@ -994,19 +1035,10 @@ b1 == b2 && go r1 r2 goBind (Rec brs1) (Rec brs2) = List.all2 - (\(b1,r1) (b2,r2) -> - b1 == b2 && - -- We need to check the types of Rec bindings, because: - -- - -- letrec (x : Bool) = x in X - -- - -- is not structurally equivalent to - -- - -- letrec (x : Int) = x in x - eqType (varType b1) (varType b2) && - go r1 r2) + (\(b1,r1) (b2,r2) -> eqVar b1 b2 && go r1 r2) brs1 brs2 goBind _ _ = False + -- Note [Case result types and alpha-equivalence] go (Case e1 _ a1) (Case e2 _ a2) = go e1 e2 && List.all2 goAlt a1 a2 @@ -1016,9 +1048,34 @@ go e1 e2 && eqType l1 l2 && eqType r1 r2 - go (Tick t1 e1) (Tick t2 e2) = t1 == t2 && go e1 e2 + go (Tick t1 e1) (Tick t2 e2) = goTick t1 t2 && go e1 e2 go _ _ = False + -- @Eq TickInfo@ compares 'NameMod' and 'Attributes' with alpha-equivalence, + -- which is too coarse here: this is structural equality. + goTick (SrcSpan s1) (SrcSpan s2) = s1 == s2 + goTick (NameMod m1 t1) (NameMod m2 t2) = m1 == m2 && eqType t1 t2 + goTick DeDup DeDup = True + goTick NoDeDup NoDeDup = True + goTick (Attributes t1 a1) (Attributes t2 a2) = eqType t1 t2 && go a1 a2 + goTick _ _ = False + +{- Note [Case result types and alpha-equivalence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'acmpTermLevels' (and hence 'aeqTerm', 'acmpTerm', @Eq Term@ and @Ord Term@) +does not compare the result type stored in a 'Case' constructor, and 'eqTerm' +follows it. This is OK for case expressions with at least one alternative: the +result type is determined by the alternatives. Every alternative's right-hand +side has exactly the result type, and (alpha-)equal right-hand sides have +(alpha-)equal types, so comparing the result type as well would be redundant +work. + +For a case expression with no alternatives the result type is /not/ determined +by the subterms, so @(case x of {}) :: A@ and @(case x of {}) :: B@ compare +equal even though their types differ. Such case expressions don't occur in +CoreHW: @Clash.GHC.GHC2Core@ turns them into an @undefined@ or @undefinedX@. +-} + instance Eq Type where (==) = aeqType @@ -1028,13 +1085,422 @@ instance Eq Term where (==) = aeqTerm -instance TypeError ( - 'Text "A broken implementation of Hashable Term has been " - ':<>: 'Text "removed in Clash 1.4.7. If this is an issue for you, please submit " - ':<>: 'Text "an issue report at https://github.com/clash-lang/clash-compiler/issues." - ) => Hashable Term where - hashWithSalt = error "Term.hashWithSalt: unreachable" +{- Note [Numbering binders by De Bruijn level] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Alpha comparison compares two variable occurrences by their De Bruijn level: +how many binders enclose the binder an occurrence resolves to. Both sides are +walked in lockstep, so at any point they are under equally many binders, and a +level therefore identifies a binder position rather than a name. Two +occurrences are alpha-equal exactly when they resolve to the same level. +Binders that come into scope together, such as those of a 'Rec' or a 'DataPat', +get consecutive levels: they are numbered as if they were nested. +-} +-- | Compare a pair of variable occurrences, under the levels of the binders +-- enclosing them. See Note [Numbering binders by De Bruijn level]. +acmpOccLevels :: + -- | Levels of the binders enclosing the left occurrence + VarEnv Int -> + -- | Levels of the binders enclosing the right occurrence + VarEnv Int -> + Var a -> + Var a -> + Ordering +acmpOccLevels envL envR v1 v2 = + case (lookupVarEnv v1 envL, lookupVarEnv v2 envR) of + -- Both bound: equal exactly when bound at the same level + (Just lvlL, Just lvlR) -> compare lvlL lvlR + -- Neither bound: compare the variables themselves + (Nothing, Nothing) -> compare (varKey v1) (varKey v2) + -- A bound variable is never equal to a free one. Which way round is + -- arbitrary, it only has to be consistent to keep the order total. + (Just _, Nothing) -> LT + (Nothing, Just _) -> GT + +-- | Give a group of binders that come into scope together, such as a 'Rec' or +-- a 'DataPat', consecutive levels, and return the level following the group. +extendLevels :: + Int -> + [Var a] -> + [Var a] -> + VarEnv Int -> + VarEnv Int -> + (Int, VarEnv Int, VarEnv Int) +extendLevels lvl vs1 vs2 envL envR = + List.foldl' one (lvl, envL, envR) (List.zipEqual vs1 vs2) + where + one (!l, eL, eR) (v1, v2) = + (l + 1, extendVarEnv v1 l eL, extendVarEnv v2 l eR) + +-- | Alpha comparison for 'Type's, under the binders enclosing them. +-- See Note [Numbering binders by De Bruijn level]. +acmpTypeLevels :: + -- | Number of enclosing binders + Int -> + -- | Levels of the type binders enclosing the left type + VarEnv Int -> + -- | Levels of the type binders enclosing the right type + VarEnv Int -> + Type -> + Type -> + Ordering +acmpTypeLevels !lvl tyL tyR = go + where + go :: Type -> Type -> Ordering + go (VarTy tv1) (VarTy tv2) = acmpOccLevels tyL tyR tv1 tv2 + go (ConstTy c1) (ConstTy c2) = compare c1 c2 + go (ForAllTy tv1 t1) (ForAllTy tv2 t2) = + go (varType tv1) (varType tv2) `thenCompare` + acmpTypeLevels + (lvl + 1) (extendVarEnv tv1 lvl tyL) (extendVarEnv tv2 lvl tyR) t1 t2 + go (AppTy s1 t1) (AppTy s2 t2) = go s1 s2 `thenCompare` go t1 t2 + go (LitTy l1) (LitTy l2) = compare l1 l2 + go (AnnType a1 t1) (AnnType a2 t2) = compare a1 a2 `thenCompare` go t1 t2 + go t1 t2 = compare (getRank t1) (getRank t2) + + getRank :: Type -> Word + getRank (VarTy {}) = 0 + getRank (LitTy {}) = 1 + getRank (ConstTy {}) = 2 + getRank (AnnType {}) = 3 + getRank (AppTy {}) = 4 + getRank (ForAllTy {}) = 5 + +-- | Alpha comparison for 'Term's. See 'acmpTypeLevels'. +acmpTermLevels :: + -- | Number of enclosing binders + Int -> + -- | Levels of the term binders enclosing the left term + VarEnv Int -> + -- | Levels of the term binders enclosing the right term + VarEnv Int -> + -- | Levels of the type binders enclosing the left term + VarEnv Int -> + -- | Levels of the type binders enclosing the right term + VarEnv Int -> + Term -> + Term -> + Ordering +acmpTermLevels !lvl tmL tmR tyL tyR = go + where + goType = acmpTypeLevels lvl tyL tyR + goTick = acmpTickInfoLevels lvl tmL tmR tyL tyR + + -- Compare underneath one more term or type binder + underTmBndr b1 b2 = + acmpTermLevels + (lvl + 1) (extendVarEnv b1 lvl tmL) (extendVarEnv b2 lvl tmR) tyL tyR + underTyBndr b1 b2 = + acmpTermLevels + (lvl + 1) tmL tmR (extendVarEnv b1 lvl tyL) (extendVarEnv b2 lvl tyR) + + go :: Term -> Term -> Ordering + go (Var id1) (Var id2) = goVar id1 id2 + go (Data dc1) (Data dc2) = compare dc1 dc2 + go (Literal l1) (Literal l2) = compare l1 l2 + go (Prim p1) (Prim p2) = comparing primName p1 p2 + go (Lam b1 e1) (Lam b2 e2) = + goType (varType b1) (varType b2) `thenCompare` underTmBndr b1 b2 e1 e2 + go (TyLam b1 e1) (TyLam b2 e2) = + goType (varType b1) (varType b2) `thenCompare` underTyBndr b1 b2 e1 e2 + go (App l1 r1) (App l2 r2) = go l1 l2 `thenCompare` go r1 r2 + go (TyApp l1 r1) (TyApp l2 r2) = go l1 l2 `thenCompare` goType r1 r2 + go (Let (NonRec i1 x1) e1) (Let (NonRec i2 x2) e2) = + go x1 x2 `thenCompare` underTmBndr i1 i2 e1 e2 + go (Let (Rec bs1) e1) (Let (Rec bs2) e2) = + -- The lengths are compared first: the binder lists are only numbered + -- against each other when they match + compare (length bs1) (length bs2) `thenCompare` + let (ids1, rhs1) = unzip bs1 + (ids2, rhs2) = unzip bs2 + (lvl', tmL', tmR') = extendLevels lvl ids1 ids2 tmL tmR + under = acmpTermLevels lvl' tmL' tmR' tyL tyR + -- Note that we compare types, because: + -- + -- let (x :: Int) = x in x + -- + -- is not alpha equivalent to: + -- + -- let (x :: Word) = x in x + -- + in goList goType (map varType ids1) (map varType ids2) `thenCompare` + (goList under rhs1 rhs2 `thenCompare` under e1 e2) + -- Note [Case result types and alpha-equivalence] + go (Case e1 _ a1) (Case e2 _ a2) = + compare (length a1) (length a2) `thenCompare` + (go e1 e2 `thenCompare` goAlts a1 a2) + go (Cast e1 l1 r1) (Cast e2 l2 r2) = + go e1 e2 `thenCompare` (goType l1 l2 `thenCompare` goType r1 r2) + go (Tick t1 e1) (Tick t2 e2) = goTick t1 t2 `thenCompare` go e1 e2 + go e1 e2 = compare (getRank e1) (getRank e2) + + goList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering + goList cmp (x : xs) (y : ys) = cmp x y `thenCompare` goList cmp xs ys + goList _ _ _ = EQ + + goAlts :: [Alt] -> [Alt] -> Ordering + goAlts (x : xs) (y : ys) = goAlt x y `thenCompare` goAlts xs ys + goAlts _ _ = EQ + + goAlt :: Alt -> Alt -> Ordering + goAlt (DataPat c1 tvs1 ids1, e1) (DataPat c2 tvs2 ids2, e2) = + -- Two 'DataPat's for the same 'DataCon' necessarily bind equally many + -- variables, so 'extendLevels' erroring on lists of unequal length is the + -- right response to Core that is already ill-formed + compare c1 c2 `thenCompare` + let (lvlTy, tyL', tyR') = extendLevels lvl tvs1 tvs2 tyL tyR + (lvl', tmL', tmR') = extendLevels lvlTy ids1 ids2 tmL tmR + in acmpTermLevels lvl' tmL' tmR' tyL' tyR' e1 e2 + goAlt (c1, e1) (c2, e2) = compare c1 c2 `thenCompare` go e1 e2 + + goVar :: Id -> Id -> Ordering + goVar id1 id2 + -- A global is never bound by an enclosing binder, so it never resolves to + -- a level. Checked before the environments, because those are keyed on + -- unique alone and a global may share a unique with a bound local. + | isGlobalId id1 || isGlobalId id2 = compare (varKey id1) (varKey id2) + | otherwise = acmpOccLevels tmL tmR id1 id2 + + getRank :: Term -> Word + getRank = \case + Var {} -> 0 + Data {} -> 1 + Literal {} -> 2 + Prim {} -> 3 + Cast {} -> 4 + App {} -> 5 + TyApp {} -> 6 + Lam {} -> 7 + TyLam {} -> 8 + Let NonRec{} _ -> 9 + Let Rec{} _ -> 10 + Case {} -> 11 + Tick {} -> 12 + +-- | Alpha equality for ticks, under the binders enclosing them. +-- See 'acmpTickInfoLevels'. +aeqTickInfoLevels :: + -- | Number of enclosing binders + Int -> + -- | Levels of the term binders enclosing the left tick + VarEnv Int -> + -- | Levels of the term binders enclosing the right tick + VarEnv Int -> + -- | Levels of the type binders enclosing the left tick + VarEnv Int -> + -- | Levels of the type binders enclosing the right tick + VarEnv Int -> + TickInfo -> + TickInfo -> + Bool +aeqTickInfoLevels lvl tmL tmR tyL tyR t1 t2 = + acmpTickInfoLevels lvl tmL tmR tyL tyR t1 t2 == EQ +{-# INLINE aeqTickInfoLevels #-} + +-- | Alpha comparison for ticks, under the binders enclosing them. +-- +-- The 'Type' in 'NameMod' and the 'Term' in 'Attributes' live in the scope +-- enclosing the tick, so they are compared under the same binders as the term +-- the tick is attached to. 'SrcSpan's are compared with 'leftmost_smallest', +-- which treats all unhelpful spans alike, so it is coarser than @Eq TickInfo@. +acmpTickInfoLevels :: + -- | Number of enclosing binders + Int -> + -- | Levels of the term binders enclosing the left tick + VarEnv Int -> + -- | Levels of the term binders enclosing the right tick + VarEnv Int -> + -- | Levels of the type binders enclosing the left tick + VarEnv Int -> + -- | Levels of the type binders enclosing the right tick + VarEnv Int -> + TickInfo -> + TickInfo -> + Ordering +acmpTickInfoLevels !lvl tmL tmR tyL tyR = go + where + goType = acmpTypeLevels lvl tyL tyR + goTerm = acmpTermLevels lvl tmL tmR tyL tyR + + go :: TickInfo -> TickInfo -> Ordering + go (SrcSpan s1) (SrcSpan s2) = leftmost_smallest s1 s2 + go (NameMod m1 t1) (NameMod m2 t2) = compare m1 m2 `thenCompare` goType t1 t2 + go (Attributes t1 a1) (Attributes t2 a2) = + goType t1 t2 `thenCompare` goTerm a1 a2 + go t1 t2 = compare (getRank t1) (getRank t2) + + getRank :: TickInfo -> Word + getRank = \case + SrcSpan {} -> 0 + NameMod {} -> 1 + DeDup -> 2 + NoDeDup -> 3 + Attributes {} -> 4 + instance Ord Term where compare = acmpTerm + +-- * Alpha hashing +-- +-- Hashing is modulo alpha equivalence, so that it agrees with @Eq Term@ and +-- @Eq Type@: alpha-equivalent terms hash alike. Only that direction holds, +-- terms that are not alpha-equivalent may collide as with any hash. A bound +-- variable is hashed by its De Bruijn level, see +-- Note [Numbering binders by De Bruijn level]. + +-- | Mix the tag of a constructor into a salt, so that terms differing only in +-- which constructor they use do not hash alike. +hashTag :: Int -> Int -> Int +hashTag = hashWithSalt + +-- | Give a group of binders that come into scope together, such as a 'Rec' or a +-- 'DataPat', consecutive levels, and return the level following the group. +extendLevelsOf :: Int -> [Var a] -> VarEnv Int -> (Int, VarEnv Int) +extendLevelsOf lvl vs env = List.foldl' one (lvl, env) vs + where + one (!l, e) v = (l + 1, extendVarEnv v l e) + +-- | Hash a 'SrcSpan' only as finely as @Eq Term@ tells one apart: all +-- 'UnhelpfulSpan's alike, and a 'RealSrcSpan' by its file name and its start +-- and end positions. The structural @Hashable SrcSpan@ orphan from +-- "GHC.SrcLoc.Extra" is finer than that, as it takes in the buffer span and the +-- reason of an unhelpful span as well, and would tell alpha-equivalent terms +-- apart. +hashSrcSpan :: Int -> SrcSpan -> Int +hashSrcSpan salt = \case + RealSrcSpan realSrcSpan _bufSpan -> hashWithSalt salt (0 :: Int, realSrcSpan) + UnhelpfulSpan _reason -> hashWithSalt salt (1 :: Int) + +-- | Hash a 'Type' modulo alpha, under the binders enclosing it. +-- See Note [Numbering binders by De Bruijn level]. +aTypeHashLevels :: + -- | Number of enclosing binders + Int -> + -- | Levels of the type binders enclosing the type + VarEnv Int -> + -- | Salt + Int -> + Type -> + Int +aTypeHashLevels !lvl tyEnv = go + where + go :: Int -> Type -> Int + go salt = \case + VarTy tv -> + -- N.B.: Variables are hashed with a "tag" to differentiate between, e.g., + -- a bound local variable bound at level "2" and a free local variable + -- with unique "2". + case lookupVarEnv tv tyEnv of + Just boundLvl -> hashWithSalt salt (0 :: Int, boundLvl) + Nothing -> hashWithSalt salt (1 :: Int, varUniq tv) + LitTy l -> hashWithSalt (hashTag salt 1) l + ConstTy c -> hashWithSalt (hashTag salt 2) c + AnnType attrs t -> go (hashWithSalt (hashTag salt 3) attrs) t + AppTy t1 t2 -> go (go (hashTag salt 4) t1) t2 + ForAllTy tv t -> + aTypeHashLevels (lvl + 1) (extendVarEnv tv lvl tyEnv) + (go (hashTag salt 5) (varType tv)) t + +-- | Hash a 'Term' modulo alpha, under the binders enclosing it. +-- See Note [Numbering binders by De Bruijn level]. +aTermHashLevels :: + -- | Number of enclosing binders + Int -> + -- | Levels of the term binders enclosing the term + VarEnv Int -> + -- | Levels of the type binders enclosing the term + VarEnv Int -> + -- | Salt + Int -> + Term -> + Int +aTermHashLevels !lvl tmEnv tyEnv = go + where + goType = aTypeHashLevels lvl tyEnv + + underTmBndr b = aTermHashLevels (lvl + 1) (extendVarEnv b lvl tmEnv) tyEnv + underTyBndr b = aTermHashLevels (lvl + 1) tmEnv (extendVarEnv b lvl tyEnv) + + go :: Int -> Term -> Int + go salt = \case + Var i -> goVar (hashTag salt 0) i + Data dc -> hashWithSalt (hashTag salt 1) dc + Literal l -> hashWithSalt (hashTag salt 2) l + -- A primitive is identified by its name + Prim p -> hashWithSalt (hashTag salt 3) (primName p) + Cast e t1 t2 -> goType (goType (go (hashTag salt 4) e) t1) t2 + App e1 e2 -> go (go (hashTag salt 5) e1) e2 + TyApp e t -> goType (go (hashTag salt 6) e) t + Lam b e -> underTmBndr b (goType (hashTag salt 7) (varType b)) e + TyLam b e -> underTyBndr b (goType (hashTag salt 8) (varType b)) e + -- A 'NonRec' binder's type is pinned down by its right-hand side, so it is + -- left out. A 'Rec' binder may occur in its own right-hand side, and then + -- it is not: @let x = x in x@ is the same term whether @x@ is an Int or a + -- Bool. + Let (NonRec i x) e -> underTmBndr i (go (hashTag salt 9) x) e + Let (Rec bs) e -> + let (ids, rhss) = unzip bs + (lvl', tmEnv') = extendLevelsOf lvl ids tmEnv + under = aTermHashLevels lvl' tmEnv' tyEnv + types = goList goType (hashTag salt 10) (map varType ids) + in under (goList under types rhss) e + -- Note [Case result types and alpha-equivalence] + Case subj _ty alts -> goList goAlt (go (hashTag salt 11) subj) alts + Tick tick e -> go (goTick (hashTag salt 12) tick) e + + -- Hash a list, mixing in its length, so that a list does not hash like one of + -- its prefixes + goList :: (Int -> a -> Int) -> Int -> [a] -> Int + goList hashElement salt xs = + hashWithSalt (List.foldl' hashElement salt xs) (length xs) + + goAlt :: Int -> Alt -> Int + goAlt salt = \case + -- A 'DataCon' fixes how many variables its 'DataPat' binds, so the binder + -- counts need no hashing of their own + (DataPat dc tvs ids, e) -> + let (lvlTy, tyEnv') = extendLevelsOf lvl tvs tyEnv + (lvl', tmEnv') = extendLevelsOf lvlTy ids tmEnv + in aTermHashLevels lvl' tmEnv' tyEnv' + (hashWithSalt (hashTag salt 0) dc) e + (LitPat l, e) -> go (hashWithSalt (hashTag salt 1) l) e + (DefaultPat, e) -> go (hashTag salt 2) e + + -- N.B.: Variables are hashed with a "tag" to differentiate between, e.g., a + -- local free variable with unique "2" and a bound free variable which + -- happens to be bound at level 2. + goVar :: Int -> Id -> Int + goVar salt i + -- Global, never bound with respect to 'tmEnv' + | isGlobalId i = hashWithSalt salt (0 :: Int, varUniq i) + -- Local, bound variable + | Just boundLvl <- lookupVarEnv i tmEnv = hashWithSalt salt (1 :: Int, boundLvl) + -- Free, local variable + | otherwise = hashWithSalt salt (2 :: Int, varUniq i) + + -- A tick's payload lives in the scope enclosing the tick, so it is hashed + -- under the enclosing binders rather than in isolation + goTick :: Int -> TickInfo -> Int + goTick salt = \case + SrcSpan s -> hashSrcSpan (hashTag salt 0) s + NameMod m t -> goType (hashWithSalt (hashTag salt 1) m) t + DeDup -> hashTag salt 2 + NoDeDup -> hashTag salt 3 + Attributes t e -> go (goType (hashTag salt 4) t) e + +-- | Hash a 'Type' modulo alpha. +-- See Note [Numbering binders by De Bruijn level]. +aTypeHashWithSalt :: Int -> Type -> Int +aTypeHashWithSalt = aTypeHashLevels 0 emptyVarEnv + +-- | Hash a 'Term' modulo alpha. +-- See Note [Numbering binders by De Bruijn level]. +aTermHashWithSalt :: Int -> Term -> Int +aTermHashWithSalt = aTermHashLevels 0 emptyVarEnv emptyVarEnv + +instance Hashable Type where + hashWithSalt = aTypeHashWithSalt + +instance Hashable Term where + hashWithSalt = aTermHashWithSalt diff --git a/src/Clash/Core/Subst.hs-boot b/src/Clash/Core/Subst.hs-boot --- a/src/Clash/Core/Subst.hs-boot +++ b/src/Clash/Core/Subst.hs-boot @@ -3,7 +3,7 @@ module Clash.Core.Subst where import GHC.Stack (HasCallStack) -import {-# SOURCE #-} Clash.Core.Term (Term) +import {-# SOURCE #-} Clash.Core.Term (Term, TickInfo) import {-# SOURCE #-} Clash.Core.Type (Type) import Clash.Core.Var (TyVar) @@ -22,6 +22,6 @@ instance Eq Type instance Ord Type -acmpTerm :: Term -> Term -> Ordering +acmpTickInfo :: TickInfo -> TickInfo -> Ordering instance Eq Term diff --git a/src/Clash/Core/Term.hs b/src/Clash/Core/Term.hs --- a/src/Clash/Core/Term.hs +++ b/src/Clash/Core/Term.hs @@ -71,16 +71,16 @@ import Data.List (nub, partition) import Data.Text (Text) import GHC.Generics -import GHC.Types.SrcLoc (SrcSpan, leftmost_smallest) +import GHC.Types.SrcLoc (SrcSpan) -- Internal Modules import Clash.Core.DataCon (DataCon) import Clash.Core.Literal (Literal) import Clash.Core.Name (Name (..)) -import {-# SOURCE #-} Clash.Core.Subst (acmpTerm) -- instance Eq/Ord Type, Eq Term +import {-# SOURCE #-} Clash.Core.Subst (acmpTickInfo) -- instance Eq/Ord Type, Eq Term import {-# SOURCE #-} Clash.Core.Type (Type) import Clash.Core.Var (Var, Id, TyVar) -import Clash.Util (curLoc, thenCompare) +import Clash.Util (curLoc) -- | Term representation in the CoreHW language: System F + LetRec + Case data Term @@ -126,19 +126,7 @@ deriving (Eq, Show, Generic, NFData, Binary) instance Ord TickInfo where - compare (SrcSpan s1) (SrcSpan s2) = leftmost_smallest s1 s2 - compare (NameMod m1 t1) (NameMod m2 t2) = - compare m1 m2 `thenCompare` compare t1 t2 - compare (Attributes t1 a1) (Attributes t2 a2) = - compare t1 t2 `thenCompare` acmpTerm a1 a2 - compare t1 t2 = compare (getRank t1) (getRank t2) - where - getRank :: TickInfo -> Word - getRank SrcSpan{} = 0 - getRank NameMod{} = 1 - getRank DeDup = 2 - getRank NoDeDup = 3 - getRank Attributes {} = 4 + compare = acmpTickInfo -- | Tag to indicate which instance/register name modifier was used data NameMod diff --git a/src/Clash/Core/Term.hs-boot b/src/Clash/Core/Term.hs-boot --- a/src/Clash/Core/Term.hs-boot +++ b/src/Clash/Core/Term.hs-boot @@ -13,6 +13,8 @@ data Term +data TickInfo + type TmName = Name Term instance Generic Term diff --git a/src/Clash/Core/TermInfo.hs b/src/Clash/Core/TermInfo.hs --- a/src/Clash/Core/TermInfo.hs +++ b/src/Clash/Core/TermInfo.hs @@ -5,7 +5,7 @@ module Clash.Core.TermInfo where -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, isJust) import GHC.Stack (HasCallStack) import Clash.Core.HasType @@ -36,6 +36,37 @@ where subjSz = termSize subj altSzs = map (termSize . snd) alts + +-- | @termSizeSmallerThan n t@ is @'termSize' t < n@, but stops traversing @t@ +-- as soon as the size reaches @n@. Use this instead of 'termSize' when +-- comparing against a limit: inlining heuristics routinely compare very large +-- terms against small limits, and only the first @n@ nodes decide the answer. +termSizeSmallerThan :: Word -> Term -> Bool +termSizeSmallerThan n t0 + | n == 0 = False + | otherwise = isJust (go (n - 1) [t0]) + where + -- @go budget ts@ returns the remaining budget after spending the summed + -- 'termSize' of @ts@, or 'Nothing' if the budget does not cover it + go :: Word -> [Term] -> Maybe Word + go budget [] = Just budget + go budget (t:rest) = case t of + Var {} -> spend budget rest + Data {} -> spend budget rest + Literal {} -> spend budget rest + Prim {} -> spend budget rest + Lam _ e -> spend budget (e:rest) + TyLam _ e -> go budget (e:rest) + App e1 e2 -> go budget (e1:e2:rest) + TyApp e _ -> go budget (e:rest) + Cast e _ _ -> go budget (e:rest) + Tick _ e -> go budget (e:rest) + Let (NonRec _ x) e -> go budget (x:e:rest) + Let (Rec xs) e -> go budget (map snd xs ++ e:rest) + Case subj _ alts -> go budget (subj : map snd alts ++ rest) + + spend 0 _ = Nothing + spend budget rest = go (budget - 1) rest multPrimErr :: PrimInfo -> String multPrimErr primInfo = [I.i| diff --git a/src/Clash/Core/Type.hs b/src/Clash/Core/Type.hs --- a/src/Clash/Core/Type.hs +++ b/src/Clash/Core/Type.hs @@ -62,7 +62,7 @@ import Control.DeepSeq as DS import Data.Binary (Binary) import Data.Coerce (coerce) -import Data.Hashable (Hashable (hashWithSalt)) +import Data.Hashable (Hashable) #if !MIN_VERSION_base(4,20,0) import Data.List (foldl') #endif @@ -73,7 +73,6 @@ import GHC.Generics (Generic(..)) import GHC.Integer (smallInteger) import GHC.Integer.Logarithms (integerLogBase#) -import GHC.TypeLits (type TypeError, ErrorMessage(Text, (:<>:))) import GHC.Base (ord) import Data.Char (chr) import Data.Maybe (fromMaybe) @@ -121,13 +120,6 @@ | LitTy !LitTy -- ^ Type literal | AnnType [Attr Text] !Type -- ^ Annotated type, see Clash.Annotations.SynthesisAttributes deriving (Show, Generic, NFData, Binary) - -instance TypeError ( - 'Text "A broken implementation of Hashable Type has been " - ':<>: 'Text "removed in Clash 1.4.7. If this is an issue for you, please submit " - ':<>: 'Text "an issue report at https://github.com/clash-lang/clash-compiler/issues." - ) => Hashable Type where - hashWithSalt = error "Type.hashWithSalt: unreachable" -- | An easier view on types data TypeView diff --git a/src/Clash/Core/Var.hs b/src/Clash/Core/Var.hs --- a/src/Clash/Core/Var.hs +++ b/src/Clash/Core/Var.hs @@ -18,6 +18,7 @@ , IdScope (..) , Id , TyVar + , varKey , mkId , mkLocalId , mkGlobalId @@ -68,10 +69,16 @@ instance Hashable (Var a) where hashWithSalt salt a = hashWithSalt salt (varKey a) +-- | N.B.: Equality checking assumes two variables are compared in the same +-- scope, similar to `aeqType` and friends. If you want structural equality, +-- use Subst's `eqVar`. instance Eq (Var a) where (==) = (==) `on` varKey (/=) = (/=) `on` varKey +-- | N.B.: Equality checking assumes two variables are compared in the same +-- scope, similar to `acmpType` and friends. If you want structural equality, +-- use Subst's `ordVar`. instance Ord (Var a) where compare = compare `on` varKey diff --git a/src/Clash/Core/VarEnv.hs b/src/Clash/Core/VarEnv.hs --- a/src/Clash/Core/VarEnv.hs +++ b/src/Clash/Core/VarEnv.hs @@ -45,6 +45,7 @@ , emptyVarSet , unitVarSet -- ** Modification + , extendVarSet , delVarSetByKey , unionVarSet , differenceVarSet @@ -81,19 +82,6 @@ -- ** Unique generation , uniqAway , uniqAway' - -- * Dual renaming - , RnEnv - -- ** Construction - , mkRnEnv - -- ** Renaming - , rnTmBndr - , rnTyBndr - , rnTmBndrs - , rnTyBndrs - , rnOccLId - , rnOccRId - , rnOccLTy - , rnOccRTy ) where @@ -105,8 +93,6 @@ import Data.Binary (Binary) import Data.Coerce (coerce) import qualified Data.List as List -import qualified Data.List.Extra as List -import Data.Maybe (fromMaybe) #ifdef UNIQUE_IS_WORD64 import Data.Word (Word64) #endif @@ -527,130 +513,3 @@ -> Seed -> Unique deriveUnique i delta = i + delta - --- * RnEnv - --- | Rename environment for e.g. alpha equivalence --- --- When going under binders for e.g. --- --- @ --- \x -> e1 `aeq` \y -> e2 --- @ --- --- We want to rename @[x -> y]@ or @[y -> x]@, but we have to pick a binder --- that is neither free in @e1@ nor @e2@ or we risk accidental capture. --- --- So we must maintain: --- --- 1. A renaming for the left term --- --- 2. A renaming for the right term --- --- 3. A set of in scope variables -data RnEnv - = RnEnv - { rn_envLTy :: VarEnv TyVar - -- ^ Type renaming for the left term - , rn_envLTm :: VarEnv Id - -- ^ Term renaming for the left term - , rn_envRTy :: VarEnv TyVar - -- ^ Type renaming for the right term - , rn_envRTm :: VarEnv Id - -- ^ Term renaming for the right term - , rn_inScope :: InScopeSet - -- ^ In scope in left or right terms - } - --- | Create an empty renaming environment -mkRnEnv - :: InScopeSet -> RnEnv -mkRnEnv vars - = RnEnv - { rn_envLTy = emptyVarEnv - , rn_envLTm = emptyVarEnv - , rn_envRTy = emptyVarEnv - , rn_envRTm = emptyVarEnv - , rn_inScope = vars - } - --- | Look up the renaming of an type-variable occurrence in the left term -rnOccLTy - :: RnEnv -> TyVar -> TyVar -rnOccLTy rn v = fromMaybe v (lookupVarEnv v (rn_envLTy rn)) - --- | Look up the renaming of an type-variable occurrence in the right term -rnOccRTy - :: RnEnv -> TyVar -> TyVar -rnOccRTy rn v = fromMaybe v (lookupVarEnv v (rn_envRTy rn)) - --- | Simultaneously go under the type-variable binder /bTvL/ and type-variable --- binder /bTvR/, finds a new binder /newTvB/, and return an environment mapping --- @[bTvL -> newB]@ and @[bTvR -> newB]@ -rnTyBndr - :: RnEnv -> TyVar -> TyVar -> RnEnv -rnTyBndr rv@(RnEnv {rn_envLTy = lenv, rn_envRTy = renv, rn_inScope = inScope}) bL bR = - rv { rn_envLTy = extendVarEnv bL newB lenv -- See Note [Rebinding and shadowing] - , rn_envRTy = extendVarEnv bR newB renv - , rn_inScope = extendInScopeSet inScope newB } - where - -- Find a new type-binder not in scope in either term - newB | not (bL `elemInScopeSet` inScope) = bL - | not (bR `elemInScopeSet` inScope) = bR - | otherwise = uniqAway inScope bL - -{- Note [Rebinding and shadowing] -Imagine: - -@ -\x -> \x -> e1 `aeq` \y -> \x -> e2 -@ - -Then inside - -@ -\x \y { [x->p] [y->p] {p} } -\x \z { [x->q] [y->p, z->q] {p,q} } -@ - -i.e. if the new var is the same as the old var, the renaming is deleted by -'extendVarEnv' --} - --- | Applies 'rnTyBndr' to several variables: the two variable lists must be of --- equal length. -rnTyBndrs - :: RnEnv -> [TyVar] -> [TyVar] -> RnEnv -rnTyBndrs env tvs1 tvs2 = - List.foldl' (\s (l,r) -> rnTyBndr s l r) env (List.zipEqual tvs1 tvs2) - --- | Look up the renaming of an occurrence in the left term -rnOccLId - :: RnEnv -> Id -> Id -rnOccLId rn v = fromMaybe v (lookupVarEnv v (rn_envLTm rn)) - --- | Look up the renaming of an occurrence in the left term -rnOccRId - :: RnEnv -> Id -> Id -rnOccRId rn v = fromMaybe v (lookupVarEnv v (rn_envRTm rn)) - --- | Simultaneously go under the binder /bL/ and binder /bR/, finds a new binder --- /newTvB/, and return an environment mapping @[bL -> newB]@ and @[bR -> newB]@ -rnTmBndr - :: RnEnv -> Id -> Id -> RnEnv -rnTmBndr rv@(RnEnv {rn_envLTm = lenv, rn_envRTm = renv, rn_inScope = inScope}) bL bR = - rv { rn_envLTm = extendVarEnv bL newB lenv -- See Note [Rebinding and shadowing] - , rn_envRTm = extendVarEnv bR newB renv - , rn_inScope = extendInScopeSet inScope newB } - where - -- Find a new type-binder not in scope in either term - newB | not (bL `elemInScopeSet` inScope) = bL - | not (bR `elemInScopeSet` inScope) = bR - | otherwise = uniqAway inScope bL - --- | Applies 'rnTmBndr' to several variables: the two variable lists must be of --- equal length. -rnTmBndrs - :: RnEnv -> [Id] -> [Id] -> RnEnv -rnTmBndrs env ids1 ids2 = - List.foldl' (\s (l,r) -> rnTmBndr s l r) env (List.zipEqual ids1 ids2) diff --git a/src/Clash/Data/UniqMap.hs b/src/Clash/Data/UniqMap.hs --- a/src/Clash/Data/UniqMap.hs +++ b/src/Clash/Data/UniqMap.hs @@ -19,6 +19,7 @@ , insertUnique , insertWith , insertMany + , insertIfAbsent , lookup , find , elem @@ -144,6 +145,13 @@ insertMany :: Uniquable a => [(a, b)] -> UniqMap b -> UniqMap b insertMany kvs xs = List.foldl' (\acc (k, v) -> insert k v acc) xs kvs + +{-# SPECIALIZE insertIfAbsent :: Unique -> b -> UniqMap b -> UniqMap b #-} +-- | Insert a key-value pair into the map if the key is not already present. Note +-- that this will first do a lookup and only then use insert (when applicable). +-- Use this when you can reasonably expect the key to already exist. +insertIfAbsent :: Uniquable a => a -> b -> UniqMap b -> UniqMap b +insertIfAbsent k v m = if elem k m then m else insert k v m {-# SPECIALIZE lookup :: Unique -> UniqMap b -> Maybe b #-} -- | Lookup an item in the map, using the unique of the given key. diff --git a/src/Clash/Driver.hs b/src/Clash/Driver.hs --- a/src/Clash/Driver.hs +++ b/src/Clash/Driver.hs @@ -4,6 +4,7 @@ 2017 , QBayLogic, Google Inc. 2020-2024, QBayLogic, 2022 , Google Inc. + 2026 , Martijn Bastiaan License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -28,9 +29,8 @@ import Control.Exception (evaluate, throw, Exception) import qualified Control.Monad as Monad import Control.Monad (unless, foldM, forM) -import Control.Monad.Catch (MonadMask, MonadThrow (throwM)) +import Control.Monad.Catch (MonadThrow (throwM), try) import Control.Monad.Extra (whenM, ifM, unlessM) -import Control.Monad.IO.Class (MonadIO) import Control.Monad.State (evalState, get) import Control.Monad.State.Strict (State) import qualified Control.Monad.State.Strict as State @@ -42,13 +42,14 @@ import qualified Data.ByteString.Lazy.Char8 as ByteStringLazyChar8 import Data.Char (isAscii, isAlphaNum) import Data.Default -import Data.Hashable (hash) +import Data.Hashable (Hashable, hash) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import qualified Data.HashSet as HashSet import Data.Proxy (Proxy(..)) import Data.List (intercalate) import qualified Data.List as List +import qualified Data.List.Extra as List import Data.List.NonEmpty (NonEmpty((:|))) import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe (fromMaybe, maybeToList, mapMaybe) @@ -63,6 +64,7 @@ import Data.Text.Prettyprint.Doc.Extra (Doc, LayoutOptions (..), PageWidth (..) , layoutPretty, renderLazy) import qualified Data.Time.Clock as Clock +import GHC.Generics (Generic) import GHC.Stack (HasCallStack) import qualified Language.Haskell.Interpreter as Hint import qualified Language.Haskell.Interpreter.Extension as Hint @@ -86,7 +88,7 @@ import GHC.BasicTypes.Extra () import Clash.Annotations.Primitive - (HDL (..)) + (HDL (..), extractPrim) import Clash.Annotations.BitRepresentation.Internal (CustomReprs) import Clash.Annotations.TopEntity @@ -517,67 +519,176 @@ withMVar ioLockV . const $ putStrLn ("Clash: Compiling " ++ topEntityS ++ " took " ++ topDiff) --- | Interpret a specific function from a specific module. This action tries --- two things: +-- | Whether a function should be interpreted as a 'BlackBoxFunction' or a +-- 'TemplateFunction'. +data InterpretFunctionType + = InterpretBlackBoxFunction + | InterpretTemplateFunction + deriving (Eq, Ord, Show, Generic, Hashable) + +-- | A single function that needs to be interpreted with Hint in order to +-- compile a primitive. Multiple primitives referencing the same function map +-- to the same request, so interpreting the distinct requests of a primitive +-- map compiles each function exactly once. +data InterpretFunctionRequest = InterpretFunctionRequest + { ifrModNames :: [String] + -- ^ Module the function lives in, one entry per module name component + , ifrFuncName :: String + -- ^ Function name + , ifrType :: InterpretFunctionType + -- ^ Type to interpret the function at + , ifrSource :: Maybe Text + -- ^ Inline Haskell source of the module, if the primitive provided one + } deriving (Eq, Ord, Show, Generic, Hashable) + +-- | Module the function of an 'InterpretFunctionRequest' lives in, as a +-- qualified module name +interpretFunctionRequestToModuleName :: InterpretFunctionRequest -> Hint.ModuleName +interpretFunctionRequestToModuleName = intercalate "." . ifrModNames + +-- | The result of interpreting an 'InterpretFunctionRequest' +data InterpretFunctionResult + = InterpretBBF BlackBoxFunction + | InterpretTF TemplateFunction + +type InterpretResults = + HashMap InterpretFunctionRequest + (Either (NonEmpty Hint.InterpreterError) InterpretFunctionResult) + +-- | Language extensions in effect when interpreting inline primitive sources +hintLanguageExtensions :: [Hint.Extension] +hintLanguageExtensions = + map Hint.asExtension $ + map show wantedLanguageExtensions ++ + map ("No" ++ ) (map show unwantedLanguageExtensions) + +-- | The functions a primitive needs interpreted before it can be compiled by +-- 'compilePrimitiveWith'. Functions in 'knownBlackBoxFunctions' or +-- 'knownTemplateFunctions' need no interpretation and yield no request. +neededInterpRequests :: ResolvedPrimitive -> [InterpretFunctionRequest] +neededInterpRequests (BlackBoxHaskell _ _ _ _ bbGenName source) + | HashMap.member fullName knownBlackBoxFunctions = [] + | otherwise = + [InterpretFunctionRequest modNames funcName InterpretBlackBoxFunction source] + where + fullName = intercalate "." modNames ++ "." ++ funcName + BlackBoxFunctionName modNames funcName = bbGenName +neededInterpRequests (BlackBox _ _ _ _ _ _ _ _ _ _ incs rM riM templ) = + concatMap go (templ : rM ++ riM ++ map snd incs) + where + go ((TTemplate, _), _) = [] + go ((THaskell, BlackBoxFunctionName modNames funcName), source@(Just _)) = + [InterpretFunctionRequest modNames funcName InterpretTemplateFunction source] + go ((THaskell, BlackBoxFunctionName modNames funcName), Nothing) + | HashMap.member fullName knownTemplateFunctions = [] + | otherwise = + [InterpretFunctionRequest modNames funcName InterpretTemplateFunction Nothing] + where + fullName = intercalate "." modNames ++ "." ++ funcName +neededInterpRequests (Primitive {}) = [] + +-- | Interpret the given functions in a single shared Hint session. Starting a +-- session is expensive (it initializes a full GHC session, including reading +-- all package databases), so sharing one session over all requests is much +-- faster than a session per function. For each request this action tries two +-- things: -- -- 1. Interpret without explicitly loading the module. This will succeed if --- the module was already loaded through a package database (set using --- 'interpreterArgs'). +-- the module can be found in the package databases (passed in as +-- @-package-db@ interpreter arguments). -- --- 2. If (1) fails, it does try to load it explicitly. If this also fails, --- an error is returned. +-- 2. If (1) fails, try to load the module explicitly: either from the +-- inline source a primitive provided, or from the import directories. +-- If this also fails, an error is recorded for the request. -- -loadImportAndInterpret - :: (MonadIO m, MonadMask m) - => [String] - -- ^ Extra search path (usually passed as -i) - -> [String] - -- ^ Interpreter args - -> String +-- All (1) attempts run before the first (2) attempt, so that interpreting +-- against the package databases is never influenced by locally loaded +-- modules. Note that 'Hint.loadModules' resets previously loaded modules, so +-- (2) attempts cannot see each other's modules either. +interpretFunctions + :: [FilePath] + -- ^ Import directories (-i flag) + -> [FilePath] + -- ^ Package databases + -> FilePath -- ^ The folder in which the GHC bootstrap libraries (base, containers, etc.) -- can be found - -> Hint.ModuleName - -- ^ Module function lives in - -> String - -- ^ Function name - -> String - -- ^ Type name ('BlackBoxFunction' or 'TemplateFunction') - -> m (Either (NonEmpty Hint.InterpreterError) a) -loadImportAndInterpret iPaths0 interpreterArgs topDir qualMod funcName typ = do - Hint.liftIO $ Monad.when debugIsOn $ - putStr "Hint: Interpreting " >> putStrLn (qualMod ++ "." ++ funcName) - -- Try to interpret function *without* loading module explicitly. If this - -- succeeds, the module was already in the global package database(s). - bbfE <- Hint.unsafeRunInterpreterWithArgsLibdir interpreterArgs topDir $ do - iPaths1 <- (++iPaths0) <$> Hint.get Hint.searchPath - Hint.set [Hint.searchPath Hint.:= iPaths1] - Hint.setImports [ "Clash.Netlist.Types", "Clash.Netlist.BlackBox.Types", qualMod] - Hint.unsafeInterpret funcName typ + -> [InterpretFunctionRequest] + -- ^ Functions to interpret + -> IO InterpretResults +interpretFunctions _ _ _ [] = pure HashMap.empty +interpretFunctions idirs pkgDbs topDir reqs = do + sessionRes <- Hint.unsafeRunInterpreterWithArgsLibdir interpreterArgs topDir $ do + -- NB: capture the pristine search path once; 'Hint.get' returns the + -- current (possibly already extended) value in a shared session. + defaultPath <- Hint.get Hint.searchPath + Hint.set [Hint.searchPath Hint.:= (defaultPath ++ idirs)] - case bbfE of - Left globalException -> do - -- Try to interpret module as a local module, not yet present in the - -- global package database(s). - localRes <- Hint.unsafeRunInterpreterWithArgsLibdir interpreterArgs topDir $ do - Hint.reset - iPaths1 <- (iPaths0++) <$> Hint.get Hint.searchPath - Hint.set [ Hint.searchPath Hint.:= iPaths1 - , Hint.languageExtensions Hint.:= langExts] - Hint.loadModules [qualMod] - Hint.setImports [ "Clash.Netlist.BlackBox.Types", "Clash.Netlist.Types", qualMod] - Hint.unsafeInterpret funcName typ + -- Phase 1: try to interpret all functions from the package databases + globalResults <- forM reqs $ \req -> do + Hint.liftIO $ Monad.when debugIsOn $ + putStr "Hint: Interpreting " >> putStrLn (interpretFunctionRequestToModuleName req ++ "." ++ ifrFuncName req) + res <- tryInterp (interpretGlobal req) + pure (req, res) - case localRes of - Left localException -> pure (Left (globalException :| [localException])) - Right res -> pure (Right res) + -- Phase 2: functions that failed phase 1 are interpreted as local + -- modules, compiled from inline source or the import directories + Monad.unless (null [() | (_, Left _) <- globalResults]) $ + Hint.set [Hint.languageExtensions Hint.:= hintLanguageExtensions] + forM globalResults $ \(req, globalRes) -> + case globalRes of + Right res -> pure (req, Right res) + Left globalException -> do + localRes <- tryInterp (interpretLocal defaultPath req) + case localRes of + Left localException -> + pure (req, Left (globalException :| [localException])) + Right res -> pure (req, Right res) - Right res -> do - return (Right res) + case sessionRes of + -- The session itself failed to initialize; attribute the error to every + -- request. + Left e -> pure (HashMap.fromList [(req, Left (e :| [])) | req <- reqs]) + Right results -> pure (HashMap.fromList results) where - langExts = map Hint.asExtension $ - map show wantedLanguageExtensions ++ - map ("No" ++ ) (map show unwantedLanguageExtensions) + interpreterArgs = concatMap (("-package-db":) . (:[])) pkgDbs + tryInterp + :: Hint.InterpreterT IO InterpretFunctionResult + -> Hint.InterpreterT IO (Either Hint.InterpreterError InterpretFunctionResult) + tryInterp = try + + interpret req = case ifrType req of + InterpretBlackBoxFunction -> + InterpretBBF <$> Hint.unsafeInterpret (ifrFuncName req) "BlackBoxFunction" + InterpretTemplateFunction -> + InterpretTF <$> Hint.unsafeInterpret (ifrFuncName req) "TemplateFunction" + + interpretGlobal req = do + Hint.setImports + ["Clash.Netlist.Types", "Clash.Netlist.BlackBox.Types", interpretFunctionRequestToModuleName req] + interpret req + + interpretLocal defaultPath req = withSourceDir $ \extraDirs -> do + Hint.set [Hint.searchPath Hint.:= (extraDirs ++ idirs ++ defaultPath)] + Hint.loadModules [interpretFunctionRequestToModuleName req] + Hint.setImports + ["Clash.Netlist.BlackBox.Types", "Clash.Netlist.Types", interpretFunctionRequestToModuleName req] + interpret req + where + -- Write the inline source (if any) of a request to a temporary + -- directory, and pass that directory as an extra search path + withSourceDir act = case ifrSource req of + Nothing -> act [] + Just source -> do + tmpDir0 <- Hint.liftIO getCanonicalTemporaryDirectory + withTempDirectory tmpDir0 "clash-prim-compile" $ \tmpDir1 -> do + let modDir = foldl () tmpDir1 (init (ifrModNames req)) + Hint.liftIO $ do + Directory.createDirectoryIfMissing True modDir + Text.writeFile (modDir last (ifrModNames req) <.> "hs") source + act [tmpDir1] + -- | List of known BlackBoxFunctions used to prevent Hint from firing. This -- improves Clash startup times. knownBlackBoxFunctions :: HashMap String BlackBoxFunction @@ -616,7 +727,33 @@ , ('P.clockWizardDifferentialTclTF, P.clockWizardDifferentialTclTF) ] --- | Compiles blackbox functions and parses blackbox templates. +-- | Compiles the blackbox functions of and parses the blackbox templates in +-- a primitive map. All blackbox functions are interpreted in a single shared +-- Hint session (see 'interpretFunctions'), and every distinct function is +-- interpreted exactly once, no matter how many primitives reference it. +compilePrimitives + :: [FilePath] + -- ^ Import directories (-i flag) + -> [FilePath] + -- ^ Package databases + -> FilePath + -- ^ The folder in which the GHC bootstrap libraries (base, containers, etc.) + -- can be found + -> ResolvedPrimMap + -- ^ Primitives to compile + -> IO CompiledPrimMap +compilePrimitives idirs pkgDbs topDir primMapR = do + let reqs = + List.nubOrd $ + concatMap + neededInterpRequests + (mapMaybe extractPrim (HashMap.elems primMapR)) + results <- interpretFunctions idirs pkgDbs topDir reqs + traverse (traverse (compilePrimitiveWith (lookupInterpResult results))) primMapR + +-- | Compiles a single primitive. Provided for backwards compatibility; when +-- compiling multiple primitives, 'compilePrimitives' only pays the cost of +-- starting a Hint session once. compilePrimitive :: [FilePath] -- ^ Import directories (-i flag) @@ -628,18 +765,41 @@ -> ResolvedPrimitive -- ^ Primitive to compile -> IO CompiledPrimitive -compilePrimitive idirs pkgDbs topDir (BlackBoxHaskell bbName wf usedArgs multiRes bbGenName source) = do +compilePrimitive idirs pkgDbs topDir prim = do + let reqs = HashSet.toList (HashSet.fromList (neededInterpRequests prim)) + results <- interpretFunctions idirs pkgDbs topDir reqs + compilePrimitiveWith (lookupInterpResult results) prim + +-- | Look up the interpreter result of a request. All requests are +-- interpreted before primitives are compiled, so a missing result is an +-- internal error: 'neededInterpRequests' diverged from the requests +-- 'compilePrimitiveWith' consumes. +lookupInterpResult + :: InterpretResults + -> InterpretFunctionRequest + -> IO (Either (NonEmpty Hint.InterpreterError) InterpretFunctionResult) +lookupInterpResult results req = + case HashMap.lookup req results of + Just res -> pure res + Nothing -> error ($(curLoc) ++ "Internal error: no interpreter result for " + ++ show req) + +-- | Compiles the blackbox functions of and parses the blackbox templates in +-- a primitive, given an action that produces the interpreted functions the +-- primitive needs (see 'neededInterpRequests'). +compilePrimitiveWith + :: (InterpretFunctionRequest -> IO (Either (NonEmpty Hint.InterpreterError) InterpretFunctionResult)) + -- ^ Look up the interpreter result for a request + -> ResolvedPrimitive + -- ^ Primitive to compile + -> IO CompiledPrimitive +compilePrimitiveWith lookupInterp (BlackBoxHaskell bbName wf usedArgs multiRes bbGenName source) = do bbFunc <- - -- TODO: Use cache for hint targets. Right now Hint will fire multiple times - -- TODO: if multiple functions use the same blackbox haskell function. case HashMap.lookup fullName knownBlackBoxFunctions of Just f -> pure f Nothing -> do - Monad.when debugIsOn (putStr "Hint: interpreting " >> putStrLn (show fullName)) - let interpreterArgs = concatMap (("-package-db":) . (:[])) pkgDbs - -- Compile a blackbox template function or fetch it from an already compiled file. - r <- go interpreterArgs source - processHintErrors (show bbGenName) bbName r + r <- lookupInterp (InterpretFunctionRequest modNames funcName InterpretBlackBoxFunction source) + expectBBF =<< processHintErrors (show bbGenName) bbName r pure (BlackBoxHaskell bbName wf usedArgs multiRes bbGenName (hash source, bbFunc)) where @@ -647,34 +807,12 @@ qualMod = intercalate "." modNames BlackBoxFunctionName modNames funcName = bbGenName - -- | Create directory based on base name and directory. Return path - -- of directory just created. - createDirectory' - :: FilePath - -> FilePath - -> IO FilePath - createDirectory' base sub = - let new = base sub in - Directory.createDirectory new >> return new - - go - :: [String] - -> Maybe Text - -> IO (Either (NonEmpty Hint.InterpreterError) BlackBoxFunction) - go args (Just source') = do - -- Create a temporary directory with user module in it, add it to the - -- list of import direcotries, and run as if it were a "normal" compiled - -- module. - tmpDir0 <- getCanonicalTemporaryDirectory - withTempDirectory tmpDir0 "clash-prim-compile" $ \tmpDir1 -> do - modDir <- foldM createDirectory' tmpDir1 (init modNames) - Text.writeFile (modDir (last modNames ++ ".hs")) source' - loadImportAndInterpret (tmpDir1:idirs) args topDir qualMod funcName "BlackBoxFunction" - - go args Nothing = do - loadImportAndInterpret idirs args topDir qualMod funcName "BlackBoxFunction" + expectBBF :: InterpretFunctionResult -> IO BlackBoxFunction + expectBBF (InterpretBBF f) = pure f + expectBBF _ = error ($(curLoc) ++ "Internal error: expected a BlackBoxFunction for " + ++ fullName) -compilePrimitive idirs pkgDbs topDir +compilePrimitiveWith lookupInterp (BlackBox pNm wf rVoid multiRes tkind () outputUsage libM imps fPlural incs rM riM templ) = do libM' <- mapM parseTempl libM imps' <- mapM parseTempl imps @@ -684,8 +822,6 @@ riM' <- traverse parseBB riM return (BlackBox pNm wf rVoid multiRes tkind () outputUsage libM' imps' fPlural incs' rM' riM' templ') where - iArgs = concatMap (("-package-db":) . (:[])) pkgDbs - parseTempl :: Applicative m => Text @@ -697,24 +833,27 @@ Success t' -> pure t' + interpretTF :: InterpretFunctionRequest -> IO TemplateFunction + interpretTF req = do + r <- lookupInterp req + res <- processHintErrors (show (BlackBoxFunctionName (ifrModNames req) (ifrFuncName req))) pNm r + case res of + InterpretTF f -> pure f + _ -> error ($(curLoc) ++ "Internal error: expected a TemplateFunction for " + ++ interpretFunctionRequestToModuleName req ++ "." ++ ifrFuncName req) + parseBB :: ((TemplateFormat,BlackBoxFunctionName), Maybe Text) -> IO BlackBox parseBB ((TTemplate,_),Just t) = BBTemplate <$> parseTempl t parseBB ((TTemplate,_),Nothing) = error ("No template specified for blackbox: " ++ show pNm) - parseBB ((THaskell,bbGenName),Just source) = do + parseBB ((THaskell,bbGenName),source@(Just source')) = do let BlackBoxFunctionName modNames funcName = bbGenName qualMod = intercalate "." modNames - tmpDir <- getCanonicalTemporaryDirectory - r <- withTempDirectory tmpDir "clash-prim-compile" $ \tmpDir' -> do - let modDir = foldl () tmpDir' (init modNames) - Directory.createDirectoryIfMissing True modDir - Text.writeFile (modDir last modNames <.> "hs") source - loadImportAndInterpret (tmpDir':idirs) iArgs topDir qualMod funcName "TemplateFunction" - let hsh = hash (qualMod, source) + hsh = hash (qualMod, source') BBFunction (Data.Text.unpack pNm) hsh <$> - processHintErrors (show bbGenName) pNm r + interpretTF (InterpretFunctionRequest modNames funcName InterpretTemplateFunction source) parseBB ((THaskell,bbGenName),Nothing) = do let BlackBoxFunctionName modNames funcName = bbGenName qualMod = intercalate "." modNames @@ -723,14 +862,13 @@ tf <- case HashMap.lookup fullName knownTemplateFunctions of Just f -> pure f - Nothing -> do - r <- loadImportAndInterpret idirs iArgs topDir qualMod funcName "TemplateFunction" - processHintErrors (show bbGenName) pNm r + Nothing -> + interpretTF (InterpretFunctionRequest modNames funcName InterpretTemplateFunction Nothing) pure (BBFunction (Data.Text.unpack pNm) hsh tf) -compilePrimitive _ _ _ (Primitive pNm wf typ) = +compilePrimitiveWith _ (Primitive pNm wf typ) = return (Primitive pNm wf typ) -{-# SCC compilePrimitive #-} +{-# SCC compilePrimitiveWith #-} newtype HintError = HintError String deriving (Exception) diff --git a/src/Clash/Netlist/BlackBox/Parser.hs b/src/Clash/Netlist/BlackBox/Parser.hs --- a/src/Clash/Netlist/BlackBox/Parser.hs +++ b/src/Clash/Netlist/BlackBox/Parser.hs @@ -1,7 +1,7 @@ {-| Copyright : (C) 2012-2016, University of Twente, 2017 , Myrtle Software Ltd, - 2021-2022, QBayLogic B.V. + 2021-2026, QBayLogic B.V. 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -79,7 +79,6 @@ <|> Lit <$> (string "~LIT" *> brackets' natural') <|> Name <$> (string "~NAME" *> brackets' natural') <|> ToVar <$> try (string "~VAR" *> brackets' pSigDorEmpty) <*> brackets' natural' - <|> (Sym Text.empty) <$> (string "~SYM" *> brackets' natural') <|> Typ Nothing <$ string "~TYPO" <|> (Typ . Just) <$> try (string "~TYP" *> brackets' natural') <|> TypM Nothing <$ string "~TYPMO" @@ -117,6 +116,7 @@ <|> OutputUsage <$> (string "~OUTPUTWIREREG" *> brackets' natural') <|> OutputUsage <$> (string "~OUTPUTUSAGE" *> brackets' natural') <|> GenSym <$> (string "~GENSYM" *> brackets' pSigD) <*> brackets' natural' + <|> (Sym Text.empty) <$> (string "~SYM" *> brackets' (Left <$> natural' <|> Right <$> pSigD)) <|> Template <$> (string "~TEMPLATE" *> brackets' pSigD) <*> brackets' pSigD <|> Repeat <$> (string "~REPEAT" *> brackets' pSigD) <*> brackets' pSigD <|> DevNull <$> (string "~DEVNULL" *> brackets' pSigD) @@ -154,6 +154,7 @@ <|> (EscapedSymbol SquareBracketClose <$ string "\\]") <|> (Text <$> (pack <$> some (satisfyRange '\000' '\90'))) <|> (Text <$> (pack <$> some (satisfyRange '\94' '\125')))) + -- excludes '[', '\\', ']', `~` pSigDorEmpty :: Parser [Element] pSigDorEmpty = pSigD <|> mempty diff --git a/src/Clash/Netlist/BlackBox/Types.hs b/src/Clash/Netlist/BlackBox/Types.hs --- a/src/Clash/Netlist/BlackBox/Types.hs +++ b/src/Clash/Netlist/BlackBox/Types.hs @@ -1,7 +1,7 @@ {-| Copyright : (C) 2012-2016, University of Twente, 2017 , Myrtle Software Ltd, - 2021-2022, QBayLogic B.V. + 2021-2026, QBayLogic B.V. 2022 , LUMI GUIDE FIETSDETECTIE B.V. 2022 , Google Inc. License : BSD2 (see the file LICENSE) @@ -96,15 +96,15 @@ -- | Elements of a blackbox context. If you extend this list, make sure to -- update the following functions: -- --- - Clash.Netlist.BlackBox.Types.prettyElem --- - Clash.Netlist.BlackBox.Types.renderElem --- - Clash.Netlist.BlackBox.Types.renderTag --- - Clash.Netlist.BlackBox.Types.setSym +-- - Clash.Netlist.BlackBox.Util.prettyElem +-- - Clash.Netlist.BlackBox.Util.renderElem +-- - Clash.Netlist.BlackBox.Util.renderTag +-- - Clash.Netlist.BlackBox.Util.setSym -- - Clash.Netlist.BlackBox.Util.inputHole --- - Clash.Netlist.BlackBox.Types.getUsedArguments --- - Clash.Netlist.BlackBox.Types.usedVariables --- - Clash.Netlist.BlackBox.Types.verifyBlackBoxContext --- - Clash.Netlist.BlackBox.Types.walkElement +-- - Clash.Netlist.BlackBox.Util.getUsedArguments +-- - Clash.Netlist.BlackBox.Util.usedVariables +-- - Clash.Netlist.BlackBox.Util.verifyBlackBoxContext +-- - Clash.Netlist.BlackBox.Util.walkElement data Element = Text !Text -- ^ Dumps given text without processing in HDL @@ -126,8 +126,6 @@ | ToVar [Element] !Int -- ^ Like Arg but only insert variable reference (creating an assignment -- elsewhere if necessary). - | Sym !Text !Int - -- ^ Symbol hole | Typ !(Maybe Int) -- ^ Type declaration hole | TypM !(Maybe Int) @@ -204,6 +202,9 @@ | OutputUsage !Int | Vars !Int | GenSym [Element] !Int + -- ^ Define a name for a numbered symbol, and render that name too + | Sym !Text !(Either Int [Element]) + -- ^ Symbol hole (indexed by either a number or a name) | Repeat [Element] [Element] -- ^ Repeat n times | DevNull [Element] diff --git a/src/Clash/Netlist/BlackBox/Util.hs b/src/Clash/Netlist/BlackBox/Util.hs --- a/src/Clash/Netlist/BlackBox/Util.hs +++ b/src/Clash/Netlist/BlackBox/Util.hs @@ -40,8 +40,9 @@ import Control.Exception (throw) import Control.Lens - (use, (%=), _1, _2, element, (^?)) + (use, (%=), _1, _2, _3, element, (^?)) import Control.Monad (forM, (<=<), filterM) +import Control.Monad.Identity (runIdentity) import Control.Monad.Extra (ifM) import Control.Monad.State (State, StateT (..), lift, gets) import Data.Bitraversable (bitraverse) @@ -259,15 +260,16 @@ -> BlackBoxTemplate -> m (BlackBoxTemplate,[N.Declaration]) setSym bbCtx l = do - (a,(_,decls)) <- runStateT (mapM setSym' l) (IntMap.empty,IntMap.empty) + (a,(_,_,decls)) <- runStateT (mapM setSym' l) (IntMap.empty,HashMap.empty,IntMap.empty) return (a,concatMap snd (IntMap.elems decls)) where bbnm = Data.Text.unpack (bbName bbCtx) setSym' :: Element - -> StateT ( IntMap.IntMap N.IdentifierText - , IntMap.IntMap (N.IdentifierText, [N.Declaration])) + -> StateT ( IntMap.IntMap N.IdentifierText -- ~SYM[number] mapping + , HashMap.HashMap Text (Maybe N.IdentifierText) -- ~SYM[string] mapping, Nothing when a name is used by GENSYM + , IntMap.IntMap (N.IdentifierText, [N.Declaration])) -- ~VAR[nm][n] mapping m Element setSym' e = case e of @@ -276,7 +278,7 @@ return (ToVar [Text (Id.toLazyText nm0)] i) (e',hwTy,_) -> do - varM <- IntMap.lookup i <$> use _2 + varM <- IntMap.lookup i <$> use _3 case varM of Nothing -> do nm' <- lift (Id.make (Text.toStrict (concatT (Text "c$":nm)))) @@ -285,29 +287,49 @@ _ -> [N.NetDecl Nothing nm' hwTy ,N.Assignment nm' N.Cont e' -- TODO De-hardcode Cont ] - _2 %= (IntMap.insert i (Id.toText nm',decls)) + _3 %= (IntMap.insert i (Id.toText nm',decls)) return (ToVar [Text (Id.toLazyText nm')] i) Just (nm',_) -> return (ToVar [Text (Text.fromStrict nm')] i) - Sym _ i -> do + Sym _ x@(Left i) -> do symM <- IntMap.lookup i <$> use _1 case symM of Nothing -> do t <- Id.toText <$> lift (Id.make "c$n") _1 %= (IntMap.insert i t) - return (Sym (Text.fromStrict t) i) - Just t -> return (Sym (Text.fromStrict t) i) - GenSym t i -> do - symM <- IntMap.lookup i <$> use _1 + return (Sym (Text.fromStrict t) x) + Just t -> return (Sym (Text.fromStrict t) x) + Sym _ x@(Right (concatT -> nm)) -> do + symM <- HashMap.lookup nm <$> use _2 case symM of Nothing -> do - t' <- Id.toText <$> lift (Id.makeBasic (Text.toStrict (concatT t))) - _1 %= (IntMap.insert i t') - return (GenSym [Text (Text.fromStrict t')] i) - Just _ -> - error ("Symbol #" ++ show (t,i) - ++ " is already defined in BlackBox for: " - ++ bbnm) + t <- Id.toText <$> lift (Id.make $ Text.toStrict nm) + _2 %= (HashMap.insert nm (Just t)) + return (Sym (Text.fromStrict t) x) + Just (Just t) -> return (Sym (Text.fromStrict t) x) + Just Nothing -> + error ("In BlackBox " ++ bbnm ++ ": " + ++ " ~SYM[" ++ Text.unpack nm ++ "] uses the same name as previously used in ~GENSYM.\n" + ++ "You can't mix numbered and named symbols.") + GenSym t@(concatT -> nm) i -> do + symNmM <- HashMap.lookup nm <$> use _2 + case symNmM of + Just (Just _) -> + error ("In BlackBox " ++ bbnm ++ ": " + ++ "the name of ~GENSYM[" ++ prettyBlackBoxStr t ++ "][" ++ show i ++ "]" + ++ " would overwrite an earlier ~SYM[" ++ Text.unpack nm ++ "].\n" + ++ "You can't mix numbered and named symbols.") + _ -> do + symM <- IntMap.lookup i <$> use _1 + case symM of + Nothing -> do + t' <- Id.toText <$> lift (Id.makeBasic (Text.toStrict nm)) + _1 %= (IntMap.insert i t') + _2 %= (HashMap.insert nm Nothing) -- mark name as taken by GENSYM + return (GenSym [Text (Text.fromStrict t')] i) + Just _ -> + error ("In BlackBox " ++ bbnm ++ ": ~GENSYM[" ++ show t ++ "][" ++ show i ++ "]" + ++ " is redefining symbol #" ++ show i ++ ".\n") Component (Decl n subN l') -> Component <$> (Decl n subN <$> mapM (bitraverse (mapM setSym') (mapM setSym')) l') IF c t f -> IF <$> pure c <*> mapM setSym' t <*> mapM setSym' f @@ -341,8 +363,8 @@ _ | [(Identifier t _, _)] <- bbResults bbCtx -> Id.toLazyText t _ -> error $ $(curLoc) ++ "Internal error when processing blackbox " ++ "for " ++ bbnm - _ -> error $ $(curLoc) ++ "Unexpected element in GENSYM when processing " - ++ "blackbox for " ++ bbnm + e -> error $ $(curLoc) ++ "Unexpected element in (GEN)SYM symbol name when processing " + ++ "blackbox for " ++ bbnm ++ ": " ++ prettyBlackBoxStr [e] ) type FileName = FilePath @@ -1083,6 +1105,9 @@ -> Ap m Text prettyBlackBox bbT = Text.concat <$> mapM prettyElem bbT +prettyBlackBoxStr :: BlackBoxTemplate -> String +prettyBlackBoxStr = Text.unpack . runIdentity . getAp . prettyBlackBox + prettyElem :: (HasCallStack, Monad m) => Element @@ -1108,7 +1133,6 @@ prettyElem (ToVar es i) = do es' <- prettyBlackBox es renderOneLine <$> (string "~VAR" <> brackets (string es') <> brackets (int i)) -prettyElem (Sym _ i) = renderOneLine <$> (string "~SYM" <> brackets (int i)) prettyElem (Typ Nothing) = return "~TYPO" prettyElem (Typ (Just i)) = renderOneLine <$> (string "~TYP" <> brackets (int i)) prettyElem (TypM Nothing) = return "~TYPMO" @@ -1192,6 +1216,10 @@ prettyElem (GenSym es i) = do es' <- prettyBlackBox es renderOneLine <$> (string "~GENSYM" <> brackets (string es') <> brackets (int i)) +prettyElem (Sym _ (Left i)) = renderOneLine <$> (string "~SYM" <> brackets (int i)) +prettyElem (Sym _ (Right es)) = do + es' <- prettyBlackBox es + renderOneLine <$> (string "~SYM" <> brackets (string es')) prettyElem (Repeat [es] [i]) = do es' <- prettyElem es i' <- prettyElem i @@ -1255,6 +1283,8 @@ SigD es _ -> concatMap go es BV _ es _ -> concatMap go es GenSym es _ -> concatMap go es + Sym _ (Left _) -> [] + Sym _ (Right es) -> concatMap go es DevNull es -> concatMap go es Text _ -> [] Result -> [] @@ -1264,7 +1294,6 @@ Lit _ -> [] Name _ -> [] ToVar es _ -> concatMap go es - Sym _ _ -> [] Typ _ -> [] TypM _ -> [] Err _ -> [] diff --git a/src/Clash/Netlist/Util.hs b/src/Clash/Netlist/Util.hs --- a/src/Clash/Netlist/Util.hs +++ b/src/Clash/Netlist/Util.hs @@ -653,8 +653,22 @@ -> Type -> Bool representableType builtInTranslation reprs stringRepresentable m = - either (const False) isRepresentable . flip evalState mempty . + representableTypeState builtInTranslation reprs stringRepresentable m + +-- | Like 'representableType', but memoizes the Core-type to HWType +-- translation in the given state. +representableTypeState + :: (CustomReprs -> TyConMap -> Type -> + State HWMap (Maybe (Either String FilteredHWType))) + -> CustomReprs + -> Bool + -- ^ String considered representable + -> TyConMap + -> Type + -> State HWMap Bool +representableTypeState builtInTranslation reprs stringRepresentable m = + fmap (either (const False) isRepresentable) . coreTypeToHWType' builtInTranslation reprs m where isRepresentable hty = case hty of diff --git a/src/Clash/Normalize.hs b/src/Clash/Normalize.hs --- a/src/Clash/Normalize.hs +++ b/src/Clash/Normalize.hs @@ -126,13 +126,15 @@ rwState = RewriteState 0 - mempty -- transformCounters Map + mempty -- transformAppliedCounters Map + mempty -- transformTriedCounters Map globals supply (error $ $(curLoc) ++ "Report as bug: no curFun",noSrcSpan) 0 (IntMap.empty, 0) emptyVarEnv + Map.empty -- hwTypeCache normState normState = NormalizeState @@ -346,6 +348,37 @@ then return (Right ((nm,e),us)) else return (Left b) +{- +Note [flatten pass structure] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Through experimentation we've learned the following: + +1. The evaluator-backed rewrites ('reduceConst', 'reduceNonRepPrim') must not + sit inside the top-down propagation bundle. 'topdownFixR' settles that bundle + at each node with 'repeatR', so a bundled 'reduceConst' is re-attempted - + evaluator call and all - for every 'appProp' or 'caseCon' that fires there. + On large designs we've measured that dominates; hoisting them out was worth + ~30%. See #3338. + +2. There should be exactly two traversals per round, and the bottom-up one has + to come first. + + 'allR' rebuilds every node it walks, so each extra traversal costs a full + term rebuild per round even when nothing fires. Running 'flattenLet' and the + evaluator-backed rewrites as one fused bottom-up pass instead of two + consecutive ones is therefore free of charge (it does not change which + rewrites fire, or in which order they fire relative to each other). + + Running that bottom-up pass _before_ the top-down one lets the constants it + folds be consumed by 'caseCon' in the same round. With the passes the other + way round the folded constants sit unused until the next round, so + constant-heavy designs pay for an extra iteration of the whole loop: + @tests/shouldwork/Basic/AES.hs@ did ~36k extra node visits per transformation + that way. + +If you touch code related to this, please make sure to run benchmarks. +-} + -- | Flatten a 'CallTree', memoizing results by binder Id within one cleanup -- pass. Without the cache, every binder reachable from the root is flattened -- as many times as it appears in the (un-deduplicated) call tree. @@ -406,16 +439,15 @@ else return (CBranch (nm,(Binding nm' sp inl pr newExpr r)) allUsed) flatten = - -- topdownFixR reaches a fixpoint for the top-down propagation bundle. - -- Keep flattenLet in the outer fixed-point loop: flattening can expose - -- fresh propagation redexes for the next top-down pass. - repeatR (topdownFixR (apply "appProp" appProp >-> + -- See Note [flatten pass structure]. + repeatR (bottomupR (apply "flattenLet" flattenLet >-> + (apply "reduceConst" reduceConst !-> + apply "deadcode" deadCode) >-> + apply "reduceNonRepPrim" reduceNonRepPrim >-> + apply "removeUnusedExpr" removeUnusedExpr) >-> + topdownFixR (apply "appProp" appProp >-> apply "bindConstantVar" bindConstantVar >-> - apply "caseCon" caseCon >-> - (apply "reduceConst" reduceConst !-> apply "deadcode" deadCode) >-> - apply "reduceNonRepPrim" reduceNonRepPrim >-> - apply "removeUnusedExpr" removeUnusedExpr) >-> - bottomupR (apply "flattenLet" flattenLet)) !-> + apply "caseCon" caseCon)) !-> topdownSucR (apply "topLet" topLet) >-> -- See [Note] relation `collapseRHSNoops` and `inlineCleanup` -- Note that we do this as the very last step, after all constant propagation diff --git a/src/Clash/Normalize/Strategy.hs b/src/Clash/Normalize/Strategy.hs --- a/src/Clash/Normalize/Strategy.hs +++ b/src/Clash/Normalize/Strategy.hs @@ -77,7 +77,10 @@ -- The outer repeatR is still needed: inlineNR is a full traversal whose -- results can only be processed by re-running the top-down bundle from the -- new root. - inlineAndPropagate = repeatR (topdownFixR (applyMany transPropagateAndInline) >-> inlineNR) + -- + -- NB: 'topdownFixR' is deliberately _not_ used here, see + -- Note [topdownFixR is not for inlining bundles]. + inlineAndPropagate = repeatR (topdownR (applyMany transPropagateAndInline) >-> inlineNR) spec = bottomupR (applyMany specTransformations) caseFlattening = topdownFixR (apply "caseFlat" caseFlat) dec = topdownFixR (apply "DEC" disjointExpressionConsolidation) diff --git a/src/Clash/Normalize/Transformations/Case.hs b/src/Clash/Normalize/Transformations/Case.hs --- a/src/Clash/Normalize/Transformations/Case.hs +++ b/src/Clash/Normalize/Transformations/Case.hs @@ -2,7 +2,7 @@ Copyright : (C) 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd, 2017-2022, Google Inc., - 2021-2024, QBayLogic B.V. + 2021-2026, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Transformations on case-expressions @@ -30,7 +30,7 @@ import Control.Exception.Base (patError) import GHC.Prim.Panic (absentError) import qualified Control.Lens as Lens -import Control.Monad.State.Strict (evalState) + import Data.Bifunctor (second) import Data.Coerce (coerce) import qualified Data.Either as Either @@ -69,14 +69,15 @@ import Clash.Debug (traceIf) import Clash.Driver.Types (DebugOpts(dbg_invariants)) import Clash.Netlist.Types (FilteredHWType(..), HWType(..)) -import Clash.Netlist.Util (coreTypeToHWType, representableType) +import Clash.Netlist.Util (coreTypeToHWType) import qualified Clash.Normalize.Primitives as NP (undefined, undefinedX) import Clash.Normalize.Types (NormRewrite, NormalizeSession) import Clash.Rewrite.Combinators ((>-!)) import Clash.Rewrite.Types ( TransformContext(..), bindings, customReprs, debugOpts, tcCache , typeTranslator, workFreeBinders) -import Clash.Rewrite.Util (changed, isFromInt, whnfRW) +import Clash.Rewrite.Util + (changed, isFromInt, isUntranslatableType, runWithHWTypeCache, whnfRW) import Clash.Rewrite.WorkFree import Clash.Util (curLoc) @@ -86,12 +87,7 @@ -- alternatives caseCase :: HasCallStack => NormRewrite caseCase (TransformContext is0 _) e@(Case (stripTicks -> Case scrut alts1Ty alts1) alts2Ty alts2) = do - ty1Rep <- representableType - <$> Lens.view typeTranslator - <*> Lens.view customReprs - <*> pure False - <*> Lens.view tcCache - <*> pure alts1Ty + ty1Rep <- not <$> isUntranslatableType False alts1Ty -- This is only worth doing if the inner case-expression has a -- non-representable alternative type. @@ -308,7 +304,8 @@ let subjTy = inferCoreTypeOf tcm subj tran <- Lens.view typeTranslator reprs <- Lens.view customReprs - case (`evalState` mempty) (coreTypeToHWType tran reprs tcm subjTy) of + subjHwty <- runWithHWTypeCache (coreTypeToHWType tran reprs tcm subjTy) + case subjHwty of Right (FilteredHWType (Void (Just hty)) _areVoids) | hty `elem` [BitVector 0, Unsigned 0, Signed 0, Index 1] -- If we know that the type of the subject is zero-bits wide and diff --git a/src/Clash/Normalize/Transformations/DEC.hs b/src/Clash/Normalize/Transformations/DEC.hs --- a/src/Clash/Normalize/Transformations/DEC.hs +++ b/src/Clash/Normalize/Transformations/DEC.hs @@ -63,7 +63,8 @@ import GHC.Settings.Constants (mAX_TUPLE_SIZE) -- internal -import Clash.Core.DataCon (DataCon) +import Clash.Core.DataCon (DataCon, dcArgTys, dcExtTyVars) +import Clash.Core.EqSolver (typeEq) import Clash.Core.Evaluator.Types (whnf') import Clash.Core.FreeVars (termFreeVars', typeFreeVars', localVarsDoNotOccurIn) @@ -76,13 +77,15 @@ , collectArgs, collectArgsTicks, mkApps, mkTicks, patIds, stripTicks) import Clash.Core.TyCon (TyConMap, TyConName, tyConDataCons) import Clash.Core.Type - (Type, TypeView (..), isPolyFunTy, mkTyConApp, splitFunForallTy, tyView) + ( Type, TypeView (..), coreView, isPolyFunTy, mkTyConApp, splitFunForallTy + , tyView) import Clash.Core.Util (mkInternalVar, mkSelectorCase, sccLetBindings) import Clash.Core.Var (Id, isGlobalId, isLocalId, varName) import Clash.Core.VarEnv ( InScopeSet, elemInScopeSet, extendInScopeSet, extendInScopeSetList , notElemInScopeSet, unionInScope) import qualified Clash.Data.UniqMap as UniqMap +import qualified Clash.Normalize.Primitives as NP import Clash.Normalize.Transformations.Letrec (deadCode) import Clash.Normalize.Types (NormRewrite, NormalizeSession) import Clash.Rewrite.Combinators (bottomupR) @@ -610,10 +613,75 @@ (ptvs,pids) = patIds p in if (coerce ptvs ++ coerce pids) `localVarsDoNotOccurIn` ct' then ct' - else Case scrut ty [(p,ct')] + else Case scrut ty (addDefault scrut [(p,ct')]) go (Branch scrut pats) = - Case scrut ty (map (second go) pats) + Case scrut ty (addDefault scrut (map (second go) pats)) + + -- A 'CaseTree' only contains alternatives for the branches in which the + -- lifted function is applied, so the case-expressions generated from it + -- are not necessarily exhaustive (#2770). e.g. for + -- + -- @ + -- case x of + -- Left y -> f y + -- Right z -> case z of + -- Left a -> h a + -- Right w -> f w + -- @ + -- + -- the transformation will (naively) rewrite it to: + -- + -- @ + -- case x of + -- Left y -> f_shared + -- Right z -> case z of + -- Left a -> h a + -- Right w -> f_shared + -- where + -- f_shared = f f_arg + -- f_arg = case x of + -- Left y -> y + -- Right z -> case z of + -- Right w -> w + -- @ + -- + -- Note that the case on @z@ doesn't have a 'Left' branch. It doesn't need + -- to, because it only gets called in cases where it has already been proven + -- that z ~ Right. Still, this is malformed Core and the evaluator will + -- crash on it if it ever sees it. We therefore add a 'DefaultPat'. + -- + -- XXX: For GADT-like constructors (e.g. Vec) counting alternatives cannot + -- tell whether missing constructors can match. We therefore leave those + -- alone. Handle smarter in the future? + addDefault :: Term -> [(Pat,Term)] -> [(Pat,Term)] + addDefault scrut alts + | any (isDefaultPat . fst) alts + = alts + -- Literal patterns can never cover all values + | any (isLitPat . fst) alts + = defaultAlt : alts + | TyConApp tcNm _ <- tyView (coreView tcm (inferCoreTypeOf tcm scrut)) + , Just tc <- UniqMap.lookup tcNm tcm + , let dcs = tyConDataCons tc + , all isVanillaDc dcs + , length dcs > length alts + = -- In Core, default patterns always come first + defaultAlt : alts + | otherwise + = alts + + defaultAlt = (DefaultPat, TyApp (Prim NP.undefined) ty) + + isDefaultPat DefaultPat = True + isDefaultPat _ = False + + isLitPat LitPat{} = True + isLitPat _ = False + + isVanillaDc dc = + null (dcExtTyVars dc) && + all (Maybe.isNothing . typeEq tcm) (dcArgTys dc) -- | Lookup the TyConName and DataCon for a tuple of size n findTup :: TyConMap -> IntMap TyConName -> Int -> (TyConName,DataCon) diff --git a/src/Clash/Normalize/Transformations/Inline.hs b/src/Clash/Normalize/Transformations/Inline.hs --- a/src/Clash/Normalize/Transformations/Inline.hs +++ b/src/Clash/Normalize/Transformations/Inline.hs @@ -2,7 +2,7 @@ Copyright : (C) 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd, 2017-2022, Google Inc., - 2021-2024, QBayLogic B.V. + 2021-2026, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -35,6 +35,7 @@ import qualified Control.Lens as Lens import qualified Control.Monad as Monad import Control.Monad ((>=>)) +import Control.Monad.Extra (anyM) import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Writer (lift,listen) import Data.Default (Default(..)) @@ -63,8 +64,8 @@ import qualified Clash.Core.Term as Term import Clash.Core.Term ( CoreContext(..), Pat(..), PrimInfo(..), Term(..), WorkInfo(..), collectArgs - , collectArgsTicks, mkApps , mkTicks, stripTicks) -import Clash.Core.TermInfo (isLocalVar, termSize) + , collectArgsTicks, collectTicks, mkApps , mkTicks, stripTicks) +import Clash.Core.TermInfo (isLocalVar, termSizeSmallerThan) import Clash.Core.Type (TypeView(..), isClassTy, isPolyFunCoreTy, tyView) import Clash.Core.Util (isSignalType, primUCo) @@ -76,13 +77,12 @@ , notElemVarSet, unionVarEnv, unionVarEnvWith, unitVarSet) import Clash.Debug (trace) import Clash.Driver.Types (Binding(..)) -import Clash.Netlist.Util (representableType) import Clash.Primitives.Types (CompiledPrimMap, Primitive(..), TemplateKind(..)) import Clash.Rewrite.Combinators (allR) import Clash.Rewrite.Types - ( TransformContext(..), bindings, curFun, customReprs, tcCache, topEntities - , typeTranslator, inlineConstantLimit, inlineFunctionLimit, inlineLimit + ( TransformContext(..), bindings, curFun, tcCache, topEntities + , inlineConstantLimit, inlineFunctionLimit, inlineLimit , inlineWFCacheLimit, primitives) import Clash.Rewrite.Util ( changed, inlineBinders, inlineOrLiftBinders, isJoinPointIn @@ -120,19 +120,20 @@ -- Don't inline `let x = x in x`, it throws us in an infinite loop True -> return (i `notElemFreeVars` e) _ -> do - tcm <- Lens.view tcCache (fn,_) <- Lens.use curFun - -- Don't inline things that perform work, it increases the circuit size. - -- - -- Also don't inline globally recursive calls, it prevents the + -- Don't inline globally recursive calls, it prevents the -- recToLetRec transformation from transforming global recursion to -- local recursion. -- See https://github.com/clash-lang/clash-compiler/issues/2839 - case isWorkFreeIsh tcm e && not (e == Var fn) of - True -> Lens.view inlineConstantLimit >>= \case - 0 -> return True - n -> return (termSize e <= n) - _ -> return False + if e == Var fn then return False else do + tcm <- Lens.view tcCache + -- Don't inline things that perform work, it increases the circuit + -- size. + case isWorkFreeIsh tcm e of + True -> Lens.view inlineConstantLimit >>= \case + 0 -> return True + n -> return (termSizeSmallerThan (n + 1) e) + _ -> return False {-# SCC bindConstantVar #-} -- | Mark to track progress of 'reduceBindersCleanup' @@ -536,11 +537,7 @@ bodyMaybe <- lookupVarEnv f <$> Lens.use bindings - nonRepScrut <- not <$> (representableType <$> Lens.view typeTranslator - <*> Lens.view customReprs - <*> pure False - <*> Lens.view tcCache - <*> pure scrutTy) + nonRepScrut <- isUntranslatableType False scrutTy case (nonRepScrut, bodyMaybe) of (True, Just b) -> do if overLimit then @@ -576,12 +573,7 @@ bodyFreeOccs = countFreeOccurances body nonRepTest :: (Id, Term) -> NormalizeSession Bool - nonRepTest (Id {varType = ty}, _) - = not <$> (representableType <$> Lens.view typeTranslator - <*> Lens.view customReprs - <*> pure False - <*> Lens.view tcCache - <*> pure ty) + nonRepTest (Id {varType = ty}, _) = isUntranslatableType False ty nonRepTest _ = return False inlineTest :: Term -> (Id, Term) -> Bool @@ -611,102 +603,163 @@ _ -> return False {-# SCC inlineSimIO #-} +-- | True when @e@, appearing at context @cc@, is an inner (partial) position +-- of a Var-headed application spine. That is, for a fully applied function call: +-- +-- f a b c +-- +-- this function returns 'True' for: +-- +-- f +-- f a +-- f a b +-- +-- This is useful for functions such as 'inlineSmall' and 'inlineWorkFree'. The +-- former doesn't really care about arguments at all, but it is still useful to +-- only run once while traversing the tree. The latter will refuse to do any work +-- for partially applied functions in the first place -- but it only finds out +-- after performing relatively expensive checks. +-- +-- Note that this will also return 'True' in context of 'TickC's. That means that +-- transformations using this as a performance guard should be careful to use +-- 'collectTicks' before matching on a constructor. +isPartOfVarAppSpine :: CoreContext -> Term -> Bool +isPartOfVarAppSpine cc e = isSpineCtx cc && isSpineNode e + where + isSpineCtx AppFun = True + isSpineCtx TyAppC = True + isSpineCtx (TickC _) = True + isSpineCtx _ = False + + isSpineNode Var {} = True + isSpineNode App {} = True + isSpineNode TyApp {} = True + isSpineNode Tick {} = True + isSpineNode _ = False + -- | Inline small functions inlineSmall :: HasCallStack => NormRewrite -inlineSmall _ e@(collectArgsTicks -> (Var f,args,ticks)) = do - untranslatable <- isUntranslatable True e - topEnts <- Lens.view topEntities - let lv = isLocalId f - if untranslatable || f `elemVarSet` topEnts || lv - then return e - else do - bndrs <- Lens.use bindings - sizeLimit <- Lens.view inlineFunctionLimit - case lookupVarEnv f bndrs of - -- Don't inline recursive expressions - Just b -> do - isRecBndr <- isRecursiveBndr f - if not isRecBndr && not (isNoInline (bindingSpec b)) && termSize (bindingTerm b) < sizeLimit - then do - let tm = mkTicks (bindingTerm b) (mkInlineTick f : ticks) - changed $ mkApps tm args - else return e +inlineSmall (TransformContext _ (cc:_)) e + | isPartOfVarAppSpine cc e + = return e - _ -> return e +inlineSmall _ e@(collectArgsTicks -> (Var f,args,ticks)) + | isLocalId f = return e + | otherwise = do + -- XXX: This is deeply nested to short-circuit expensive checks + topEnts <- Lens.view topEntities + if f `elemVarSet` topEnts + then return e + else do + bndrs <- Lens.use bindings + sizeLimit <- Lens.view inlineFunctionLimit + case lookupVarEnv f bndrs of + Just b + | not (isNoInline (bindingSpec b)) + , termSizeSmallerThan sizeLimit (bindingTerm b) + -> do + -- Don't inline recursive expressions + isRecBndr <- isRecursiveBndr f + if isRecBndr + then return e + else do + untranslatable <- isUntranslatable True e + if untranslatable + then return e + else do + let tm = mkTicks (bindingTerm b) (mkInlineTick f : ticks) + changed $ mkApps tm args + _ -> return e + inlineSmall _ e = return e {-# SCC inlineSmall #-} -- | Inline work-free functions, i.e. fully applied functions that evaluate to -- a constant inlineWorkFree :: HasCallStack => NormRewrite +inlineWorkFree (TransformContext _ (cc:_)) e + | isPartOfVarAppSpine cc e + = return e + inlineWorkFree _ e@(collectArgsTicks -> (Var f,args@(_:_),ticks)) + | isLocalId f = return e + | otherwise = do - tcm <- Lens.view tcCache - let eTy = inferCoreTypeOf tcm e - argsHaveWork <- or <$> mapM (either expressionHasWork - (const (pure False))) - args - untranslatable <- isUntranslatableType True eTy + -- XXX: This is deeply nested to short-circuit expensive checks topEnts <- Lens.view topEntities - let isSignal = isSignalType tcm eTy - let lv = isLocalId f - let isTopEnt = elemVarSet f topEnts - if untranslatable || isSignal || argsHaveWork || lv || isTopEnt + if f `elemVarSet` topEnts then return e else do bndrs <- Lens.use bindings case lookupVarEnv f bndrs of - -- Don't inline recursive expressions Just b -> do - isRecBndr <- isRecursiveBndr f - if isRecBndr - then return e - else do - let tm = mkTicks (bindingTerm b) (mkInlineTick f : ticks) - changed $ mkApps tm args + tcm <- Lens.view tcCache + let eTy = inferCoreTypeOf tcm e + if isSignalType tcm eTy + then return e + else do + untranslatable <- isUntranslatableType True eTy + argsHaveWork <- anyM (either expressionHasWork + (const (pure False))) + args + if untranslatable || argsHaveWork + then return e + else do + -- Don't inline recursive expressions + isRecBndr <- isRecursiveBndr f + if isRecBndr + then return e + else do + let tm = mkTicks (bindingTerm b) (mkInlineTick f : ticks) + changed $ mkApps tm args _ -> return e where - -- an expression is has work when it contains free local variables, + -- an expression has work when it contains free local variables, -- or has a Signal type, i.e. it does not evaluate to a work-free - -- constant. - expressionHasWork e' = do - let fvIds = Lens.toListOf freeLocalIds e' - tcm <- Lens.view tcCache - let e'Ty = inferCoreTypeOf tcm e' - isSignal = isSignalType tcm e'Ty - return (not (null fvIds) || isSignal) + -- constant. The free-variable check runs first: it is cheaper than + -- inferring the expression's type. + expressionHasWork e' = + if not (isClosed e') + then return True + else do + tcm <- Lens.view tcCache + let e'Ty = inferCoreTypeOf tcm e' + return (isSignalType tcm e'Ty) -inlineWorkFree _ e@(Var f) = do - tcm <- Lens.view tcCache - let fTy = coreTypeOf f - closed = not (isPolyFunCoreTy tcm fTy) - isSignal = isSignalType tcm fTy - untranslatable <- isUntranslatableType True fTy - topEnts <- Lens.view topEntities - let gv = isGlobalId f - if closed && f `notElemVarSet` topEnts && not untranslatable && not isSignal && gv - then do - bndrs <- Lens.use bindings - case lookupVarEnv f bndrs of - -- Don't inline recursive expressions - Just top -> do - isRecBndr <- isRecursiveBndr f - if isRecBndr - then return e - else do - let topB = bindingTerm top - sizeLimit <- Lens.view inlineWFCacheLimit - -- caching only worth it from a certain size onwards, otherwise - -- the caching mechanism itself brings more of an overhead. - if termSize topB < sizeLimit then - changed topB - else do - b <- normalizeTopLvlBndr False f top - changed (bindingTerm b) - _ -> return e - else return e +inlineWorkFree _ e@(collectTicks -> (Var f, ticks)) + | isLocalId f = return e + | otherwise = do + topEnts <- Lens.view topEntities + tcm <- Lens.view tcCache + let fTy = coreTypeOf f + closed = not (isPolyFunCoreTy tcm fTy) + if f `elemVarSet` topEnts || not closed || isSignalType tcm fTy + then return e + else do + untranslatable <- isUntranslatableType True fTy + if untranslatable + then return e + else do + bndrs <- Lens.use bindings + case lookupVarEnv f bndrs of + -- Don't inline recursive expressions + Just top -> do + isRecBndr <- isRecursiveBndr f + if isRecBndr + then return e + else do + let topB = bindingTerm top + sizeLimit <- Lens.view inlineWFCacheLimit + -- caching only worth it from a certain size onwards, otherwise + -- the caching mechanism itself brings more of an overhead. + if termSizeSmallerThan sizeLimit topB then + changed (mkTicks topB ticks) + else do + b <- normalizeTopLvlBndr False f top + changed (mkTicks (bindingTerm b) ticks) + _ -> return e inlineWorkFree _ e = return e {-# SCC inlineWorkFree #-} diff --git a/src/Clash/Normalize/Transformations/Letrec.hs b/src/Clash/Normalize/Transformations/Letrec.hs --- a/src/Clash/Normalize/Transformations/Letrec.hs +++ b/src/Clash/Normalize/Transformations/Letrec.hs @@ -2,7 +2,7 @@ Copyright : (C) 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd, 2017-2018, Google Inc., - 2021-2022, QBayLogic B.V. + 2021-2026, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -50,7 +50,7 @@ import Clash.Core.Name (mkUnsafeSystemName, nameOcc) import Clash.Core.Subst import Clash.Core.Term - ( LetBinding, Pat(..), PrimInfo(..), Term(..), collectArgs, collectArgsTicks + ( CoreContext(..), LetBinding, Pat(..), PrimInfo(..), Term(..), collectArgs, collectArgsTicks , collectTicks, isLambdaBodyCtx, isTickCtx, mkApps, mkLams, mkTicks, Bind(..) , partitionTicks, stripAllTicks) import Clash.Core.TermInfo (isCon, isLet, isLocalVar, isTick) @@ -93,6 +93,40 @@ {-# SCC deadCode #-} removeUnusedExpr :: HasCallStack => NormRewrite +-- The primitive and data-constructor equations below collect the whole +-- application spine with 'collectArgsTicks'. Say we have an application: +-- +-- f a b c +-- +-- Then we're only interested in the root (@f a b c@), not in the inner nodes +-- (@f a@, @f a b@). At the root, 'collectArgsTicks' collects the full argument +-- list @[a, b, c]@; an inner node would only ever see a prefix of that (@[a]@, +-- @[a, b]@) at the same argument indices. So any argument an inner node could +-- remove, the root removes too, which makes the inner attempts wasted work. +-- This holds through ticks and type applications as well, since +-- 'collectArgsTicks' looks through both. +-- +-- We therefore skip a node that is itself a spine node (@App@, @TyApp@, @Prim@, +-- or @Tick@) sitting under a parent that continues the spine (@AppFun@, +-- @TyAppC@, or @TickC@). The single-alternative-Case equation is unaffected: +-- the spine only threads through applications, type applications, and ticks, so +-- a Case is never an inner node of a spine. +removeUnusedExpr (TransformContext _ (cc:_)) e + | isSpineCtx cc + , isSpineNode e + = return e + where + isSpineCtx AppFun = True + isSpineCtx TyAppC = True + isSpineCtx (TickC _) = True + isSpineCtx _ = False + + isSpineNode App {} = True + isSpineNode TyApp {} = True + isSpineNode Prim {} = True + isSpineNode Tick {} = True + isSpineNode _ = False + removeUnusedExpr _ e@(collectArgsTicks -> (p@(Prim pInfo),args,ticks)) = do bbM <- HashMap.lookup (primName pInfo) <$> Lens.view primitives let diff --git a/src/Clash/Normalize/Transformations/Reduce.hs b/src/Clash/Normalize/Transformations/Reduce.hs --- a/src/Clash/Normalize/Transformations/Reduce.hs +++ b/src/Clash/Normalize/Transformations/Reduce.hs @@ -2,7 +2,7 @@ Copyright : (C) 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd, 2017-2018, Google Inc., - 2021-2022, QBayLogic B.V. + 2021-2026, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -10,7 +10,10 @@ -} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} module Clash.Normalize.Transformations.Reduce ( reduceBinders @@ -21,10 +24,12 @@ import qualified Control.Lens as Lens import Control.Monad.Trans.Except (runExcept) import qualified Data.Either as Either -import qualified Data.List as List +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap import qualified Data.List.Extra as List import qualified Data.Maybe as Maybe import Data.Maybe (fromMaybe, listToMaybe) +import Data.Text (Text) import GHC.Stack (HasCallStack) import Clash.Core.FreeVars (typeFreeVars) @@ -33,10 +38,10 @@ import Clash.Core.Pretty (showPpr) import Clash.Core.Subst (Subst, extendIdSubst, substTm) import Clash.Core.Term - ( CoreContext(..), LetBinding, PrimInfo(..), Term(..), TickInfo(..), collectArgs - , collectArgsTicks, mkApps, mkTicks, mkTmApps) -import Clash.Core.TyCon (tyConDataCons) -import Clash.Core.Type (Type, TypeView(..), mkTyConApp, splitFunForallTy, tyView) + ( CoreContext(..), LetBinding, PrimInfo(..), Term(..), TickInfo(..) + , WorkInfo(..), collectArgs, collectArgsTicks, mkApps, mkTicks, mkTmApps) +import Clash.Core.TyCon (TyCon(..), TyConMap, tyConDataCons) +import Clash.Core.Type (Type, TypeView(..), mkTyConApp, splitFunForallTy, tyView, coreView) import Clash.Core.Util (mkVec, shouldSplit, tyNatSize, mkInternalVar) import Clash.Core.VarEnv (extendInScopeSet) import qualified Clash.Data.UniqMap as UniqMap @@ -46,6 +51,10 @@ import Clash.Normalize.Util (shouldReduce) import Clash.Rewrite.Types (TransformContext(..), tcCache, normalizeUltra) import Clash.Rewrite.Util (changed, isUntranslatableType, setChanged, whnfRW) +import qualified Clash.Sized.Internal.BitVector +import qualified Clash.Sized.RTree +import qualified Clash.Sized.Vector +import Clash.Util (textNameLit) -- | XXX: is given inverse topologically sorted binders, but returns -- topologically sorted binders @@ -77,6 +86,12 @@ {-# SCC reduceBinders #-} reduceConst :: HasCallStack => NormRewrite +-- An 'App' in an 'AppFun' context is an inner node of an application spine, +-- e.g. the @f a@ inside @f a b c@. Only evaluate at the root (@f a b c@): +-- an under-applied primitive cannot fold, and if @f@ is itself an application +-- (@(g x) a b c@) the evaluator reduces the whole thing to WHNF anyway, so it +-- folds @g x@ as part of folding the root. Skip the evaluator call here. +reduceConst (TransformContext _ (AppFun:_)) e = return e reduceConst ctx e@(App _ _) | (Prim p0, _) <- collectArgs e = whnfRW False ctx e $ \_ctx1 e1 -> case e1 of @@ -106,29 +121,7 @@ -- > (y1 :: Int = case yr0 of (:>) _ y yr -> y -- > in (($) x0 y0 :> ($) x1 y1 :> Nil) -- --- Currently, it only handles the following functions: --- --- * Clash.Sized.Vector.zipWith --- * Clash.Sized.Vector.map --- * Clash.Sized.Vector.traverse# --- * Clash.Sized.Vector.fold --- * Clash.Sized.Vector.foldr --- * Clash.Sized.Vector.dfold --- * Clash.Sized.Vector.(++) --- * Clash.Sized.Vector.head --- * Clash.Sized.Vector.tail --- * Clash.Sized.Vector.last --- * Clash.Sized.Vector.init --- * Clash.Sized.Vector.unconcat --- * Clash.Sized.Vector.transpose --- * Clash.Sized.Vector.replicate --- * Clash.Sized.Vector.replace_int --- * Clash.Sized.Vector.imap --- * Clash.Sized.Vector.dtfold --- * Clash.Sized.RTree.tdfold --- * Clash.Sized.RTree.treplicate --- * Clash.Sized.Internal.BitVector.split# --- * Clash.Sized.Internal.BitVector.eq# +-- Currently, it only handles the functions in 'reduceNonRepPrimImpls'. -- -- Note [Unroll shouldSplit types] -- 1. Certain higher-order functions over Vec, such as map, have specialized @@ -150,349 +143,572 @@ -- -- See https://github.com/clash-lang/clash-compiler/issues/1606 reduceNonRepPrim :: HasCallStack => NormRewrite -reduceNonRepPrim c@(TransformContext _ ctx) e@(App _ _) | (Prim p, args, ticks) <- collectArgsTicks e = do - tcm <- Lens.view tcCache - ultra <- Lens.view normalizeUltra - let eTy = inferCoreTypeOf tcm e - let resTy = snd (splitFunForallTy eTy) - case tyView resTy of - (TyConApp vecTcNm@(nameOcc -> "Clash.Sized.Vector.Vec") - [runExcept . tyNatSize tcm -> Right 0, aTy]) -> do - let nilE = fromMaybe (error "reduceNonRepPrim: unable to create Vec DCs") $ do - vecTc <- UniqMap.lookup vecTcNm tcm - [nilCon,consCon] <- pure (tyConDataCons vecTc) - return (mkVec nilCon consCon aTy 0 []) - changed (mkTicks nilE ticks) - tv -> let argLen = length args in case primName p of - "Clash.Sized.Vector.zipWith" - | (tmArgs,[lhsElTy,rhsElty,resElTy,nTy]) <- Either.partitionEithers args - , TyConApp vecTcNm _ <- tv - , let lhsTy = mkTyConApp vecTcNm [nTy,lhsElTy] - , let rhsTy = mkTyConApp vecTcNm [nTy,rhsElty] - -> case runExcept (tyNatSize tcm nTy) of - Right n -> do - shouldReduce1 <- List.orM [ pure (ultra || n < 2) - , shouldReduce ctx - , List.anyM isUntranslatableType_not_poly - [lhsElTy,rhsElty,resElTy] - -- Note [Unroll shouldSplit types] - , pure (any (Maybe.isJust . shouldSplit tcm) - [lhsTy,rhsTy,resTy]) ] - if shouldReduce1 - then abstractOverMissingArgs ticks tmArgs eTy c - (reduceZipWith p n lhsElTy rhsElty resElTy) - else return e - _ -> return e - | argLen >= 4 - -> error ("reduceNonRepPrim: zipWith bad args" <> showPpr e) +-- Only consider the root of an application spine (see 'reduceConst'): the root +-- sees all arguments, and the @Vec 0@-to-@Nil@ rewrite below is only +-- type-correct at the root, where no more arguments follow. +reduceNonRepPrim (TransformContext _ (AppFun:_)) e = return e +reduceNonRepPrim c e@(App _ _) + | (Prim p, args, ticks) <- collectArgsTicks e + = do + tcm <- Lens.view tcCache + let handlerM = HashMap.lookup (primName p) reduceNonRepPrimImpls + -- Every primitive whose result type is @Vec 0 a@ reduces to @Nil@, not + -- just the ones with a handler. That takes the type of the applied + -- primitive, which is expensive to infer, so for a primitive without a + -- handler it is only inferred when the primitive's declared type shows a + -- @Vec@ result is possible at all. That rules out the vast majority of + -- them. + if Maybe.isNothing handlerM && not (mayReturnVec tcm (primType p)) + then return e + else do + let eTy = inferCoreTypeOf tcm e + let (remainingArgTys, resTy) = splitFunForallTy eTy + let tv = tyView (coreView tcm resTy) + case zeroLengthVecTerm tcm tv of + -- Only replace the whole application by @Nil@ if the primitive is + -- fully applied (a partially applied primitive has a function type, + -- so replacing it by @Nil@ would change its arity) and if it does + -- not always perform work (e.g. blackboxes like an VIO must be + -- rendered even if their result is zero-width). + Just nilE + | null remainingArgTys + , primWorkInfo p /= WorkAlways + -> changed (mkTicks nilE ticks) + _ -> case handlerM of + Nothing -> return e + Just handler -> do + ultraArg <- Lens.view normalizeUltra + handler ReduceNonRepPrimContext + { transformContext = c + , originalTerm = e + , primInfo = p + , primArguments = args + , primTicks = ticks + , tyConMap = tcm + , ultra = ultraArg + , termType = eTy + , resultType = resTy + , resultTypeView = tv + } - "Clash.Sized.Vector.map" - | (tmArgs,[argElTy,resElTy,nTy]) <- Either.partitionEithers args - , TyConApp vecTcNm _ <- tv - , let argTy = mkTyConApp vecTcNm [nTy,argElTy] - -> case runExcept (tyNatSize tcm nTy) of - Right n -> do - shouldReduce1 <- List.orM [ pure (ultra || n < 2 ) - , shouldReduce ctx - , List.anyM isUntranslatableType_not_poly - [argElTy,resElTy] - -- Note [Unroll shouldSplit types] - , pure (any (Maybe.isJust . shouldSplit tcm) - [argTy,resTy]) ] - if shouldReduce1 - then abstractOverMissingArgs ticks tmArgs eTy c - (reduceMap p n argElTy resElTy) - else return e - _ -> return e - | argLen >= 3 - -> error ("reduceNonRepPrim: map bad args" <> showPpr e) +reduceNonRepPrim _ e = return e +{-# SCC reduceNonRepPrim #-} - "Clash.Sized.Vector.traverse#" - | (tmArgs,[aTy,fTy,bTy,nTy]) <- Either.partitionEithers args - -> case runExcept (tyNatSize tcm nTy) of - Right n -> abstractOverMissingArgs ticks tmArgs eTy c (reduceTraverse n aTy fTy bTy) - _ -> return e - | argLen >= 4 - -> error ("reduceNonRepPrim: traverse# bad args" <> showPpr e) +-- | The name of the 'Clash.Sized.Vector.Vec' type constructor. +vecTcName :: Text +vecTcName = $(textNameLit ''Clash.Sized.Vector.Vec) - "Clash.Sized.Vector.fold" - | (tmArgs,[nTy,aTy]) <- Either.partitionEithers args - , (_:Right argTy:_) <- fst (splitFunForallTy (piResultTys tcm (primType p) [nTy,aTy])) - -> case runExcept (tyNatSize tcm nTy) of - Right n -> do - shouldReduce1 <- List.orM [ pure (ultra || n == 0) - , shouldReduce ctx - , isUntranslatableType_not_poly aTy - -- Note [Unroll shouldSplit types] - , pure (Maybe.isJust (shouldSplit tcm argTy))] - if shouldReduce1 then - abstractOverMissingArgs ticks tmArgs eTy c (reduceFold (n + 1) aTy) - else return e - _ -> return e - | argLen >= 2 - -> error ("reduceNonRepPrim: fold bad args" <> showPpr e) +-- | If the given type view is @Vec 0 a@, return the corresponding @Nil@ term. +zeroLengthVecTerm :: TyConMap -> TypeView -> Maybe Term +zeroLengthVecTerm tcm tv + | TyConApp vecTcNm [nTy, aTy] <- tv + , nameOcc vecTcNm == vecTcName + , Right 0 <- runExcept (tyNatSize tcm nTy) + = Just $ fromMaybe (error "reduceNonRepPrim: unable to create Vec DCs") $ do + vecTc <- UniqMap.lookup vecTcNm tcm + [nilCon,consCon] <- pure (tyConDataCons vecTc) + return (mkVec nilCon consCon aTy 0 []) + | otherwise + = Nothing - "Clash.Sized.Vector.foldr" - | (tmArgs,[aTy,bTy,nTy]) <- Either.partitionEithers args - , (_:_:Right argTy:_) <- fst (splitFunForallTy (piResultTys tcm (primType p) [aTy,bTy,nTy])) - -> case runExcept (tyNatSize tcm nTy) of - Right n -> do - shouldReduce1 <- List.orM [ pure ultra - , shouldReduce ctx - , List.anyM isUntranslatableType_not_poly [aTy,bTy] - -- Note [Unroll shouldSplit types] - , pure (Maybe.isJust (shouldSplit tcm argTy)) ] - if shouldReduce1 - then abstractOverMissingArgs ticks tmArgs eTy c (reduceFoldr p n aTy) - else return e - _ -> return e - | argLen >= 3 - -> error ("reduceNonRepPrim: foldr bad args" <> showPpr e) +-- | Can applying the primitive produce a value whose type has +-- 'Clash.Sized.Vector.Vec' at its head? This is decided from the primitive's +-- declared type, which is readily available, rather than from the type of the +-- applied primitive, which has to be inferred. +-- +-- A result headed by a concrete type constructor other than @Vec@ can never +-- instantiate to a @Vec@. Everything else -- type variables, type families, +-- type constructors we know nothing about -- might, and yields 'True'. +-- Over-approximating is sound: a 'True' only makes 'reduceNonRepPrim' infer +-- the type of the applied primitive and ask 'zeroLengthVecTerm' for a verdict. +mayReturnVec :: TyConMap -> Type -> Bool +mayReturnVec tcm ty = case tyView (snd (splitFunForallTy ty)) of + TyConApp tcNm _ + | nameOcc tcNm == vecTcName -> True + | otherwise -> case UniqMap.lookup tcNm tcm of + -- Type families might reduce to a 'Vec' + Just FunTyCon{} -> True + Just _ -> False + Nothing -> True + _ -> True - "Clash.Sized.Vector.dfold" - | (tmArgs,[_mTy,nTy,aTy]) <- Either.partitionEithers args - -> case runExcept (tyNatSize tcm nTy) of - Right n -> abstractOverMissingArgs ticks tmArgs eTy c (reduceDFold n aTy) - _ -> return e - | argLen >= 3 - -> error ("reduceNonRepPrim: dfold bad args" <> showPpr e) +-- | Everything the handlers in 'reduceNonRepPrimImpls' receive from the +-- dispatch site in 'reduceNonRepPrim'. +data ReduceNonRepPrimContext = ReduceNonRepPrimContext + { transformContext :: TransformContext + , originalTerm :: Term + -- ^ The primitive applied to its arguments + , primInfo :: PrimInfo + , primArguments :: [Either Term Type] + , primTicks :: [TickInfo] + , tyConMap :: TyConMap + , ultra :: Bool + -- ^ Whether @-fclash-ultra@ is enabled + , termType :: Type + -- ^ The type of 'originalTerm' + , resultType :: Type + -- ^ 'termType' stripped of its quantifiers and function arguments + , resultTypeView :: TypeView + -- ^ 'tyView' of 'resultType' + } - "Clash.Sized.Vector.++" - | (tmArgs,[nTy,aTy,mTy]) <- Either.partitionEithers args - -> case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy)) of - (Right n, Right m) -> do - shouldReduce1 <- List.orM [ pure (n==0) - , pure (m==0) - , shouldReduce ctx - , isUntranslatableType_not_poly aTy - -- Note [Unroll shouldSplit types] - , pure (Maybe.isJust (shouldSplit tcm resTy)) ] - if shouldReduce1 - then abstractOverMissingArgs ticks tmArgs eTy c (reduceAppend n m aTy) - else return e - _ -> return e - | argLen >= 3 - -> error ("reduceNonRepPrim: ++ bad args" <> showPpr e) +-- | A handler for a specific primitive in 'reduceNonRepPrimImpls'. +type ReduceNonRepPrimHandler + = ReduceNonRepPrimContext -> NormalizeSession Term - "Clash.Sized.Vector.head" - | (tmArgs,[nTy,aTy]) <- Either.partitionEithers args - , (Right argTy:_) <- fst (splitFunForallTy (piResultTys tcm (primType p) [nTy,aTy])) - -> case runExcept (tyNatSize tcm nTy) of - Right n -> do - shouldReduce1 <- List.orM [ shouldReduce ctx - , isUntranslatableType_not_poly aTy - -- Note [Unroll shouldSplit types] - , pure (Maybe.isJust (shouldSplit tcm argTy)) ] - if shouldReduce1 - then abstractOverMissingArgs ticks tmArgs eTy c (reduceHead (n+1) aTy) - else return e - _ -> return e - | argLen >= 2 - -> error ("reduceNonRepPrim: head bad args" <> showPpr e) +-- | The primitives 'reduceNonRepPrim' can reduce, keyed on primitive +-- name. The handlers are the arms of the @case@ expression this map replaced; +-- a handler whose guards do not apply returns 'originalTerm' unchanged, like +-- the fall-through of the @case@ did. +reduceNonRepPrimImpls :: HashMap Text ReduceNonRepPrimHandler +reduceNonRepPrimImpls = HashMap.fromList + [ ($(textNameLit 'Clash.Sized.Vector.zipWith), reduceZipWithHandler) + , ($(textNameLit 'Clash.Sized.Vector.map), reduceMapHandler) + , ($(textNameLit 'Clash.Sized.Vector.traverse#), reduceTraverseHandler) + , ($(textNameLit 'Clash.Sized.Vector.fold), reduceFoldHandler) + , ($(textNameLit 'Clash.Sized.Vector.foldr), reduceFoldrHandler) + , ($(textNameLit 'Clash.Sized.Vector.dfold), reduceDFoldHandler) + , ($(textNameLit '(Clash.Sized.Vector.++)), reduceAppendHandler) + , ($(textNameLit 'Clash.Sized.Vector.head), reduceHeadHandler) + , ($(textNameLit 'Clash.Sized.Vector.tail), reduceTailHandler) + , ($(textNameLit 'Clash.Sized.Vector.last), reduceLastHandler) + , ($(textNameLit 'Clash.Sized.Vector.init), reduceInitHandler) + , ($(textNameLit 'Clash.Sized.Vector.unconcat), reduceUnconcatHandler) + , ($(textNameLit 'Clash.Sized.Vector.transpose), reduceTransposeHandler) + , ($(textNameLit 'Clash.Sized.Vector.replicate), reduceReplicateHandler) + -- replace_int and index_int are not exported from Clash.Sized.Vector, so + -- their names cannot be quoted + , ("Clash.Sized.Vector.replace_int", reduceReplaceIntHandler) + , ("Clash.Sized.Vector.index_int", reduceIndexIntHandler) + , ($(textNameLit 'Clash.Sized.Vector.imap), reduceImapHandler) + , ($(textNameLit 'Clash.Sized.Vector.iterateI), reduceIterateIHandler) + , ($(textNameLit 'Clash.Sized.Vector.dtfold), reduceDTFoldHandler) + , ($(textNameLit 'Clash.Sized.Vector.reverse), reduceReverseHandler) + , ($(textNameLit 'Clash.Sized.RTree.tdfold), reduceTDFoldHandler) + , ($(textNameLit 'Clash.Sized.RTree.treplicate), reduceTReplicateHandler) + , ($(textNameLit 'Clash.Sized.Internal.BitVector.split#), reduceSplitHandler) + , ($(textNameLit 'Clash.Sized.Internal.BitVector.eq#), reduceEqHandler) + ] - "Clash.Sized.Vector.tail" - | (tmArgs,[nTy,aTy]) <- Either.partitionEithers args - , (Right argTy:_) <- fst (splitFunForallTy (piResultTys tcm (primType p) [nTy,aTy])) - -> case runExcept (tyNatSize tcm nTy) of - Right n -> do - shouldReduce1 <- List.orM [ shouldReduce ctx - , isUntranslatableType_not_poly aTy - -- Note [Unroll shouldSplit types] - , pure (Maybe.isJust (shouldSplit tcm argTy)) ] - if shouldReduce1 - then abstractOverMissingArgs ticks tmArgs eTy c (reduceTail (n+1) aTy) - else return e - _ -> return e - | argLen >= 2 - -> error ("reduceNonRepPrim: tail bad args" <> showPpr e) +reduceZipWithHandler :: ReduceNonRepPrimHandler +reduceZipWithHandler ReduceNonRepPrimContext{..} + | (tmArgs,[lhsElTy,rhsElty,resElTy,nTy]) <- Either.partitionEithers primArguments + , TyConApp vecTcNm _ <- resultTypeView + , let lhsTy = mkTyConApp vecTcNm [nTy,lhsElTy] + , let rhsTy = mkTyConApp vecTcNm [nTy,rhsElty] + = case runExcept (tyNatSize tyConMap nTy) of + Right n -> do + shouldReduce1 <- List.orM [ pure (ultra || n < 2) + , shouldReduce (tfContext transformContext) + , List.anyM isUntranslatableType_not_poly + [lhsElTy,rhsElty,resElTy] + -- Note [Unroll shouldSplit types] + , pure (any (Maybe.isJust . shouldSplit tyConMap) + [lhsTy,rhsTy,resultType]) ] + if shouldReduce1 + then abstractOverMissingArgs primTicks tmArgs termType transformContext + (reduceZipWith primInfo n lhsElTy rhsElty resElTy) + else return originalTerm + _ -> return originalTerm + | length primArguments >= 4 + = error ("reduceNonRepPrim: zipWith bad args" <> showPpr originalTerm) + | otherwise + = return originalTerm - "Clash.Sized.Vector.last" - | (tmArgs,[nTy,aTy]) <- Either.partitionEithers args - , (Right argTy:_) <- fst (splitFunForallTy (piResultTys tcm (primType p) [nTy,aTy])) - -> case runExcept (tyNatSize tcm nTy) of - Right n -> do - shouldReduce1 <- List.orM [ shouldReduce ctx - , isUntranslatableType_not_poly aTy - -- Note [Unroll shouldSplit types] - , pure (Maybe.isJust (shouldSplit tcm argTy)) - ] - if shouldReduce1 - then abstractOverMissingArgs ticks tmArgs eTy c (reduceLast (n+1) aTy) - else return e - _ -> return e - | argLen >= 2 - -> error ("reduceNonRepPrim: last bad args" <> showPpr e) +reduceMapHandler :: ReduceNonRepPrimHandler +reduceMapHandler ReduceNonRepPrimContext{..} + | (tmArgs,[argElTy,resElTy,nTy]) <- Either.partitionEithers primArguments + , TyConApp vecTcNm _ <- resultTypeView + , let argTy = mkTyConApp vecTcNm [nTy,argElTy] + = case runExcept (tyNatSize tyConMap nTy) of + Right n -> do + shouldReduce1 <- List.orM [ pure (ultra || n < 2 ) + , shouldReduce (tfContext transformContext) + , List.anyM isUntranslatableType_not_poly + [argElTy,resElTy] + -- Note [Unroll shouldSplit types] + , pure (any (Maybe.isJust . shouldSplit tyConMap) + [argTy,resultType]) ] + if shouldReduce1 + then abstractOverMissingArgs primTicks tmArgs termType transformContext + (reduceMap primInfo n argElTy resElTy) + else return originalTerm + _ -> return originalTerm + | length primArguments >= 3 + = error ("reduceNonRepPrim: map bad args" <> showPpr originalTerm) + | otherwise + = return originalTerm - "Clash.Sized.Vector.init" - | (tmArgs,[nTy,aTy]) <- Either.partitionEithers args - , (Right argTy:_) <- fst (splitFunForallTy (piResultTys tcm (primType p) [nTy,aTy])) - -> case runExcept (tyNatSize tcm nTy) of - Right n -> do - shouldReduce1 <- List.orM [ shouldReduce ctx - , isUntranslatableType_not_poly aTy - -- Note [Unroll shouldSplit types] - , pure (Maybe.isJust (shouldSplit tcm argTy)) ] - if shouldReduce1 - then abstractOverMissingArgs ticks tmArgs eTy c (reduceInit p n aTy) - else return e - _ -> return e - | argLen >= 2 - -> error ("reduceNonRepPrim: init bad args" <> showPpr e) +reduceTraverseHandler :: ReduceNonRepPrimHandler +reduceTraverseHandler ReduceNonRepPrimContext{..} + | (tmArgs,[aTy,fTy,bTy,nTy]) <- Either.partitionEithers primArguments + = case runExcept (tyNatSize tyConMap nTy) of + Right n -> abstractOverMissingArgs primTicks tmArgs termType transformContext + (reduceTraverse n aTy fTy bTy) + _ -> return originalTerm + | length primArguments >= 4 + = error ("reduceNonRepPrim: traverse# bad args" <> showPpr originalTerm) + | otherwise + = return originalTerm - "Clash.Sized.Vector.unconcat" - | (tmArgs,[nTy,mTy,aTy]) <- Either.partitionEithers args - , (_:_:Right argTy:_) <- fst (splitFunForallTy (piResultTys tcm (primType p) [nTy,mTy,aTy])) - -> case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy)) of - (Right n, Right m) -> do - shouldReduce1 <- List.orM [ pure (m==0) - , shouldReduce ctx - , isUntranslatableType_not_poly aTy - -- Note [Unroll shouldSplit types] - , pure (Maybe.isJust (shouldSplit tcm argTy)) - ] - if shouldReduce1 then - abstractOverMissingArgs ticks tmArgs eTy c (reduceUnconcat p n m aTy) - else - return e - _ -> return e - | argLen >= 3 - -> error ("reduceNonRepPrim: unconcat bad args" <> showPpr e) +reduceFoldHandler :: ReduceNonRepPrimHandler +reduceFoldHandler ReduceNonRepPrimContext{..} + | (tmArgs,[nTy,aTy]) <- Either.partitionEithers primArguments + , (_:Right argTy:_) <- fst (splitFunForallTy (piResultTys tyConMap (primType primInfo) [nTy,aTy])) + = case runExcept (tyNatSize tyConMap nTy) of + Right n -> do + shouldReduce1 <- List.orM [ pure (ultra || n == 0) + , shouldReduce (tfContext transformContext) + , isUntranslatableType_not_poly aTy + -- Note [Unroll shouldSplit types] + , pure (Maybe.isJust (shouldSplit tyConMap argTy))] + if shouldReduce1 then + abstractOverMissingArgs primTicks tmArgs termType transformContext + (reduceFold (n + 1) aTy) + else return originalTerm + _ -> return originalTerm + | length primArguments >= 2 + = error ("reduceNonRepPrim: fold bad args" <> showPpr originalTerm) + | otherwise + = return originalTerm - "Clash.Sized.Vector.transpose" - | (tmArgs,[mTy,nTy,aTy]) <- Either.partitionEithers args - -> case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy)) of - (Right n, Right 0) -> abstractOverMissingArgs ticks tmArgs eTy c (reduceTranspose n 0 aTy) - _ -> return e - | argLen >= 3 - -> error ("reduceNonRepPrim: transpose bad args" <> showPpr e) +reduceFoldrHandler :: ReduceNonRepPrimHandler +reduceFoldrHandler ReduceNonRepPrimContext{..} + | (tmArgs,[aTy,bTy,nTy]) <- Either.partitionEithers primArguments + , (_:_:Right argTy:_) <- fst (splitFunForallTy (piResultTys tyConMap (primType primInfo) [aTy,bTy,nTy])) + = case runExcept (tyNatSize tyConMap nTy) of + Right n -> do + shouldReduce1 <- List.orM [ pure ultra + , shouldReduce (tfContext transformContext) + , List.anyM isUntranslatableType_not_poly [aTy,bTy] + -- Note [Unroll shouldSplit types] + , pure (Maybe.isJust (shouldSplit tyConMap argTy)) ] + if shouldReduce1 + then abstractOverMissingArgs primTicks tmArgs termType transformContext + (reduceFoldr primInfo n aTy) + else return originalTerm + _ -> return originalTerm + | length primArguments >= 3 + = error ("reduceNonRepPrim: foldr bad args" <> showPpr originalTerm) + | otherwise + = return originalTerm - "Clash.Sized.Vector.replicate" - | (tmArgs,[nTy,aTy]) <- Either.partitionEithers args - -> case runExcept (tyNatSize tcm nTy) of - Right n -> do - shouldReduce1 <- List.orM [ shouldReduce ctx - , isUntranslatableType_not_poly aTy - -- Note [Unroll shouldSplit types] - , pure (Maybe.isJust (shouldSplit tcm resTy)) - ] - if shouldReduce1 - then abstractOverMissingArgs ticks tmArgs eTy c (reduceReplicate n aTy resTy) - else return e - _ -> return e - | argLen >= 2 - -> error ("reduceNonRepPrim: replicate bad args" <> showPpr e) +reduceDFoldHandler :: ReduceNonRepPrimHandler +reduceDFoldHandler ReduceNonRepPrimContext{..} + | (tmArgs,[_mTy,nTy,aTy]) <- Either.partitionEithers primArguments + = case runExcept (tyNatSize tyConMap nTy) of + Right n -> abstractOverMissingArgs primTicks tmArgs termType transformContext + (reduceDFold n aTy) + _ -> return originalTerm + | length primArguments >= 3 + = error ("reduceNonRepPrim: dfold bad args" <> showPpr originalTerm) + | otherwise + = return originalTerm - -- replace_int :: KnownNat n => Vec n a -> Int -> a -> Vec n a - "Clash.Sized.Vector.replace_int" - | (tmArgs,[nTy,aTy]) <- Either.partitionEithers args - -> case runExcept (tyNatSize tcm nTy) of - Right n -> do - shouldReduce1 <- List.orM [ pure ultra - , shouldReduce ctx +reduceAppendHandler :: ReduceNonRepPrimHandler +reduceAppendHandler ReduceNonRepPrimContext{..} + | (tmArgs,[nTy,aTy,mTy]) <- Either.partitionEithers primArguments + = case (runExcept (tyNatSize tyConMap nTy), runExcept (tyNatSize tyConMap mTy)) of + (Right n, Right m) -> do + shouldReduce1 <- List.orM [ pure (n==0) + , pure (m==0) + , shouldReduce (tfContext transformContext) , isUntranslatableType_not_poly aTy -- Note [Unroll shouldSplit types] - , pure (Maybe.isJust (shouldSplit tcm resTy)) - ] + , pure (Maybe.isJust (shouldSplit tyConMap resultType)) ] if shouldReduce1 - then abstractOverMissingArgs ticks tmArgs eTy c (reduceReplace_int n aTy resTy) - else return e - _ -> return e - | argLen >= 2 - -> error ("reduceNonRepPrim: replace_int bad args" <> showPpr e) + then abstractOverMissingArgs primTicks tmArgs termType transformContext + (reduceAppend n m aTy) + else return originalTerm + _ -> return originalTerm + | length primArguments >= 3 + = error ("reduceNonRepPrim: ++ bad args" <> showPpr originalTerm) + | otherwise + = return originalTerm - "Clash.Sized.Vector.index_int" - | (tmArgs,[nTy,aTy]) <- Either.partitionEithers args - , (_:Right argTy:_) <- fst (splitFunForallTy (piResultTys tcm (primType p) [nTy,aTy])) - -> case runExcept (tyNatSize tcm nTy) of - Right n -> do - shouldReduce1 <- List.orM [ pure ultra - , shouldReduce ctx - , isUntranslatableType_not_poly aTy - -- Note [Unroll shouldSplit types] - , pure (Maybe.isJust (shouldSplit tcm argTy)) ] - if shouldReduce1 - then abstractOverMissingArgs ticks tmArgs eTy c (reduceIndex_int n aTy) - else return e - _ -> return e - | argLen >= 2 - -> error ("reduceNonRepPrim: index_int bad args" <> showPpr e) +reduceHeadHandler :: ReduceNonRepPrimHandler +reduceHeadHandler ReduceNonRepPrimContext{..} + | (tmArgs,[nTy,aTy]) <- Either.partitionEithers primArguments + , (Right argTy:_) <- fst (splitFunForallTy (piResultTys tyConMap (primType primInfo) [nTy,aTy])) + = case runExcept (tyNatSize tyConMap nTy) of + Right n -> do + shouldReduce1 <- List.orM [ shouldReduce (tfContext transformContext) + , isUntranslatableType_not_poly aTy + -- Note [Unroll shouldSplit types] + , pure (Maybe.isJust (shouldSplit tyConMap argTy)) ] + if shouldReduce1 + then abstractOverMissingArgs primTicks tmArgs termType transformContext + (reduceHead (n+1) aTy) + else return originalTerm + _ -> return originalTerm + | length primArguments >= 2 + = error ("reduceNonRepPrim: head bad args" <> showPpr originalTerm) + | otherwise + = return originalTerm - "Clash.Sized.Vector.imap" - | (tmArgs,[nTy,argElTy,resElTy]) <- Either.partitionEithers args - , TyConApp vecTcNm _ <- tv - , let argTy = mkTyConApp vecTcNm [nTy,argElTy] - -> case runExcept (tyNatSize tcm nTy) of - Right n -> do - shouldReduce1 <- List.orM [ pure (ultra || n < 2) - , shouldReduce ctx - , List.anyM isUntranslatableType_not_poly [argElTy,resElTy] - -- Note [Unroll shouldSplit types] - , pure (any (Maybe.isJust . shouldSplit tcm) - [argTy,resTy]) ] - if shouldReduce1 - then abstractOverMissingArgs ticks tmArgs eTy c (reduceImap n argElTy resElTy) - else return e - _ -> return e - | argLen >= 3 - -> error ("reduceNonRepPrim: imap bad args" <> showPpr e) +reduceTailHandler :: ReduceNonRepPrimHandler +reduceTailHandler ReduceNonRepPrimContext{..} + | (tmArgs,[nTy,aTy]) <- Either.partitionEithers primArguments + , (Right argTy:_) <- fst (splitFunForallTy (piResultTys tyConMap (primType primInfo) [nTy,aTy])) + = case runExcept (tyNatSize tyConMap nTy) of + Right n -> do + shouldReduce1 <- List.orM [ shouldReduce (tfContext transformContext) + , isUntranslatableType_not_poly aTy + -- Note [Unroll shouldSplit types] + , pure (Maybe.isJust (shouldSplit tyConMap argTy)) ] + if shouldReduce1 + then abstractOverMissingArgs primTicks tmArgs termType transformContext + (reduceTail (n+1) aTy) + else return originalTerm + _ -> return originalTerm + | length primArguments >= 2 + = error ("reduceNonRepPrim: tail bad args" <> showPpr originalTerm) + | otherwise + = return originalTerm - "Clash.Sized.Vector.iterateI" - | (tmArgs,[nTy,aTy]) <- Either.partitionEithers args - -> case runExcept (tyNatSize tcm nTy) of - Right n -> do - shouldReduce1 <- List.orM - [ pure (ultra || n < 2) - , shouldReduce ctx - , isUntranslatableType_not_poly aTy - -- Note [Unroll shouldSplit types] - , pure (Maybe.isJust (shouldSplit tcm resTy)) ] +reduceLastHandler :: ReduceNonRepPrimHandler +reduceLastHandler ReduceNonRepPrimContext{..} + | (tmArgs,[nTy,aTy]) <- Either.partitionEithers primArguments + , (Right argTy:_) <- fst (splitFunForallTy (piResultTys tyConMap (primType primInfo) [nTy,aTy])) + = case runExcept (tyNatSize tyConMap nTy) of + Right n -> do + shouldReduce1 <- List.orM [ shouldReduce (tfContext transformContext) + , isUntranslatableType_not_poly aTy + -- Note [Unroll shouldSplit types] + , pure (Maybe.isJust (shouldSplit tyConMap argTy)) + ] + if shouldReduce1 + then abstractOverMissingArgs primTicks tmArgs termType transformContext + (reduceLast (n+1) aTy) + else return originalTerm + _ -> return originalTerm + | length primArguments >= 2 + = error ("reduceNonRepPrim: last bad args" <> showPpr originalTerm) + | otherwise + = return originalTerm - if shouldReduce1 then - abstractOverMissingArgs ticks tmArgs eTy c (reduceIterateI n aTy resTy) - else - return e - _ -> return e - | argLen >= 2 - -> error ("reduceNonRepPrim: iterateI bad args" <> showPpr e) +reduceInitHandler :: ReduceNonRepPrimHandler +reduceInitHandler ReduceNonRepPrimContext{..} + | (tmArgs,[nTy,aTy]) <- Either.partitionEithers primArguments + , (Right argTy:_) <- fst (splitFunForallTy (piResultTys tyConMap (primType primInfo) [nTy,aTy])) + = case runExcept (tyNatSize tyConMap nTy) of + Right n -> do + shouldReduce1 <- List.orM [ shouldReduce (tfContext transformContext) + , isUntranslatableType_not_poly aTy + -- Note [Unroll shouldSplit types] + , pure (Maybe.isJust (shouldSplit tyConMap argTy)) ] + if shouldReduce1 + then abstractOverMissingArgs primTicks tmArgs termType transformContext + (reduceInit primInfo n aTy) + else return originalTerm + _ -> return originalTerm + | length primArguments >= 2 + = error ("reduceNonRepPrim: init bad args" <> showPpr originalTerm) + | otherwise + = return originalTerm - "Clash.Sized.Vector.dtfold" - | (tmArgs,[_mTy,nTy,aTy]) <- Either.partitionEithers args - -> case runExcept (tyNatSize tcm nTy) of - Right n -> abstractOverMissingArgs ticks tmArgs eTy c (reduceDTFold n aTy) - _ -> return e - | argLen >= 3 - -> error ("reduceNonRepPrim: dtfold bad args" <> showPpr e) +reduceUnconcatHandler :: ReduceNonRepPrimHandler +reduceUnconcatHandler ReduceNonRepPrimContext{..} + | (tmArgs,[nTy,mTy,aTy]) <- Either.partitionEithers primArguments + , (_:_:Right argTy:_) <- fst (splitFunForallTy (piResultTys tyConMap (primType primInfo) [nTy,mTy,aTy])) + = case (runExcept (tyNatSize tyConMap nTy), runExcept (tyNatSize tyConMap mTy)) of + (Right n, Right m) -> do + shouldReduce1 <- List.orM [ pure (m==0) + , shouldReduce (tfContext transformContext) + , isUntranslatableType_not_poly aTy + -- Note [Unroll shouldSplit types] + , pure (Maybe.isJust (shouldSplit tyConMap argTy)) + ] + if shouldReduce1 then + abstractOverMissingArgs primTicks tmArgs termType transformContext + (reduceUnconcat primInfo n m aTy) + else + return originalTerm + _ -> return originalTerm + | length primArguments >= 3 + = error ("reduceNonRepPrim: unconcat bad args" <> showPpr originalTerm) + | otherwise + = return originalTerm - "Clash.Sized.Vector.reverse" - | ultra - , (tmArgs,[nTy,aTy]) <- Either.partitionEithers args - , Right n <- runExcept (tyNatSize tcm nTy) - -> abstractOverMissingArgs ticks tmArgs eTy c (reduceReverse n aTy) +reduceTransposeHandler :: ReduceNonRepPrimHandler +reduceTransposeHandler ReduceNonRepPrimContext{..} + | (tmArgs,[mTy,nTy,aTy]) <- Either.partitionEithers primArguments + = case (runExcept (tyNatSize tyConMap nTy), runExcept (tyNatSize tyConMap mTy)) of + (Right n, Right 0) -> abstractOverMissingArgs primTicks tmArgs termType transformContext + (reduceTranspose n 0 aTy) + _ -> return originalTerm + | length primArguments >= 3 + = error ("reduceNonRepPrim: transpose bad args" <> showPpr originalTerm) + | otherwise + = return originalTerm - "Clash.Sized.RTree.tdfold" - | (tmArgs,[_mTy,nTy,aTy]) <- Either.partitionEithers args - -> case runExcept (tyNatSize tcm nTy) of - Right n -> abstractOverMissingArgs ticks tmArgs eTy c (reduceTFold n aTy) - _ -> return e - | argLen >= 3 - -> error ("reduceNonRepPrim: tdfold bad args" <> showPpr e) - "Clash.Sized.RTree.treplicate" - | (tmArgs,[nTy,aTy]) <- Either.partitionEithers args -> - case runExcept (tyNatSize tcm nTy) of - Right n -> do - shouldReduce1 <- List.orM [ shouldReduce ctx - , isUntranslatableType False aTy ] - if shouldReduce1 - then abstractOverMissingArgs ticks tmArgs eTy c (reduceTReplicate n aTy resTy) - else return e - _ -> return e - | argLen >= 2 - -> error ("reduceNonRepPrim: treplicate bad args" <> showPpr e) - "Clash.Sized.Internal.BitVector.split#" - | (tmArgs,[nTy,mTy]) <- Either.partitionEithers args -> - case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy), tv) of - (Right n, Right m, TyConApp tupTcNm [lTy,rTy]) - | n == 0 -> abstractOverMissingArgs ticks tmArgs eTy c $ \(_kn :: Term) bvArg (_ctx :: TransformContext) -> do +reduceReplicateHandler :: ReduceNonRepPrimHandler +reduceReplicateHandler ReduceNonRepPrimContext{..} + | (tmArgs,[nTy,aTy]) <- Either.partitionEithers primArguments + = case runExcept (tyNatSize tyConMap nTy) of + Right n -> do + shouldReduce1 <- List.orM [ shouldReduce (tfContext transformContext) + , isUntranslatableType_not_poly aTy + -- Note [Unroll shouldSplit types] + , pure (Maybe.isJust (shouldSplit tyConMap resultType)) + ] + if shouldReduce1 + then abstractOverMissingArgs primTicks tmArgs termType transformContext + (reduceReplicate n aTy resultType) + else return originalTerm + _ -> return originalTerm + | length primArguments >= 2 + = error ("reduceNonRepPrim: replicate bad args" <> showPpr originalTerm) + | otherwise + = return originalTerm + +-- replace_int :: KnownNat n => Vec n a -> Int -> a -> Vec n a +reduceReplaceIntHandler :: ReduceNonRepPrimHandler +reduceReplaceIntHandler ReduceNonRepPrimContext{..} + | (tmArgs,[nTy,aTy]) <- Either.partitionEithers primArguments + = case runExcept (tyNatSize tyConMap nTy) of + Right n -> do + shouldReduce1 <- List.orM [ pure ultra + , shouldReduce (tfContext transformContext) + , isUntranslatableType_not_poly aTy + -- Note [Unroll shouldSplit types] + , pure (Maybe.isJust (shouldSplit tyConMap resultType)) + ] + if shouldReduce1 + then abstractOverMissingArgs primTicks tmArgs termType transformContext + (reduceReplace_int n aTy resultType) + else return originalTerm + _ -> return originalTerm + | length primArguments >= 2 + = error ("reduceNonRepPrim: replace_int bad args" <> showPpr originalTerm) + | otherwise + = return originalTerm + +reduceIndexIntHandler :: ReduceNonRepPrimHandler +reduceIndexIntHandler ReduceNonRepPrimContext{..} + | (tmArgs,[nTy,aTy]) <- Either.partitionEithers primArguments + , (_:Right argTy:_) <- fst (splitFunForallTy (piResultTys tyConMap (primType primInfo) [nTy,aTy])) + = case runExcept (tyNatSize tyConMap nTy) of + Right n -> do + shouldReduce1 <- List.orM [ pure ultra + , shouldReduce (tfContext transformContext) + , isUntranslatableType_not_poly aTy + -- Note [Unroll shouldSplit types] + , pure (Maybe.isJust (shouldSplit tyConMap argTy)) ] + if shouldReduce1 + then abstractOverMissingArgs primTicks tmArgs termType transformContext + (reduceIndex_int n aTy) + else return originalTerm + _ -> return originalTerm + | length primArguments >= 2 + = error ("reduceNonRepPrim: index_int bad args" <> showPpr originalTerm) + | otherwise + = return originalTerm + +reduceImapHandler :: ReduceNonRepPrimHandler +reduceImapHandler ReduceNonRepPrimContext{..} + | (tmArgs,[nTy,argElTy,resElTy]) <- Either.partitionEithers primArguments + , TyConApp vecTcNm _ <- resultTypeView + , let argTy = mkTyConApp vecTcNm [nTy,argElTy] + = case runExcept (tyNatSize tyConMap nTy) of + Right n -> do + shouldReduce1 <- List.orM [ pure (ultra || n < 2) + , shouldReduce (tfContext transformContext) + , List.anyM isUntranslatableType_not_poly [argElTy,resElTy] + -- Note [Unroll shouldSplit types] + , pure (any (Maybe.isJust . shouldSplit tyConMap) + [argTy,resultType]) ] + if shouldReduce1 + then abstractOverMissingArgs primTicks tmArgs termType transformContext + (reduceImap n argElTy resElTy) + else return originalTerm + _ -> return originalTerm + | length primArguments >= 3 + = error ("reduceNonRepPrim: imap bad args" <> showPpr originalTerm) + | otherwise + = return originalTerm + +reduceIterateIHandler :: ReduceNonRepPrimHandler +reduceIterateIHandler ReduceNonRepPrimContext{..} + | (tmArgs,[nTy,aTy]) <- Either.partitionEithers primArguments + = case runExcept (tyNatSize tyConMap nTy) of + Right n -> do + shouldReduce1 <- List.orM + [ pure (ultra || n < 2) + , shouldReduce (tfContext transformContext) + , isUntranslatableType_not_poly aTy + -- Note [Unroll shouldSplit types] + , pure (Maybe.isJust (shouldSplit tyConMap resultType)) ] + + if shouldReduce1 then + abstractOverMissingArgs primTicks tmArgs termType transformContext + (reduceIterateI n aTy resultType) + else + return originalTerm + _ -> return originalTerm + | length primArguments >= 2 + = error ("reduceNonRepPrim: iterateI bad args" <> showPpr originalTerm) + | otherwise + = return originalTerm + +reduceDTFoldHandler :: ReduceNonRepPrimHandler +reduceDTFoldHandler ReduceNonRepPrimContext{..} + | (tmArgs,[_mTy,nTy,aTy]) <- Either.partitionEithers primArguments + = case runExcept (tyNatSize tyConMap nTy) of + Right n -> abstractOverMissingArgs primTicks tmArgs termType transformContext + (reduceDTFold n aTy) + _ -> return originalTerm + | length primArguments >= 3 + = error ("reduceNonRepPrim: dtfold bad args" <> showPpr originalTerm) + | otherwise + = return originalTerm + +reduceReverseHandler :: ReduceNonRepPrimHandler +reduceReverseHandler ReduceNonRepPrimContext{..} + | ultra + , (tmArgs,[nTy,aTy]) <- Either.partitionEithers primArguments + , Right n <- runExcept (tyNatSize tyConMap nTy) + = abstractOverMissingArgs primTicks tmArgs termType transformContext + (reduceReverse n aTy) + | otherwise + = return originalTerm + +reduceTDFoldHandler :: ReduceNonRepPrimHandler +reduceTDFoldHandler ReduceNonRepPrimContext{..} + | (tmArgs,[_mTy,nTy,aTy]) <- Either.partitionEithers primArguments + = case runExcept (tyNatSize tyConMap nTy) of + Right n -> abstractOverMissingArgs primTicks tmArgs termType transformContext + (reduceTFold n aTy) + _ -> return originalTerm + | length primArguments >= 3 + = error ("reduceNonRepPrim: tdfold bad args" <> showPpr originalTerm) + | otherwise + = return originalTerm + +reduceTReplicateHandler :: ReduceNonRepPrimHandler +reduceTReplicateHandler ReduceNonRepPrimContext{..} + | (tmArgs,[nTy,aTy]) <- Either.partitionEithers primArguments + = case runExcept (tyNatSize tyConMap nTy) of + Right n -> do + shouldReduce1 <- List.orM [ shouldReduce (tfContext transformContext) + , isUntranslatableType False aTy ] + if shouldReduce1 + then abstractOverMissingArgs primTicks tmArgs termType transformContext + (reduceTReplicate n aTy resultType) + else return originalTerm + _ -> return originalTerm + | length primArguments >= 2 + = error ("reduceNonRepPrim: treplicate bad args" <> showPpr originalTerm) + | otherwise + = return originalTerm + +reduceSplitHandler :: ReduceNonRepPrimHandler +reduceSplitHandler ReduceNonRepPrimContext{..} + | (tmArgs,[nTy,mTy]) <- Either.partitionEithers primArguments + = case (runExcept (tyNatSize tyConMap nTy), runExcept (tyNatSize tyConMap mTy), resultTypeView) of + (Right n, Right m, TyConApp tupTcNm [lTy,rTy]) + | n == 0 -> abstractOverMissingArgs primTicks tmArgs termType transformContext $ + \(_kn :: Term) bvArg (_ctx :: TransformContext) -> do let tup = mkApps (Data tupDc) [Right lTy ,Right rTy @@ -500,8 +716,9 @@ ,Left (TyApp (Prim removedArg) rTy) ] - (changed (mkTicks tup ticks) :: NormalizeSession Term) - | m == 0 -> abstractOverMissingArgs ticks tmArgs eTy c $ \(_kn :: Term) bvArg (_ctx :: TransformContext) -> do + (changed (mkTicks tup primTicks) :: NormalizeSession Term) + | m == 0 -> abstractOverMissingArgs primTicks tmArgs termType transformContext $ + \(_kn :: Term) bvArg (_ctx :: TransformContext) -> do let tup = mkApps (Data tupDc) [Right lTy ,Right rTy @@ -509,34 +726,38 @@ ,Left bvArg ] - (changed (mkTicks tup ticks) :: NormalizeSession Term) - where - tupDc = fromMaybe (error "reduceNonRepPrim: faield to create tup DC") $ do - tupTc <- UniqMap.lookup tupTcNm tcm - listToMaybe (tyConDataCons tupTc) - _ -> return e - | argLen >= 3 - -> error ("reduceNonRepPrim: split# bad args" <> showPpr e) - "Clash.Sized.Internal.BitVector.eq#" - | (tmArgs,[nTy]) <- Either.partitionEithers args - , Right 0 <- runExcept (tyNatSize tcm nTy) - , TyConApp boolTcNm [] <- tv - -> abstractOverMissingArgs ticks tmArgs eTy c $ \(_kn :: Term) (_l :: Term) (_r :: Term) (_ctx :: TransformContext) -> do - let trueDc = fromMaybe (error "reduceNonRepPrim: failed to create True DC") $ do - boolTc <- UniqMap.lookup boolTcNm tcm - [_falseDc,dc] <- pure (tyConDataCons boolTc) - return dc - in (changed (Data trueDc) :: NormalizeSession Term) - _ -> return e - where - isUntranslatableType_not_poly t = do - u <- isUntranslatableType False t - if u - then return (null $ Lens.toListOf typeFreeVars t) - else return False + (changed (mkTicks tup primTicks) :: NormalizeSession Term) + where + tupDc = fromMaybe (error "reduceNonRepPrim: faield to create tup DC") $ do + tupTc <- UniqMap.lookup tupTcNm tyConMap + listToMaybe (tyConDataCons tupTc) + _ -> return originalTerm + | length primArguments >= 3 + = error ("reduceNonRepPrim: split# bad args" <> showPpr originalTerm) + | otherwise + = return originalTerm -reduceNonRepPrim _ e = return e -{-# SCC reduceNonRepPrim #-} +reduceEqHandler :: ReduceNonRepPrimHandler +reduceEqHandler ReduceNonRepPrimContext{..} + | (tmArgs,[nTy]) <- Either.partitionEithers primArguments + , Right 0 <- runExcept (tyNatSize tyConMap nTy) + , TyConApp boolTcNm [] <- resultTypeView + = abstractOverMissingArgs primTicks tmArgs termType transformContext $ + \(_kn :: Term) (_l :: Term) (_r :: Term) (_ctx :: TransformContext) -> + let trueDc = fromMaybe (error "reduceNonRepPrim: failed to create True DC") $ do + boolTc <- UniqMap.lookup boolTcNm tyConMap + [_falseDc,dc] <- pure (tyConDataCons boolTc) + return dc + in (changed (Data trueDc) :: NormalizeSession Term) + | otherwise + = return originalTerm + +isUntranslatableType_not_poly :: Type -> NormalizeSession Bool +isUntranslatableType_not_poly t = do + u <- isUntranslatableType False t + if u + then return (null $ Lens.toListOf typeFreeVars t) + else return False class AbstractOverMissingArgs a where -- | Abstract over a primitive until it is saturated diff --git a/src/Clash/Normalize/Transformations/Specialize.hs b/src/Clash/Normalize/Transformations/Specialize.hs --- a/src/Clash/Normalize/Transformations/Specialize.hs +++ b/src/Clash/Normalize/Transformations/Specialize.hs @@ -75,19 +75,18 @@ import Clash.Core.Util (listToLets) import Clash.Core.Var (Var(..), Id, TyVar, mkTyVar) import Clash.Core.VarEnv - ( InScopeSet, extendInScopeSet, extendInScopeSetList, lookupVarEnv - , mkInScopeSet, mkVarSet, unionInScope, elemVarSet) + ( InScopeSet, emptyVarEnv, extendInScopeSet, extendInScopeSetList + , lookupVarEnv, mkInScopeSet, mkVarSet, unionInScope, unitVarEnv, elemVarSet) import qualified Clash.Data.UniqMap as UniqMap import Clash.Debug (traceIf, traceM) import Clash.Driver.Types (Binding(..), TransformationInfo(..), hasTransformationInfo) -import Clash.Netlist.Util (representableType) import Clash.Rewrite.Combinators (topdownR) import Clash.Rewrite.Types - ( TransformContext(..), bindings, censor, curFun, customReprs, extra, tcCache - , typeTranslator, workFreeBinders, debugOpts, topEntities, specializationLimit) + ( TransformContext(..), bindings, censor, curFun, extra, tcCache + , workFreeBinders, debugOpts, topEntities, specializationLimit) import Clash.Rewrite.Util ( mkBinderFor, mkDerivedName, mkFunction, mkTmBinderFor, setChanged, changed - , normalizeTermTypes, normalizeId, whnfRW) + , isUntranslatableType, normalizeTermTypes, normalizeId, whnfRW) import Clash.Rewrite.WorkFree (isWorkFree) import Clash.Normalize.Types ( NormRewrite, NormalizeSession, specialisationCache, specialisationHistory) @@ -204,8 +203,14 @@ bndrs <- Lens.use bindings orM [pure (isVar arg), isWorkFree workFreeBinders bndrs arg] >>= \case True -> - let subst = extendIdSubst (mkSubst is0) v arg in - (`mkTicks` ticks) <$> go is0 (substTm "appProp.AppLam" subst e) args [] + -- 'e' is deshadowed w.r.t. an in-scope set that contains the free + -- variables of 'arg': 'appProp' deshadows the function expression + -- w.r.t. 'is0' up front, and 'go' re-deshadows whenever it extends the + -- in-scope set. So no binder in 'e' shadows 'v' — the binder of the + -- enclosing lambda -- nor captures a free variable of 'arg', which is + -- exactly the precondition of 'unsafeSubstTm'. + (`mkTicks` ticks) + <$> go is0 (unsafeSubstTm emptyVarEnv (unitVarEnv v arg) e) args [] False -> let is1 = extendInScopeSet is0 v in Let (NonRec v arg) <$> go is1 (deShadowTerm is1 e) args ticks @@ -608,11 +613,7 @@ = do tcm <- Lens.view tcCache let e2Ty = inferCoreTypeOf tcm e2 let localVar = isLocalVar e2 - nonRepE2 <- not <$> (representableType <$> Lens.view typeTranslator - <*> Lens.view customReprs - <*> pure False - <*> Lens.view tcCache - <*> pure e2Ty) + nonRepE2 <- isUntranslatableType False e2Ty if nonRepE2 && not localVar then do e2' <- inlineInternalSpecialisationArgument e2 diff --git a/src/Clash/Rewrite/Combinators.hs b/src/Clash/Rewrite/Combinators.hs --- a/src/Clash/Rewrite/Combinators.hs +++ b/src/Clash/Rewrite/Combinators.hs @@ -159,6 +159,29 @@ subtrees are rewritten. Rewrites that inspect let-bound context whose binding terms may have changed, for example through 'whnfRW', still need an outer repeat or a normal repeated top-down traversal. + +Note [topdownFixR is not for inlining bundles] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'topdownFixR' trades traversals for re-descents, and that trade is only a win +when rewrites are cheap and rarely fire at the same node twice. + +Whenever 'r' succeeds at a node, 'topdownFixR' re-descends into that node's +_entire_ subtree, because the rewrite may have restructured it. So one +'topdownFixR' costs + +> n + sum over nodes v of (times r fired at v) * size of subtree(v) + +node visits, where 'repeatR (topdownR r)' costs 'n' per round. 'topdownFixR' +wins when it saves enough rounds to pay for those re-descents. + +For bundles that inline (@inlineWorkFree@, @inlineSmall@, @inlineOrLiftNonRep@) +it loses: inlining replaces a small node by an arbitrarily large body, every +enclosing node tends to become rewritable in turn, and each of those rewrites +re-descends a subtree that just grew. Measured on +@tests/shouldwork/Basic/T1354B.hs@ (a deeply nested chain of function +compositions), using 'topdownFixR' for 'inlineAndPropagate' reaches exactly the +same fixed point but needs 1.57x the node visits, costing ~40% wall-clock. It +was ~3% slower on a larger industrial design we've measured too. See #3250. -} -- | Apply a transformation in a repeated top-down traversal. diff --git a/src/Clash/Rewrite/Types.hs b/src/Clash/Rewrite/Types.hs --- a/src/Clash/Rewrite/Types.hs +++ b/src/Clash/Rewrite/Types.hs @@ -2,7 +2,7 @@ Copyright : (C) 2012-2016, University of Twente, 2016 , Myrtle Software Ltd, 2017 , Google Inc., - 2021-2022, QBayLogic B.V. + 2021-2026, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -74,12 +74,14 @@ -- | State of a rewriting session data RewriteState extra = RewriteState - -- TODO Given we now keep transformCounters, this should just be 'fold' + -- TODO Given we now keep transformCounter, this should just be 'fold' -- over that map, otherwise the two counts could fall out of sync. { _transformCounter :: {-# UNPACK #-} !Word -- ^ Total number of applied transformations - , _transformCounters :: HashMap Text Word + , _transformAppliedCounters :: HashMap Text Word -- ^ Map that tracks how many times each transformation is applied + , _transformTriedCounters :: HashMap Text Word + -- ^ Map that tracks how many times each transformation has been tried , _bindings :: !BindingMap -- ^ Global binders , _uniqSupply :: !Supply @@ -92,6 +94,11 @@ -- ^ Used as a heap for compile-time evaluation of primitives that live in I/O , _workFreeBinders :: VarEnv Bool -- ^ Map telling whether a binder's definition is work-free + , _hwTypeCache :: HWMap + -- ^ Cache for the Core-type to HWType translation. The translation only + -- depends on environment that is constant for the whole rewrite session + -- (the type translator, custom representations, and the TyConMap), so the + -- cache never has to be invalidated. , _extra :: !extra -- ^ Additional state } diff --git a/src/Clash/Rewrite/Util.hs b/src/Clash/Rewrite/Util.hs --- a/src/Clash/Rewrite/Util.hs +++ b/src/Clash/Rewrite/Util.hs @@ -2,7 +2,7 @@ Copyright : (C) 2012-2016, University of Twente, 2016 , Myrtle Software Ltd, 2017 , Google Inc., - 2021-2023, QBayLogic B.V. + 2021-2026, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -26,7 +26,7 @@ import Control.DeepSeq import Control.Exception (throw) -import Control.Lens ((%=), (+=), (^.)) +import Control.Lens ((%=), (+=), (^.), Lens') import qualified Control.Lens as Lens import qualified Control.Monad as Monad import Control.Monad.IO.Class (liftIO) @@ -36,6 +36,7 @@ import Data.Bifunctor (second) import Data.Coerce (coerce) import Data.Functor.Const (Const (..)) +import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.List (group, partition, sort, sortOn) import qualified Data.List as List @@ -78,7 +79,8 @@ import Clash.Driver.Types (TransformationInfo(..), DebugOpts(..), BindingMap, Binding(..), IsPrim(..), ClashEnv(..), ClashOpts(..), hasDebugInfo, isDebugging) -import Clash.Netlist.Util (representableType) +import Clash.Netlist.Types (HWMap) +import Clash.Netlist.Util (representableTypeState) import Clash.Pretty (clashPretty, showDoc) import Clash.Rewrite.Types import Clash.Rewrite.WorkFree @@ -132,6 +134,16 @@ findDups :: [Id] -> [[Id]] findDups ids = filter ((1 <) . length) (group (sort ids)) +-- | Strictly bump a counter in 'RewriteState', typically 'transformTriedCounters' +-- or 'transformAppliedCounters'. +bumpCounter + :: String + -> Lens' (RewriteState extra) (HashMap Text Word) + -> RewriteMonad extra () +bumpCounter name l = do + counters <- Lens.use l + -- Note: Using $! to force thunks to prevent a gigantic pile of +1s in memory + Lens.assign l $! HashMap.insertWith (+) (Text.pack name) 1 counters -- | Record if a transformation is successfully applied apply @@ -196,8 +208,10 @@ go opts = traceIf (hasDebugInfo TryTerm name opts) ("Tried: " ++ name ++ " on:\n" ++ before) $ do nTrans <- pred <$> Lens.use transformCounter - Monad.when (dbg_countTransformations opts && hasChanged) $ do - transformCounters %= HashMap.insertWith (const succ) (Text.pack name) 1 + Monad.when (dbg_countTransformations opts) $ do + bumpCounter name transformTriedCounters + Monad.when hasChanged $ + bumpCounter name transformAppliedCounters Monad.when (dbg_invariants opts && hasChanged) $ do tcm <- Lens.view tcCache @@ -292,8 +306,15 @@ -> IO a runRewriteSession r s m = do (a, s', _) <- runR m r s + + let + triedTransformationsMessage = + ("Clash: Tried transformations:\n" ++ Text.unpack (showCounters (s' ^. transformTriedCounters))) + appliedTransformationsMessage = + ("Clash: Applied transformations:\n" ++ Text.unpack (showCounters (s' ^. transformAppliedCounters))) + traceIf (dbg_countTransformations (opt_debug (envOpts (_clashEnv r)))) - ("Clash: Transformations:\n" ++ Text.unpack (showCounters (s' ^. transformCounters))) $ + (triedTransformationsMessage ++ "\n" ++ appliedTransformationsMessage) $ traceIf (None < dbg_transformationInfo (opt_debug (envOpts (_clashEnv r)))) ("Clash: Applied " ++ show (s' ^. transformCounter) ++ " transformations") pure a @@ -360,15 +381,19 @@ :: (Term -> LetBinding -> RewriteMonad extra Bool) -- ^ Property test -> Rewrite extra -inlineBinders condition (TransformContext inScope0 _) expr@(Let (NonRec i x) res) = do - inline <- condition expr (i, x) +inlineBinders condition (TransformContext inScope0 _) expr@(Let (NonRec i x) res) + -- Substitution would be a no-op for a binder that does not occur in the + -- body, so the (potentially expensive) property test can be skipped. + | notElemFreeVars i res = changed res + | otherwise = do + inline <- condition expr (i, x) - if inline && elemFreeVars i res then - let inScope1 = extendInScopeSet inScope0 i - subst = extendIdSubst (mkSubst inScope1) i x - in changed (substTm "inlineBinders" subst res) - else - return expr + if inline then + let inScope1 = extendInScopeSet inScope0 i + subst = extendIdSubst (mkSubst inScope1) i x + in changed (substTm "inlineBinders" subst res) + else + return expr inlineBinders condition (TransformContext inScope0 _) expr@(Let (Rec xes) res) = do (toInline,toKeep) <- partitionM (condition expr) xes @@ -685,6 +710,15 @@ return (uniqAway' (`UniqMap.elem` binders) i (setUnique nm i)) {-# INLINE isUntranslatable #-} +-- | Run a Core-type to HWType translation action against the session-wide +-- translation cache ('hwTypeCache'). +runWithHWTypeCache :: State.State HWMap a -> RewriteMonad extra a +runWithHWTypeCache m = do + cache0 <- Lens.use hwTypeCache + let (a, !cache1) = State.runState m cache0 + hwTypeCache Lens..= cache1 + pure a + -- | Determine if a term cannot be represented in hardware isUntranslatable :: Bool @@ -693,11 +727,7 @@ -> RewriteMonad extra Bool isUntranslatable stringRepresentable tm = do tcm <- Lens.view tcCache - not <$> (representableType <$> Lens.view typeTranslator - <*> Lens.view customReprs - <*> pure stringRepresentable - <*> pure tcm - <*> pure (inferCoreTypeOf tcm tm)) + isUntranslatableType stringRepresentable (inferCoreTypeOf tcm tm) {-# INLINE isUntranslatableType #-} -- | Determine if a type cannot be represented in hardware @@ -706,12 +736,11 @@ -- ^ String representable -> Type -> RewriteMonad extra Bool -isUntranslatableType stringRepresentable ty = - not <$> (representableType <$> Lens.view typeTranslator - <*> Lens.view customReprs - <*> pure stringRepresentable - <*> Lens.view tcCache - <*> pure ty) +isUntranslatableType stringRepresentable ty = do + tt <- Lens.view typeTranslator + reprs <- Lens.view customReprs + tcm <- Lens.view tcCache + not <$> runWithHWTypeCache (representableTypeState tt reprs stringRepresentable tcm ty) normalizeTermTypes :: TyConMap -> Term -> Term normalizeTermTypes tcm e = case e of diff --git a/src/Clash/Util.hs b/src/Clash/Util.hs --- a/src/Clash/Util.hs +++ b/src/Clash/Util.hs @@ -11,6 +11,7 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskellQuotes #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -34,6 +35,7 @@ import Data.Maybe (fromMaybe, listToMaybe, catMaybes) import Data.Map.Ordered (OMap) import qualified Data.Map.Ordered as OMap +import qualified Data.Text as Text #if MIN_VERSION_prettyprinter(1,7,0) import Prettyprinter @@ -81,6 +83,12 @@ -- | Construct a string pattern match out of the given @TemplateHaskell@ name namePat :: TH.Name -> TH.Q TH.Pat namePat = return . TH.LitP . TH.StringL . show + +-- | Like 'Data.Text.pack', but used with a TemplateHaskell name. As a +-- TemplateHaskell expression itself to make sure GHC can optimize the call. +textNameLit :: TH.Name -> TH.Q TH.Exp +textNameLit nm = + TH.appE (TH.varE 'Text.pack) (TH.litE (TH.stringL (show nm))) assertPanic :: String -> Int -> a diff --git a/tests/Clash/Tests/Core/AlphaEquivalence.hs b/tests/Clash/Tests/Core/AlphaEquivalence.hs new file mode 100644 --- /dev/null +++ b/tests/Clash/Tests/Core/AlphaEquivalence.hs @@ -0,0 +1,366 @@ +{-| + Copyright : (C) 2026, QBayLogic B.V. + License : BSD2 (see the file LICENSE) + Maintainer : QBayLogic B.V. + + Tests for alpha equivalence, alpha comparison and alpha hashing of 'Term' and + 'Type' +-} + +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Clash.Tests.Core.AlphaEquivalence (tests) where + +import Data.Hashable (Hashable, hash) + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.TH (testGroupGenerator) + +import Clash.Core.HasFreeVars (freeVarsOf) +import Clash.Core.Name (NameSort (..)) +import Clash.Core.Subst (freshenTm) +import Clash.Core.Term (Term (..), NameMod (..), TickInfo (..)) +import Clash.Core.Type (Type (..)) +import Clash.Core.Var (Var (..)) +import Clash.Core.VarEnv (eltsVarSet, mkInScopeSet, mkVarSet) + +import Test.Clash.Rewrite (intTy, localId, parseToTermQQ, tyVar) + + +-- | Assert that two terms (or types) are alpha-equivalent, and that 'Ord' +-- agrees, in both directions. Their hashes have to agree as well: hashing +-- alpha-equivalent terms alike is the direction of the hash law that holds. +assertAlphaEqual :: (Ord a, Show a, Hashable a) => a -> a -> Assertion +assertAlphaEqual t1 t2 = do + t1 @=? t2 + t2 @=? t1 + EQ @=? compare t1 t2 + EQ @=? compare t2 t1 + hash t1 @=? hash t2 + +-- | Assert that two terms (or types) are not alpha-equivalent, and that 'Ord' +-- agrees. Also checks that comparison in the opposite direction yields the +-- opposite result, i.e. that the order is antisymmetric on this pair. +assertAlphaNotEqual :: (Ord a, Show a, Hashable a) => a -> a -> Assertion +assertAlphaNotEqual t1 t2 = do + assertBool "t1 /= t2" (t1 /= t2) + assertBool "t2 /= t1" (t2 /= t1) + case compare t1 t2 of + EQ -> assertFailure "compare == EQ" + LT -> GT @=? compare t2 t1 + GT -> LT @=? compare t2 t1 + + -- XXX: (a == b) `implies` (hash a == hash b), but not necessarily the other + -- way around. Still, chances of hitting a hash collision should be pretty + -- small. This test therefore serves as a sanity check to see whether the + -- generated hashes are chaotic enough. + -- + -- IF you ever encounter a hash collision here, you can safely remove it. + -- Still, it would then be a good idea to think about how we want to test + -- the "chaoticness" of the function. + assertBool + "If you see this read the TODO comment ^: hash t1 /= hash t2" + (hash t1 /= hash t2) + +case_arxiv_2105_02856_eq1 :: Assertion +case_arxiv_2105_02856_eq1 = assertAlphaEqual a b + where + a = [parseToTermQQ|let (x :: Int) = exp z in x + 7|] + b = [parseToTermQQ|let (y :: Int) = exp z in y + 7|] + +case_arxiv_2105_02856_eq2 :: Assertion +case_arxiv_2105_02856_eq2 = assertAlphaEqual a b + where + a = [parseToTermQQ|\(x :: Int) -> x + 7|] + b = [parseToTermQQ|\(y :: Int) -> y + 7|] + +case_arxiv_2105_02856_eq3 :: Assertion +case_arxiv_2105_02856_eq3 = assertAlphaEqual a b + where + a = [parseToTermQQ|\(x :: Int) -> x + y|] + b = [parseToTermQQ|\(p :: Int) -> p + y|] + +case_arxiv_2105_02856_eq4 :: Assertion +case_arxiv_2105_02856_eq4 = assertAlphaEqual a b + where + a = [parseToTermQQ|let (bar :: Int) = x + 1 in bar * y|] + b = [parseToTermQQ|let (pub :: Int) = x + 1 in pub * y|] + +case_arxiv_2105_02856_eq5 :: Assertion +case_arxiv_2105_02856_eq5 = assertAlphaEqual a b + where + a = [parseToTermQQ|\(x :: Int) -> x + t|] + b = [parseToTermQQ|\(x :: Int) -> x + t|] + +case_arxiv_2105_02856_neq1 :: Assertion +case_arxiv_2105_02856_neq1 = assertAlphaNotEqual a b + where + a = [parseToTermQQ|\(x :: Int) -> x + y|] + b = [parseToTermQQ|\(q :: INt) -> q + z|] + +case_arxiv_2105_02856_neq2 :: Assertion +case_arxiv_2105_02856_neq2 = assertAlphaNotEqual a b + where + a = [parseToTermQQ|(x :: Int) + 2|] + b = [parseToTermQQ|(y :: INt) + 2|] + +case_arxiv_2105_02856_neq3 :: Assertion +case_arxiv_2105_02856_neq3 = assertAlphaNotEqual a b + where + a = [parseToTermQQ|let (x :: Int) = e1 in let (y :: Int) = e2 in x + y|] + b = [parseToTermQQ|let (y :: Int) = e2 in let (x :: Int) = e1 in x + y|] + +case_shadowing_1 :: Assertion +case_shadowing_1 = do + assertAlphaEqual a a + assertAlphaEqual a b + assertAlphaEqual a c + + assertAlphaEqual b a + assertAlphaEqual b b + assertAlphaEqual b c + + assertAlphaEqual c a + assertAlphaEqual c b + assertAlphaEqual c c + + assertAlphaNotEqual d a + assertAlphaNotEqual d b + assertAlphaNotEqual d c + + assertAlphaNotEqual a d + assertAlphaNotEqual b d + assertAlphaNotEqual c d + where + -- EQ: + a = [parseToTermQQ|\(x :: Int) -> \(x :: Int) -> x|] + b = [parseToTermQQ|\(x :: Int) -> \(y :: Int) -> y|] + c = [parseToTermQQ|\(a :: Int) -> \(b :: Int) -> b|] + + -- NEQ: + d = [parseToTermQQ|\(x :: Int) -> \(y :: Int) -> x|] + +case_shadowing_2 :: Assertion +case_shadowing_2 = do + assertAlphaEqual a a + assertAlphaEqual a b + assertAlphaEqual a c + + assertAlphaEqual b a + assertAlphaEqual b b + assertAlphaEqual b c + + assertAlphaEqual c a + assertAlphaEqual c b + assertAlphaEqual c c + + assertAlphaNotEqual d a + assertAlphaNotEqual d b + assertAlphaNotEqual d c + + assertAlphaNotEqual a d + assertAlphaNotEqual b d + assertAlphaNotEqual c d + where + -- EQ: + a = [parseToTermQQ|\(x :: Int) -> x + (\(x :: Int) -> x * 2) 5|] + b = [parseToTermQQ|\(x :: Int) -> x + (\(y :: Int) -> y * 2) 5|] + c = [parseToTermQQ|\(a :: Int) -> a + (\(b :: Int) -> b * 2) 5|] + + -- NEQ: + d = [parseToTermQQ|\(x :: Int) -> x + (\(y :: Int) -> x * 2) 5|] + +case_shadowing_3 :: Assertion +case_shadowing_3 = assertAlphaNotEqual a b + where + a = [parseToTermQQ|let (x :: Int) = 10 in let (x :: Int) = x + 5 in x * 2|] + b = [parseToTermQQ|let (y :: Int) = 10 in let (z :: Int) = y + 5 in z * 2|] + +case_captureFreeVar :: Assertion +case_captureFreeVar = assertAlphaNotEqual a b + where + a = [parseToTermQQ|\(x :: Int) -> x + y|] + b = [parseToTermQQ|\(y :: Int) -> y + y|] + +-- | Free variables are compared by unique alone: their human readable names +-- are irrelevant. +case_freeVarsCompareByUnique :: Assertion +case_freeVarsCompareByUnique = do + assertAlphaEqual a b + assertAlphaNotEqual a c + where + a = [parseToTermQQ|x_1 + y|] + b = [parseToTermQQ|q_1 + y|] + c = [parseToTermQQ|x_2 + y|] + +-- | A bound variable is never equal to a free variable, even if the free +-- variable has the same unique as the binder on the other side. +case_boundVersusFree :: Assertion +case_boundVersusFree = assertAlphaNotEqual a b + where + a = [parseToTermQQ|\(x_1 :: Int) -> x_1|] + b = [parseToTermQQ|\(y_2 :: Int) -> x_1|] + +-- | Renaming a binder such that it captures a free variable of the other term +-- does not make the terms equal, even when uniques line up exactly. +case_captureWithExplicitUniques :: Assertion +case_captureWithExplicitUniques = assertAlphaNotEqual a b + where + a = [parseToTermQQ|\(z_5 :: Int) -> y_2|] + b = [parseToTermQQ|\(y_2 :: Int) -> y_2|] + +-- | Swapping binder names consistently is fine, but swapping the references +-- without swapping the binders is not. +case_binderSwap :: Assertion +case_binderSwap = do + assertAlphaEqual a b + assertAlphaNotEqual a c + where + a = [parseToTermQQ|\(x :: Int) -> \(y :: Int) -> x + y|] + b = [parseToTermQQ|\(y :: Int) -> \(x :: Int) -> y + x|] + c = [parseToTermQQ|\(x :: Int) -> \(y :: Int) -> y + x|] + +-- | Lambda binders must have alpha-equivalent types. +case_lambdaBinderTypeSignificant :: Assertion +case_lambdaBinderTypeSignificant = assertAlphaNotEqual a b + where + a = [parseToTermQQ|\(x :: Int) -> x|] + b = [parseToTermQQ|\(x :: Bool) -> x|] + +-- | An inner binder may shadow an outer binder by unique; references resolve +-- to the innermost one. +case_sameUniqueShadowing :: Assertion +case_sameUniqueShadowing = assertAlphaEqual a b + where + a = [parseToTermQQ|\(x_1 :: Int) -> \(y_1 :: Int) -> y_1|] + b = [parseToTermQQ|\(p_2 :: Int) -> \(q_3 :: Int) -> q_3|] + +-- | Mutually recursive bindings can be renamed, but the binding a body refers +-- to is significant. +case_letrecMutualRecursion :: Assertion +case_letrecMutualRecursion = do + assertAlphaEqual a b + assertAlphaNotEqual a c + where + a = [parseToTermQQ|let { (x :: Int) = y; (y :: Int) = x } in x|] + b = [parseToTermQQ|let { (p :: Int) = q; (q :: Int) = p } in p|] + c = [parseToTermQQ|let { (p :: Int) = q; (q :: Int) = p } in q|] + +-- | Letrecs with a different number of bindings are never equal; in +-- particular the positional comparison must not silently drop the extra +-- binding. +case_letrecBindingCountSignificant :: Assertion +case_letrecBindingCountSignificant = assertAlphaNotEqual a b + where + a = [parseToTermQQ|let { (x :: Int) = 1 } in x|] + b = [parseToTermQQ|let { (x :: Int) = 1; (y :: Int) = 1 } in x|] + +-- | A letrec binder's type is significant, even when the right-hand sides +-- agree. Unlike a @NonRec@ binder, whose type its right-hand side pins down, a +-- letrec binder may occur in its own right-hand side, and then it does not: +-- @let x = x@ is the same term whether @x@ is an @Int@ or a @Bool@. +case_letrecBinderTypeSignificant :: Assertion +case_letrecBinderTypeSignificant = assertAlphaNotEqual a b + where + a = [parseToTermQQ|let (x :: Int) = 5 in x|] + b = [parseToTermQQ|let (x :: Bool) = 5 in x|] + +-- | Self-referencing letrec bindings can be renamed like any other binding. +case_letrecSelfReference :: Assertion +case_letrecSelfReference = assertAlphaEqual a b + where + a = [parseToTermQQ|let (x_1 :: Int) = x_1 in x_1|] + b = [parseToTermQQ|let (y_2 :: Int) = y_2 in y_2|] + +-- | Terms built from different constructors are never equal, even when they +-- would evaluate to the same value. +case_differentConstructors :: Assertion +case_differentConstructors = assertAlphaNotEqual a b + where + a = [parseToTermQQ|\(x :: Int) -> x|] + b = [parseToTermQQ|let (x :: Int) = x in x|] + +-- | The Core in 'Attributes' lives in the scope enclosing the tick, so it is +-- compared under the enclosing renaming environment. Judging it in an empty +-- environment would compare an occurrence of a bound variable by its raw +-- unique, making these two unequal. +case_tickAttributesSeesEnclosingBinders :: Assertion +case_tickAttributesSeesEnclosingBinders = assertAlphaEqual a b + where + a = attributed (localId User "x" 100 intTy) + b = attributed (localId User "y" 200 intTy) + attributed v = Lam v (Tick (Attributes intTy (Var v)) (Var v)) + +-- | Free variables in 'Attributes' are still significant: only binders are +-- renamed away. +case_tickAttributesDistinguishesFreeVars :: Assertion +case_tickAttributesDistinguishesFreeVars = assertAlphaNotEqual a b + where + x = localId User "x" 100 intTy + a = attributed x + b = attributed (localId User "y" 200 intTy) + attributed v = Lam x (Tick (Attributes intTy (Var v)) (Var x)) + +-- | The 'Type' in 'NameMod' lives in the scope enclosing the tick, so it is +-- compared under the enclosing renaming environment, just like the 'Term' in +-- 'Attributes'. This is the shape @Clash.GHC.GHC2Core.nameModTerm@ builds for +-- @prefixName@ and friends: +-- @/\\nm. \\x -> Tick (NameMod PrefixName (VarTy nm)) x@. +case_tickNameModSeesEnclosingBinders :: Assertion +case_tickNameModSeesEnclosingBinders = assertAlphaEqual a b + where + a = nameModTerm (tyVar User "nm" 300) + b = nameModTerm (tyVar User "nm" 400) + x = localId User "x" 100 intTy + nameModTerm tv = + TyLam tv (Lam x (Tick (NameMod PrefixName (VarTy tv)) (Var x))) + +-- | 'freshenTm' gives every binder a fresh unique. The Core in 'Attributes' +-- lives in the scope enclosing the tick, so an occurrence of the binder inside +-- it has to be renamed along with the body; leaving it alone turns it into a +-- free variable pointing at the old unique. +case_freshenTmRenamesInsideAttributes :: Assertion +case_freshenTmRenamesInsideAttributes = + case freshened of + Lam x' (Tick (Attributes _ (Var attributed)) _) -> do + assertBool "binder was freshened" (varUniq x' /= varUniq x) + varUniq x' @=? varUniq attributed + [] @=? eltsVarSet (freeVarsOf freshened) + other -> assertFailure ("unexpected shape: " <> show other) + where + x = localId User "x" 100 intTy + term = Lam x (Tick (Attributes intTy (Var x)) (Var x)) + -- 'x' is already in scope, so 'freshenTm' has to rename the binder + (_, freshened) = freshenTm (mkInScopeSet (mkVarSet [x])) term + +-- | The type of the outermost lambda binder of a term. 'parseToTermQQ' parses a +-- 'Term', so this is how a test gets its hands on a 'Type'. +binderType :: Term -> Type +binderType = \case + Lam i _ -> varType i + t -> error ("binderType: not a lambda: " <> show t) + +-- | Regression test: comparison of 'ForAllTy' binders is antisymmetric, i.e. +-- swapping the arguments flips the 'Ordering' rather than yielding 'LT' both +-- ways. 'assertAlphaNotEqual' checks both directions. +case_forAllTyAntisymmetric :: Assertion +case_forAllTyAntisymmetric = assertAlphaNotEqual t1 t2 + where + t1 = binderType [parseToTermQQ|\(v :: forall a_3 b_2. b_2) -> v|] + t2 = binderType [parseToTermQQ|\(v :: forall c_1 d_4. c_1) -> v|] + +-- | Regression test: comparison of 'Lam' binders is antisymmetric, i.e. +-- swapping the arguments flips the 'Ordering' rather than yielding 'LT' both +-- ways. 'assertAlphaNotEqual' checks both directions. +case_lamAntisymmetric :: Assertion +case_lamAntisymmetric = assertAlphaNotEqual a b + where + a = [parseToTermQQ|\(x_3 :: Int) -> \(y_2 :: Int) -> y_2|] + b = [parseToTermQQ|\(p_1 :: Int) -> \(q_4 :: Int) -> p_1|] + +tests :: TestTree +tests = $(testGroupGenerator) diff --git a/tests/Clash/Tests/Core/StructuralEquivalence.hs b/tests/Clash/Tests/Core/StructuralEquivalence.hs new file mode 100644 --- /dev/null +++ b/tests/Clash/Tests/Core/StructuralEquivalence.hs @@ -0,0 +1,188 @@ +{-| + Copyright : (C) 2026, QBayLogic B.V. + License : BSD2 (see the file LICENSE) + Maintainer : QBayLogic B.V. + + Tests for structural equality and comparison of 'Type' +-} + +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Clash.Tests.Core.StructuralEquivalence (tests) where + +import Data.Text (Text) + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.TH (testGroupGenerator) + +import Clash.Core.Name (NameSort (..), mkUnsafeName) +import Clash.Core.Subst (eqType, eqVar, ordType) +import Clash.Core.Type (Kind, LitTy (..), Type (..)) +import Clash.Core.TysPrim (liftedTypeKind) +import Clash.Core.Var (TyVar, Var (..)) +import Clash.Unique (Unique) + +import Test.Clash.Rewrite (intTy, parseTyConTy) + +-- | A 'TyVar' with the given human readable name, unique and kind. Unlike +-- 'Test.Clash.Rewrite.tyVar', whose kind is always 'liftedTypeKind'. +kindedTyVar :: Text -> Unique -> Kind -> TyVar +kindedTyVar nm uniq kind = TyVar (mkUnsafeName User nm uniq) uniq kind + +-- | The kind variable @(~)@ and @Coercible@ bind, i.e. @mkAlphaTyVarUnique 0@ +kindVarK :: TyVar +kindVarK = kindedTyVar "k" 0 liftedTypeKind + +-- | @(,)@'s second type variable, @b :: Type@ +bLifted :: TyVar +bLifted = kindedTyVar "b" 2 liftedTypeKind + +-- | @(~)@'s second type variable, @b :: k@. GHC gives it the same unique as +-- 'bLifted': both are @mkAlphaTyVarUnique 2@. +bKinded :: TyVar +bKinded = kindedTyVar "b" 2 (VarTy kindVarK) + +boolTy :: Type +boolTy = parseTyConTy "Bool" + +-- | Assert that two types are structurally equal, and that 'ordType' agrees, +-- in both directions. +assertEqualTy :: Type -> Type -> Assertion +assertEqualTy t1 t2 = do + assertBool "eqType t1 t2" (eqType t1 t2) + assertBool "eqType t2 t1" (eqType t2 t1) + EQ @=? ordType t1 t2 + EQ @=? ordType t2 t1 + +-- | Assert that two types are not structurally equal, and that 'ordType' +-- agrees. Also checks that comparison in the opposite direction yields the +-- opposite result, i.e. that the order is antisymmetric on this pair. +assertNotEqualTy :: Type -> Type -> Assertion +assertNotEqualTy t1 t2 = do + assertBool "not (eqType t1 t2)" (not (eqType t1 t2)) + assertBool "not (eqType t2 t1)" (not (eqType t2 t1)) + case ordType t1 t2 of + EQ -> assertFailure "ordType t1 t2 == EQ" + LT -> GT @=? ordType t2 t1 + GT -> LT @=? ordType t2 t1 + +-- | Regression test for #3361: type variables that share a unique but not a +-- kind are not structurally equal. +case_tyVarKindSignificant :: Assertion +case_tyVarKindSignificant = do + assertNotEqualTy (VarTy bLifted) (VarTy bKinded) + assertBool "not (eqVar bLifted bKinded)" (not (eqVar bLifted bKinded)) + -- The 'Eq' instance on 'Var' is exactly what is too coarse here: it only + -- compares uniques (and scope), which is why 'eqVar' exists. + assertBool "bLifted == bKinded" (bLifted == bKinded) + +-- | The kind of a 'ForAllTy' binder is significant. See +-- 'case_tyVarKindSignificant'. +case_forAllTyBinderKindSignificant :: Assertion +case_forAllTyBinderKindSignificant = + assertNotEqualTy (ForAllTy bLifted intTy) (ForAllTy bKinded intTy) + +-- | A kind difference nested inside a type is found too. See +-- 'case_tyVarKindSignificant'. +case_nestedTyVarKindSignificant :: Assertion +case_nestedTyVarKindSignificant = + assertNotEqualTy (AppTy intTy (VarTy bLifted)) (AppTy intTy (VarTy bKinded)) + +-- | Type variables agreeing on unique /and/ kind are structurally equal. +case_tyVarSameKindEqual :: Assertion +case_tyVarSameKindEqual = + assertEqualTy (VarTy bLifted) (VarTy (kindedTyVar "b" 2 liftedTypeKind)) + +-- | Type variables that differ only in their human readable name are not +-- structurally equal either. +-- +-- GHC really does produce such pairs. Its template variables are numbered from +-- zero per wired-in construct, so the alpha uniques are reused wholesale: +-- @(~)@'s @k@ and @(~~)@'s @k0@ are both @mkAlphaTyVarUnique 0@ kinded 'Type', +-- and differ in nothing but their name. +case_tyVarNameSignificant :: Assertion +case_tyVarNameSignificant = + assertNotEqualTy (VarTy kindVarK) (VarTy (kindedTyVar "k0" 0 liftedTypeKind)) + +-- | Structural equality is finer than alpha equivalence: alpha-equivalent +-- types whose binders have different uniques are not structurally equal. +case_structuralIsFinerThanAlpha :: Assertion +case_structuralIsFinerThanAlpha = do + -- @Eq Type@ is alpha equivalence + t1 @=? t2 + assertNotEqualTy t1 t2 + where + t1 = ForAllTy a (VarTy a) + t2 = ForAllTy b (VarTy b) + a = kindedTyVar "a" 1 liftedTypeKind + b = kindedTyVar "b" 2 liftedTypeKind + +-- | At least one type per 'Type' constructor, plus the pairs that only differ +-- in a nested detail, so that the 'ordType' laws below are exercised on +-- types that compare equal as well as on types that don't. +representativeTypes :: [Type] +representativeTypes = + [ VarTy bLifted + , VarTy bKinded + , VarTy (kindedTyVar "b'" 2 liftedTypeKind) + , VarTy (kindedTyVar "c" 3 liftedTypeKind) + , intTy + , boolTy + , LitTy (NumTy 5) + , LitTy (NumTy 6) + , LitTy (SymTy "sym") + , LitTy (CharTy 'c') + , AppTy intTy boolTy + , AppTy boolTy intTy + , ForAllTy bLifted intTy + , ForAllTy bKinded intTy + , ForAllTy bLifted boolTy + , AnnType [] intTy + ] + +-- | 'ordType' yields 'EQ' exactly when 'eqType' holds. +case_ordTypeAgreesWithEqType :: Assertion +case_ordTypeAgreesWithEqType = + sequence_ + [ assertEqual (show (t1, t2)) (eqType t1 t2) (ordType t1 t2 == EQ) + | t1 <- representativeTypes + , t2 <- representativeTypes + ] + +-- | Swapping 'ordType''s arguments flips the 'Ordering'. +case_ordTypeAntisymmetric :: Assertion +case_ordTypeAntisymmetric = + sequence_ + [ assertEqual (show (t1, t2)) (flipOrdering (ordType t1 t2)) (ordType t2 t1) + | t1 <- representativeTypes + , t2 <- representativeTypes + ] + where + flipOrdering = \case + LT -> GT + EQ -> EQ + GT -> LT + +-- | 'ordType' is reflexive. +case_ordTypeReflexive :: Assertion +case_ordTypeReflexive = + sequence_ + [ assertEqual (show t) EQ (ordType t t) | t <- representativeTypes ] + +-- | 'ordType' is transitive. +case_ordTypeTransitive :: Assertion +case_ordTypeTransitive = + sequence_ + [ assertBool (show (t1, t2, t3)) (ordType t1 t3 /= GT) + | t1 <- representativeTypes + , t2 <- representativeTypes + , t3 <- representativeTypes + , ordType t1 t2 /= GT + , ordType t2 t3 /= GT + ] + +tests :: TestTree +tests = $(testGroupGenerator) diff --git a/tests/Clash/Tests/Core/Subst.hs b/tests/Clash/Tests/Core/Subst.hs --- a/tests/Clash/Tests/Core/Subst.hs +++ b/tests/Clash/Tests/Core/Subst.hs @@ -12,12 +12,12 @@ import Test.Tasty import Test.Tasty.HUnit -import Clash.Core.Name (Name(..), NameSort(..)) -import Clash.Core.Term (Term(Var)) +import Clash.Core.Name (Name(..), NameSort(..), OccName) +import Clash.Core.Term (Bind(..), Pat(..), Term(..)) import Clash.Core.Type (ConstTy(..), Type(ConstTy)) import Clash.Core.Subst import Clash.Core.VarEnv -import Clash.Core.Var (IdScope(..), Var(..)) +import Clash.Core.Var (Id, IdScope(..), Var(..)) import Clash.Unique (Unique) fakeName :: Name a @@ -32,21 +32,75 @@ unique :: Unique unique = 20 -termVar :: Var Term -termVar = Id { - varName = fakeName {nameUniq=unique, nameOcc="term"} - , varUniq = unique +mkTestId :: IdScope -> OccName -> Unique -> Id +mkTestId scope occ uniq = Id { + varName = fakeName {nameUniq=uniq, nameOcc=occ} + , varUniq = uniq , varType = ConstTy (TyCon fakeName) - , idScope = LocalId + , idScope = scope } +termVar :: Var Term +termVar = mkTestId LocalId "term" unique + term1 :: Term term1 = Var termVar +fakeType :: Type +fakeType = ConstTy (TyCon fakeName) + +localX, localY, localZ, localW, globalG :: Id +localX = mkTestId LocalId "x" 21 +localY = mkTestId LocalId "y" 22 +localZ = mkTestId LocalId "z" 23 +localW = mkTestId LocalId "w" 24 +globalG = mkTestId GlobalId "g" 25 + +-- | The term substituted for 'localX' in the 'unsafeSubstTm' tests +payload :: Term +payload = Var localY + +-- | Deshadowed w.r.t. an in-scope set holding 'localX' and 'localY', so it +-- satisfies 'unsafeSubstTm's precondition for substituting 'localX' +deshadowedTerm :: Term +deshadowedTerm = + Lam localZ + (Let (NonRec localW (Var localX)) + (Case (Var localW) fakeType + [(DefaultPat, App (Var localX) (Var localZ))])) + tests :: TestTree tests = testGroup "Clash.Tests.Core.Subst" [ testCase "deShadow type/term" $ term1 @=? deShadowTerm (extendInScopeSet emptyInScopeSet termVar) term1 + + , testCase "unsafeSubstTm substitutes a local variable" $ + App payload (Var localZ) @=? + unsafeSubstTm emptyVarEnv (unitVarEnv localX payload) + (App (Var localX) (Var localZ)) + + , testCase "unsafeSubstTm leaves unmatched variables alone" $ + Var localZ @=? + unsafeSubstTm emptyVarEnv (unitVarEnv localX payload) (Var localZ) + + , testCase "unsafeSubstTm looks globals up in the global substitution" $ do + payload @=? unsafeSubstTm (unitVarEnv globalG payload) emptyVarEnv + (Var globalG) + -- A global is never looked up in the local substitution, nor the other + -- way around + Var globalG @=? unsafeSubstTm emptyVarEnv (unitVarEnv globalG payload) + (Var globalG) + Var localX @=? unsafeSubstTm (unitVarEnv localX payload) emptyVarEnv + (Var localX) + + , testCase "unsafeSubstTm agrees with substTm on a deshadowed term" $ + let + is = extendInScopeSetList emptyInScopeSet [localX, localY] + subst = extendIdSubst (mkSubst is) localX payload + in + substTm "unsafeSubstTm test" subst deshadowedTerm @=? + unsafeSubstTm emptyVarEnv (unitVarEnv localX payload) + deshadowedTerm ] diff --git a/tests/Test/Clash/Rewrite.hs b/tests/Test/Clash/Rewrite.hs --- a/tests/Test/Clash/Rewrite.hs +++ b/tests/Test/Clash/Rewrite.hs @@ -1,5 +1,5 @@ {-| - Copyright : (C) 2020,2022 QBayLogic B.V. + Copyright : (C) 2020,2022-2026 QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -20,6 +20,7 @@ import qualified Clash.Core.Term as C import qualified Clash.Core.Literal as C import qualified Clash.Core.Type as C +import qualified Clash.Core.TysPrim as C import qualified Clash.Core.Var as C import Clash.Core.VarEnv (InScopeSet, emptyVarSet, emptyVarEnv, emptyInScopeSet) import Clash.Driver.Types (ClashEnv(..), ClashOpts(..), defClashOpts, debugSilent) @@ -31,13 +32,23 @@ import Clash.Unique (Unique) import Control.Applicative ((<|>)) +import Control.DeepSeq (NFData, force) +import Control.Exception (ErrorCall (..), evaluate, try) +import Data.Char (isAscii, ord) import Data.Default +import Data.Maybe (fromMaybe) import Language.Haskell.Exts.Syntax -import Language.Haskell.Exts.Parser (parseExp, fromParseResult) +import Language.Haskell.Exts.Extension (Extension (..), KnownExtension (..)) +import Language.Haskell.Exts.Parser + (ParseMode (..), defaultParseMode, fromParseResult, parseExpWithMode) import System.IO.Unsafe (unsafePerformIO) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, assertEqual, assertFailure, testCase) import Text.Read (readMaybe) import GHC.Stack (HasCallStack) +import qualified Text.Show.Pretty as Pretty + import qualified Language.Haskell.TH.Syntax as TH import qualified Language.Haskell.TH.Quote as TH @@ -77,12 +88,14 @@ instance Default extra => Default (RewriteState extra) where def = RewriteState { _transformCounter=0 - , _transformCounters=mempty + , _transformAppliedCounters=mempty + , _transformTriedCounters=mempty , _bindings=emptyVarEnv , _uniqSupply=unsafePerformIO newSupply , _curFun=error "_curFun: NYI" , _nameCounter=2 , _workFreeBinders=emptyVarEnv + , _hwTypeCache=mempty , _globalHeap=error "_globalHeap: NYI" , _extra=def } @@ -129,95 +142,297 @@ runSingleTransformationDef = runSingleTransformation def def def -parseType :: Show l => Type l -> C.Type +parseType :: (HasCallStack, Show l) => Type l -> C.Type parseType = \case + -- Parentheses: (..) + TyParen _ t -> + parseType t + -- Type constructor: T - TyCon _ (UnQual _ (Ident _ typNm)) -> + TyCon _ (UnQual _ nm) -> -- TODO: We could/should build a TyConMap here - C.ConstTy (C.TyCon (C.Name C.User (Text.pack typNm) 0 C.noSrcSpan)) + C.ConstTy (C.TyCon (parseName nm)) + -- Type variable: a + TyVar _ nm -> + C.VarTy (parseTyVar nm) + + -- Universal quantification: forall a b. t + TyForall _ (Just tvs) Nothing t -> + foldr (C.ForAllTy . parseTyVarBind) (parseType t) tvs + + -- Type application: f a + TyApp _ t1 t2 -> + C.AppTy (parseType t1) (parseType t2) + -- Unsupported type: t -> error ("parseType: " <> show t) --- | Parse an identifier into a Clash Name. Identifiers must include a unique --- and might include a modifier indicating whether its NameSort. Examples: +-- | Parse an identifier into a 'C.TyVar'. Type variables are always of kind +-- 'liftedTypeKind': there is no way to spell out anything else, and nothing in +-- these tests needs one. See 'parseNameScope' for the format of identifiers. +parseTyVar :: (HasCallStack, Show l) => Name l -> C.TyVar +parseTyVar nm0 = C.TyVar nm1 (C.nameUniq nm1) C.liftedTypeKind + where + nm1 = parseName nm0 + +-- | Parse the binder of a @forall@ into a 'C.TyVar'. See 'parseTyVar'. +parseTyVarBind :: (HasCallStack, Show l) => TyVarBind l -> C.TyVar +parseTyVarBind = \case + UnkindedVar _ nm -> parseTyVar nm + + -- A kind annotation would have to name a kind, and 'parseTyVar' only produces + -- 'liftedTypeKind' anyway + b -> error ("parseTyVarBind: " <> show b) + +-- | Derive a 'Unique' from a human readable name, by interpreting each of its +-- characters as a byte and concatenating those bytes. Used for identifiers that +-- don't spell out their unique, see 'parseName'. -- --- * x_3: User identifier with human readable name "x", unique "3" --- * x_I3: Internal identifier with human readable name "x", unique "3" --- * x_S3: System identifier with human readable name "x", unique "3" +-- Only ASCII names of at most four characters are supported, as a 'Unique' is +-- only guaranteed to hold 32 bits. +nameToUnique :: HasCallStack => String -> Unique +nameToUnique nm + | null nm = error + "nameToUnique: can't derive a unique from an empty name" + | length nm > 4 = error [I.i| + Can't derive a unique from '#{nm}': a 'Unique' is only guaranteed to hold + 32 bits, so names of more than four characters don't fit. Spell out the + unique instead, e.g. '#{nm}_123'. + |] + | any (not . isAscii) nm = error [I.i| + Can't derive a unique from '#{nm}': it contains non-ASCII characters. + Spell out the unique instead, e.g. 'foobar_123'. + |] + | otherwise = List.foldl' (\acc c -> acc * 256 + fromIntegral (ord c)) 0 nm + +-- | Parse an identifier into a Clash Name and an 'C.IdScope'. Identifiers might +-- include a unique, and might include modifiers indicating their 'C.NameSort' +-- and 'C.IdScope'. Examples: -- -parseName :: Show l => Name l -> C.Name a -parseName = \case - Ident _ s -> failOnNothing s (go "" s) - Symbol _ s -> failOnNothing s (go "" s) +-- * x_3: User, local identifier with human readable name "x", unique "3" +-- * x_I3: Internal, local identifier with human readable name "x", unique "3" +-- * x_S3: System, local identifier with human readable name "x", unique "3" +-- * x_G3: User, global identifier with human readable name "x", unique "3" +-- +-- * x: User, local identifier with human readable name "x", unique derived from "x" +-- * x_U: User, local identifier with human readable name "x", unique derived from "x" +-- * x_S: System, local identifier with human readable name "x", unique derived from "x" +-- * x_G: User, global identifier with human readable name "x", unique derived from "x" +-- +-- Modifiers may be combined, in any order: 'x_SG3' and 'x_GS3' both denote a +-- System, global identifier with unique "3". Identifiers that don't spell out +-- their unique derive it from their human readable name, see 'nameToUnique'. +-- +-- Identifiers default to 'C.User' and 'C.LocalId'. +-- +parseNameScope :: (HasCallStack, Show l) => Name l -> (C.Name a, C.IdScope) +parseNameScope = \case + Ident _ s -> mkName s + Symbol _ s -> mkName s where - failOnNothing _ (Just (nmSort, nm, uniq)) = - C.mkUnsafeName nmSort (Text.pack nm) uniq - failOnNothing s Nothing = error [I.i| - Not a valid id: #{s}. Identifiers must be of form 'foobar_123', where - 'foobar' is a human-readable (but ultimately unused) name and '123' is the - unique. Additionally, 'I', 'U', or 'S' might be prefixed to create an - Internal, User, or System name respectively. For example, 'foobar_S123'. - |] + mkName s = case go "" s of + Just (nmSort, scope, nm, uniq) -> + ( C.mkUnsafeName nmSort (Text.pack nm) (fromMaybe (nameToUnique nm) uniq) + , scope ) + -- No '_'-delimited suffix at all: the whole identifier is the name + Nothing -> + (C.mkUnsafeName C.User (Text.pack s) (nameToUnique s), C.LocalId) go _seen "" = Nothing - go seen0 ('_':s:ss) - | 'U' <- s = fmap (C.User,seen1,) (readMaybe ss) <|> cont - | 'S' <- s = fmap (C.System,seen1,) (readMaybe ss) <|> cont - | 'I' <- s = fmap (C.Internal,seen1,) (readMaybe ss) <|> cont - | otherwise = fmap (C.User,seen1,) (readMaybe (s:ss)) <|> cont + go seen0 ('_':s:ss) = fmap withName (parseSuffix (s:ss)) <|> cont where - seen1 = reverse seen0 + withName (nmSort, scope, uniq) = (nmSort, scope, reverse seen0, uniq) cont = go ('_':seen0) (s:ss) go seen (s:ss) = go (s:seen) ss --- | Parse declarations (as, amongst others, used in let expressions). Note that --- every binder needs an explicit type annotation, as we don't do any type --- inference. Type annotations may occur anywhere though. Example, this is OK: + -- Parse a suffix such as "3", "S", or "SG3": zero or more modifiers followed + -- by an optional unique. Yields 'Nothing' if the suffix is malformed, in which + -- case it is considered part of the human readable name. + parseSuffix = goSuffix C.User C.LocalId + where + goSuffix nmSort scope = \case + 'U':ss -> goSuffix C.User scope ss + 'S':ss -> goSuffix C.System scope ss + 'I':ss -> goSuffix C.Internal scope ss + 'G':ss -> goSuffix nmSort C.GlobalId ss + 'L':ss -> goSuffix nmSort C.LocalId ss + -- Modifiers are either followed by a unique, or end the identifier + "" -> Just (nmSort, scope, Nothing) + ss -> fmap ((nmSort,scope,) . Just) (readMaybe ss) + +-- | Parse an identifier into a Clash Name, ignoring any scope modifier. See +-- 'parseNameScope'. +parseName :: (HasCallStack, Show l) => Name l -> C.Name a +parseName = fst . parseNameScope + +-- | Parse an identifier into an 'C.Id' of the given type. See 'parseNameScope'. +parseIdWithType :: (HasCallStack, Show l) => C.Type -> Name l -> C.Id +parseIdWithType typ nm0 = C.Id nm1 (C.nameUniq nm1) typ scope + where + (nm1, scope) = parseNameScope nm0 + +-- | Parse an identifier into an 'C.Id', looking its type up in the given +-- 'TypeMap'. Fails if the identifier's type wasn't declared. See +-- 'parseIdWithType'. +parseId :: (HasCallStack, Show l) => TypeMap -> Name l -> C.Id +parseId typs nm0 = C.Id nm1 uniq (lookupTM uniq typs) scope + where + (nm1, scope) = parseNameScope nm0 + uniq = C.nameUniq nm1 + +-- | Type given to free variables, i.e. to variables that aren't bound anywhere +-- in the term and don't spell out their type. There's nothing to infer such a +-- type from, and it is irrelevant to most tests - notably, alpha equivalence +-- compares free variables by unique alone. -- +-- Note that this only applies to /references/: binders always need their type +-- declared, see 'parsePats'. +freeVarType :: C.Type +freeVarType = + C.ConstTy (C.TyCon (C.Name C.Internal (Text.pack "FreeVar") 0 C.noSrcSpan)) + +-- | Parse a reference to a variable, looking its type up in the given 'TypeMap'. +-- References that aren't in it are free variables, and get 'freeVarType'. +parseVarRef :: (HasCallStack, Show l) => TypeMap -> Name l -> C.Id +parseVarRef typs nm0 = C.Id nm1 uniq typ scope + where + (nm1, scope) = parseNameScope nm0 + uniq = C.nameUniq nm1 + typ = fromMaybe freeVarType (HashMap.lookup uniq typs) + +-- | Parse the operator of an infix application into a variable reference +parseOp :: (HasCallStack, Show l) => TypeMap -> QOp l -> C.Term +parseOp typs = \case + -- Operator: `f` or + + QVarOp _ (UnQual _ nm) -> + C.Var (parseVarRef typs nm) + + -- Unsupported operator: + o -> + error ("parseOp: " <> show o) + +-- | Parse binder patterns, as used by let bindings and lambdas. Note that every +-- binder needs an explicit type annotation, as we don't do any type inference. +-- The annotation may be spelled out in the pattern itself, or declared in an +-- enclosing let. I.e., all of these are OK: +-- +-- \(x_0 :: Int) -> x_0 +-- -- let +-- (x_0 :: Int) = 2 +-- in +-- x_0 +-- +-- let -- x_0 :: Int -- x_0 = 2 --- --- x_1 :: Int --- x_1 = x_0 -- in --- x_1 +-- \x_0 -> x_0 -- -- But this is not: -- -- let --- x_0 :: Int -- x_0 = 2 --- --- x_1 = x_0 -- in --- x_1 +-- x_0 -- +-- Binders are added to the type map, so the scope they bind can refer to them +-- without repeating their type. +parsePats + :: forall l + . (HasCallStack, Show l) + => TypeMap + -> [Pat l] + -> (TypeMap, [C.Id]) +parsePats = List.mapAccumL parsePat + where + parsePat :: HasCallStack => TypeMap -> Pat l -> (TypeMap, C.Id) + parsePat typs = \case + -- Parentheses: (...) + PParen _ p -> + parsePat typs p + + -- Binder with type signature: x :: t + PatTypeSig _ (PVar _ nm) (parseType -> t) -> + let i = parseIdWithType t nm + in (HashMap.insert (C.varUniq i) t typs, i) + + -- Binder: x + PVar _ nm -> + (typs, parseId typs nm) + + -- Unsupported pattern + p -> + error ("parsePat: " <> show p) + +-- | Parse lambda binders. Like 'parsePats', except that a binder annotated with +-- the kind @Type@ binds a /type/ variable rather than a term variable: +-- +-- \\(a :: Type) (x :: a) -> x +-- +-- is @/\\a. \\x. x@, a 'C.TyLam' around a 'C.Lam'. Haskell has no syntax for a +-- type lambda, and @\\ \@a -> e@ is not something @haskell-src-exts@ parses, so +-- the kind annotation is what marks one here. +-- +-- Type binders are not added to the type map: it maps a term variable to its +-- type, and a reference to a type variable is parsed by 'parseType', which needs +-- no context. See 'parseTyVar'. +parseLamPats + :: forall l + . (HasCallStack, Show l) + => TypeMap + -> [Pat l] + -> (TypeMap, [Either C.TyVar C.Id]) +parseLamPats = List.mapAccumL parseLamPat + where + parseLamPat + :: HasCallStack => TypeMap -> Pat l -> (TypeMap, Either C.TyVar C.Id) + parseLamPat typs pat + | Just nm <- typeBinder pat = (typs, Left (parseTyVar nm)) + | otherwise = fmap Right (head' (parsePats typs [pat])) + where + head' (typs1, [i]) = (typs1, i) + head' _ = error "parseLamPats: impossible" + + -- A binder annotated with the kind 'Type', modulo parentheses + typeBinder :: Pat l -> Maybe (Name l) + typeBinder = \case + PParen _ p -> typeBinder p + PatTypeSig _ (PVar _ nm) (TyCon _ (UnQual _ (Ident _ "Type"))) -> Just nm + _ -> Nothing + +-- | Parse declarations (as, amongst others, used in let expressions). See +-- 'parsePats' for how binders get their type. +-- +-- The type map returned includes the types of all binders declared here, so it +-- can be used to parse the body of the let these declarations belong to. parseDecls :: forall l . (HasCallStack, Show l) => TypeMap -> [Decl l] -> (TypeMap, [C.LetBinding]) -parseDecls typs0 decls = (typs1, map parseOtherDecl otherDecls) +parseDecls typs0 decls = (typs2, zip ids (map (expToTerm typs2) rhss)) where (typDecls, otherDecls) = List.partition isTypeDecl decls + + -- Types declared by separate type signatures insertTyp (nm, t) = HashMap.insert nm t typs1 = foldr insertTyp typs0 (concatMap parseTypeDecl typDecls) - parseOtherDecl :: HasCallStack => Decl l -> C.LetBinding - parseOtherDecl = \case - PatBind _ (PVar _ (parseName -> nm)) (UnGuardedRhs _ e) Nothing -> - let - uniq = C.nameUniq nm - typ = lookupTM (C.nameUniq nm) typs1 - in - (C.Id nm uniq typ C.LocalId, expToTerm typs1 e) - e -> - error ("parseOtherDecl: " <> show e) + -- Binders, plus the types they declare in their patterns. Note that all + -- right-hand sides are parsed with the /final/ type map, so bindings may refer + -- to each other irrespective of the order they're declared in. + (typs2, ids) = parsePats typs1 pats + (pats, rhss) = unzip (map splitOtherDecl otherDecls) + splitOtherDecl :: HasCallStack => Decl l -> (Pat l, Exp l) + splitOtherDecl = \case + PatBind _ p (UnGuardedRhs _ e) Nothing -> (p, e) + d -> error ("splitOtherDecl: " <> show d) + parseTypeDecl :: Decl l -> [(Unique, C.Type)] parseTypeDecl (TypeSig _ nms t) = map (\nm -> (C.nameUniq (parseName nm), parseType t)) nms @@ -239,22 +454,35 @@ Paren _ e -> expToTerm typs0 e - -- Local variable reference with type signature: x :: t - ExpTypeSig _ (Var _ (UnQual _ (parseName -> nm))) (parseType -> t) -> - C.Var (C.Id nm (C.nameUniq nm) t C.LocalId) + -- Variable reference with type signature: x :: t + ExpTypeSig _ (Var _ (UnQual _ nm)) (parseType -> t) -> + C.Var (parseIdWithType t nm) + -- Type application: e @t + App _ e1 (TypeApp _ t) -> + C.TyApp (expToTerm typs0 e1) (parseType t) + -- Term application: e1 e2 App _ e1 e2 -> C.App (expToTerm typs0 e1) (expToTerm typs0 e2) - -- Variable reference: e - Var _ (UnQual _ (parseName -> nm)) -> + -- Infix application: e1 + e2 + InfixApp _ e1 op e2 -> + C.App (C.App (parseOp typs0 op) (expToTerm typs0 e1)) (expToTerm typs0 e2) + + -- Lambda: \x y -> e. A binder annotated @:: Type@ binds a type variable, so + -- it becomes a 'C.TyLam': @\\(a :: Type) (x :: a) -> x@ is @/\\a. \\x. x@. + Lambda _ pats body0 -> let - uniq = C.nameUniq nm - typ = lookupTM (C.nameUniq nm) typs0 + (typs1, binders) = parseLamPats typs0 pats + body1 = expToTerm typs1 body0 in - C.Var (C.Id nm uniq typ C.LocalId) + foldr (either C.TyLam C.Lam) body1 binders + -- Variable reference: e + Var _ (UnQual _ nm) -> + C.Var (parseVarRef typs0 nm) + -- Literal: 3 Lit _ (Int _ i _) -> C.Literal (C.IntLiteral i) @@ -269,12 +497,27 @@ -- Unsupported expression e -> error ("expToTerm: " <> show e) +-- | Parse mode used by 'parseToTerm'. Enables: +-- +-- * @ScopedTypeVariables@, so lambda binders can spell out their type: +-- @\\(x_0 :: Int) -> x_0@, and so a type binder can spell out its kind: +-- @\\(a :: Type) -> ..@, see 'parseLamPats'. +-- * @RankNTypes@, for @forall@ in a type: @(x :: forall a. a)@. +-- * @TypeApplications@, for type application: @f \@Int@. +termParseMode :: ParseMode +termParseMode = defaultParseMode + { extensions = + map EnableExtension [ScopedTypeVariables, RankNTypes, TypeApplications] + <> extensions defaultParseMode + } + -- | Parse a string representing a Haskell expression into Clash Core. This can -- only parse very simple expressions. In the future we should make an effort to -- build a proper TyConMap (using LoadModules) to faithfully reproduce more -- complex expressions. -parseToTerm :: String -> C.Term -parseToTerm = expToTerm HashMap.empty . fromParseResult . parseExp +parseToTerm :: HasCallStack => String -> C.Term +parseToTerm = + expToTerm HashMap.empty . fromParseResult . parseExpWithMode termParseMode -- | See documentation of 'parseToTerm'. Example usage: -- @@ -299,3 +542,320 @@ , TH.quoteType = error "parseToTerm.quoteType: NYI" , TH.quoteDec = error "parseToTerm.quoteDec: NYI" } + +-- | The type 'parseType' produces for a type constructor whose name it derives +-- a unique from, e.g. @Int@ +parseTyConTy :: HasCallStack => String -> C.Type +parseTyConTy nm = + C.ConstTy + (C.TyCon (C.Name C.User (Text.pack nm) (nameToUnique nm) C.noSrcSpan)) + +-- | The type 'parseType' produces for the type constructor @Int@ +intTy :: C.Type +intTy = parseTyConTy "Int" + +-- | An 'C.Id' with the given scope, name sort, human readable name, unique, and +-- type +mkId :: C.IdScope -> C.NameSort -> String -> Unique -> C.Type -> C.Id +mkId scope nmSort nm uniq typ = + C.Id (C.mkUnsafeName nmSort (Text.pack nm) uniq) uniq typ scope + +-- | A local 'C.Id'. See 'mkId'. +localId :: C.NameSort -> String -> Unique -> C.Type -> C.Id +localId = mkId C.LocalId + +-- | A 'C.TyVar' with the given name sort, human readable name, and unique. Its +-- kind is 'C.liftedTypeKind', see 'parseTyVar'. +tyVar :: C.NameSort -> String -> Unique -> C.TyVar +tyVar nmSort nm uniq = + C.TyVar (C.mkUnsafeName nmSort (Text.pack nm) uniq) uniq C.liftedTypeKind + +-- | A reference to a local variable of type @Int@. See 'localId'. +intVar :: C.NameSort -> String -> Unique -> C.Term +intVar nmSort nm uniq = C.Var (localId nmSort nm uniq intTy) + +-- | A reference to a global variable of type @Int@. See 'mkId'. +globalIntVar :: C.NameSort -> String -> Unique -> C.Term +globalIntVar nmSort nm uniq = C.Var (mkId C.GlobalId nmSort nm uniq intTy) + +-- | A reference to a variable without a declared type. See 'freeVarType'. +freeVar :: C.NameSort -> String -> Unique -> C.Term +freeVar nmSort nm uniq = C.Var (localId nmSort nm uniq freeVarType) + +-- | Assert that two terms are structurally equal, by comparing their 'Show' +-- output. +-- +-- Note that we deliberately use neither '==' nor 'Clash.Core.Subst.eqTerm': +-- 'Eq' on 'C.Term' is alpha equivalence, and both compare names by their unique +-- alone, so they'd ignore a name's sort ('C.User', 'C.System', 'C.Internal') +-- and human readable name. 'Show' is derived everywhere, so it shows all of it. +assertStructurallyEqual :: (HasCallStack, Show a) => a -> a -> Assertion +assertStructurallyEqual expected actual = + assertEqual "" (Pretty.ppShow expected) (Pretty.ppShow actual) + +-- | Assert that forcing a value throws an 'ErrorCall' mentioning the given +-- substring +assertErrorContains + :: (HasCallStack, NFData a, Show a) => String -> a -> Assertion +assertErrorContains needle a = do + parsed <- try (evaluate (force a)) + case parsed of + Left (ErrorCall msg) + | needle `List.isInfixOf` msg -> pure () + | otherwise -> assertFailure + ("Expected an error mentioning '" <> needle <> "', but got:\n" <> msg) + Right parsed1 -> assertFailure + ("Expected an error mentioning '" <> needle + <> "', but parsing succeeded:\n" <> Pretty.ppShow parsed1) + +tests :: TestTree +tests = testGroup "Test.Clash.Rewrite" + [ testGroup "parseToTerm" + [ testCase "literal" $ + assertStructurallyEqual + (C.Literal (C.IntLiteral 3)) + (parseToTerm "3") + + , testCase "variable" $ + assertStructurallyEqual + (intVar C.User "x" 3) + (parseToTerm "x_3 :: Int") + + , testCase "parentheses" $ + assertStructurallyEqual + (intVar C.User "x" 3) + (parseToTerm "((x_3 :: Int))") + + , testCase "application" $ + assertStructurallyEqual + (C.App (intVar C.User "f" 0) (intVar C.User "x" 1)) + (parseToTerm "(f_0 :: Int) (x_1 :: Int)") + + , testCase "let" $ + assertStructurallyEqual + (C.Letrec + [ (localId C.User "x" 0 intTy, C.Literal (C.IntLiteral 5)) + , (localId C.User "x" 1 intTy, intVar C.User "x" 0) + ] + (intVar C.User "x" 1)) + (parseToTerm "let { x_0, x_1 :: Int; x_0 = 5; x_1 = x_0 } in x_1") + + , testCase "let with an inline type annotation" $ + assertStructurallyEqual + (C.Letrec + [(localId C.User "x" 0 intTy, C.Literal (C.IntLiteral 5))] + (intVar C.User "x" 0)) + (parseToTerm "let { (x_0 :: Int) = 5 } in x_0") + + -- Bindings may refer to each other regardless of the order they're + -- declared in, so their types have to be collected up front + , testCase "let with a forward reference" $ + assertStructurallyEqual + (C.Letrec + [ (localId C.User "x" 0 intTy, intVar C.User "y" 1) + , (localId C.User "y" 1 intTy, C.Literal (C.IntLiteral 5)) + ] + (intVar C.User "x" 0)) + (parseToTerm "let { (x_0 :: Int) = y_1; (y_1 :: Int) = 5 } in x_0") + + , testCase "let without a type annotation" $ + assertErrorContains "forgot to (explicitely) declare" + (parseToTerm "let { x_0 = 5 } in x_0") + + -- 0x2b == ord '+' + , testCase "infix application" $ + assertStructurallyEqual + (C.App + (C.App (freeVar C.User "+" 0x2b) (intVar C.User "x" 0)) + (intVar C.User "y" 1)) + (parseToTerm "(x_0 :: Int) + (y_1 :: Int)") + + , testCase "infix application of a named function" $ + assertStructurallyEqual + (C.App + (C.App (freeVar C.User "add" 2) (intVar C.User "x" 0)) + (intVar C.User "y" 1)) + (parseToTerm "(x_0 :: Int) `add_2` (y_1 :: Int)") + + , testCase "free variable" $ + assertStructurallyEqual + (C.App (freeVar C.User "f" 0) (intVar C.User "x" 1)) + (parseToTerm "f_0 (x_1 :: Int)") + + , testCase "lambda" $ + assertStructurallyEqual + (C.Lam (localId C.User "x" 0 intTy) (intVar C.User "x" 0)) + (parseToTerm "\\(x_0 :: Int) -> x_0") + + , testCase "lambda with multiple binders" $ + assertStructurallyEqual + (C.Lam (localId C.User "x" 0 intTy) + (C.Lam (localId C.User "y" 1 intTy) (intVar C.User "y" 1))) + (parseToTerm "\\(x_0 :: Int) (y_1 :: Int) -> y_1") + + , testCase "lambda with a modified binder" $ + assertStructurallyEqual + (C.Lam (localId C.System "x" 0 intTy) (intVar C.System "x" 0)) + (parseToTerm "\\(x_S0 :: Int) -> x_S0") + + , testCase "lambda application" $ + assertStructurallyEqual + (C.App + (C.Lam (localId C.User "x" 0 intTy) (intVar C.User "x" 0)) + (intVar C.User "y" 1)) + (parseToTerm "(\\(x_0 :: Int) -> x_0) (y_1 :: Int)") + + , testCase "lambda binder typed by an enclosing let" $ + assertStructurallyEqual + (C.Letrec + [(localId C.User "x" 0 intTy, C.Literal (C.IntLiteral 5))] + (C.Lam (localId C.User "y" 1 intTy) (intVar C.User "x" 0))) + (parseToTerm "let { x_0, y_1 :: Int; x_0 = 5 } in \\y_1 -> x_0") + + , testCase "lambda without a type annotation" $ + assertErrorContains "forgot to (explicitely) declare" + (parseToTerm "\\x_0 -> x_0") + + , testCase "type lambda" $ + assertStructurallyEqual + (C.TyLam (tyVar C.User "a" 0) + (C.Lam (localId C.User "x" 1 (C.VarTy (tyVar C.User "a" 0))) + (C.Var (localId C.User "x" 1 (C.VarTy (tyVar C.User "a" 0)))))) + (parseToTerm "\\(a_0 :: Type) (x_1 :: a_0) -> x_1") + + , testCase "type application" $ + assertStructurallyEqual + (C.TyApp (freeVar C.User "f" 0) intTy) + (parseToTerm "f_0 @Int") + + , testCase "forall" $ + assertStructurallyEqual + (C.Lam + (localId C.User "v" 0 + (C.ForAllTy (tyVar C.User "a" 1) + (C.ForAllTy (tyVar C.User "b" 2) + (C.VarTy (tyVar C.User "b" 2))))) + (C.Var + (localId C.User "v" 0 + (C.ForAllTy (tyVar C.User "a" 1) + (C.ForAllTy (tyVar C.User "b" 2) + (C.VarTy (tyVar C.User "b" 2))))))) + (parseToTerm "\\(v_0 :: forall a_1 b_2. b_2) -> v_0") + + , testCase "type application of a type constructor" $ + let maybeInt = + C.AppTy + (C.ConstTy + (C.TyCon + (C.Name C.User (Text.pack "Maybe") 9 C.noSrcSpan))) + intTy + in assertStructurallyEqual + (C.Lam + (localId C.User "v" 0 maybeInt) + (C.Var (localId C.User "v" 0 maybeInt))) + (parseToTerm "\\(v_0 :: Maybe_9 Int) -> v_0") + ] + + , testGroup "parseNameScope" + [ testCase "explicit unique" $ + assertStructurallyEqual + (intVar C.User "x" 3) + (parseToTerm "x_3 :: Int") + + , testCase "explicit unique, user" $ + assertStructurallyEqual + (intVar C.User "x" 3) + (parseToTerm "x_U3 :: Int") + + , testCase "explicit unique, system" $ + assertStructurallyEqual + (intVar C.System "x" 3) + (parseToTerm "x_S3 :: Int") + + , testCase "explicit unique, internal" $ + assertStructurallyEqual + (intVar C.Internal "x" 3) + (parseToTerm "x_I3 :: Int") + + -- 0x78 == ord 'x' + , testCase "derived unique" $ + assertStructurallyEqual + (intVar C.User "x" 0x78) + (parseToTerm "x :: Int") + + , testCase "derived unique, user" $ + assertStructurallyEqual + (intVar C.User "x" 0x78) + (parseToTerm "x_U :: Int") + + , testCase "derived unique, system" $ + assertStructurallyEqual + (intVar C.System "x" 0x78) + (parseToTerm "x_S :: Int") + + , testCase "derived unique, internal" $ + assertStructurallyEqual + (intVar C.Internal "x" 0x78) + (parseToTerm "x_I :: Int") + + , testCase "derived unique, four characters" $ + assertStructurallyEqual + (intVar C.User "abcd" 0x61626364) + (parseToTerm "abcd :: Int") + + , testCase "derived unique, four characters and a modifier" $ + assertStructurallyEqual + (intVar C.System "abcd" 0x61626364) + (parseToTerm "abcd_S :: Int") + + , testCase "name containing an underscore" $ + assertStructurallyEqual + (intVar C.User "foo_bar" 3) + (parseToTerm "foo_bar_3 :: Int") + + , testCase "explicit scope, local" $ + assertStructurallyEqual + (intVar C.User "x" 3) + (parseToTerm "x_L3 :: Int") + + , testCase "explicit scope, global" $ + assertStructurallyEqual + (globalIntVar C.User "x" 3) + (parseToTerm "x_G3 :: Int") + + , testCase "explicit scope, derived unique" $ + assertStructurallyEqual + (globalIntVar C.User "x" 0x78) + (parseToTerm "x_G :: Int") + + , testCase "explicit scope and name sort" $ + assertStructurallyEqual + (globalIntVar C.System "x" 3) + (parseToTerm "x_SG3 :: Int") + + , testCase "explicit scope and name sort, reversed" $ + assertStructurallyEqual + (globalIntVar C.System "x" 3) + (parseToTerm "x_GS3 :: Int") + + , testCase "explicit scope and name sort, derived unique" $ + assertStructurallyEqual + (globalIntVar C.Internal "x" 0x78) + (parseToTerm "x_IG :: Int") + + , testCase "explicit scope on a let binder" $ + assertStructurallyEqual + (C.Letrec + [(mkId C.GlobalId C.User "x" 0 intTy, C.Literal (C.IntLiteral 5))] + (globalIntVar C.User "x" 0)) + (parseToTerm "let { x_G0 :: Int; x_G0 = 5 } in x_G0") + + , testCase "name too long to derive a unique from" $ + assertErrorContains "names of more than four characters don't fit" + (parseToTerm "abcde :: Int") + + , testCase "name too long to derive a unique from, with a modifier" $ + assertErrorContains "names of more than four characters don't fit" + (parseToTerm "abcde_S :: Int") + ] + ] diff --git a/tests/unittests.hs b/tests/unittests.hs --- a/tests/unittests.hs +++ b/tests/unittests.hs @@ -3,13 +3,16 @@ import Test.Tasty import Test.Tasty.QuickCheck +import qualified Clash.Tests.Core.AlphaEquivalence import qualified Clash.Tests.Core.FreeVars +import qualified Clash.Tests.Core.StructuralEquivalence import qualified Clash.Tests.Core.Subst import qualified Clash.Tests.Core.TermLiteral import qualified Clash.Tests.Driver.Manifest import qualified Clash.Tests.Netlist.Id import qualified Clash.Tests.Normalize.Transformations import qualified Clash.Tests.Util.Interpolate +import qualified Test.Clash.Rewrite -- AFAIK there's no good way to override the default, so we just detect the -- default value and change it. @@ -19,13 +22,16 @@ tests :: TestTree tests = testGroup "Unittests" - [ Clash.Tests.Core.FreeVars.tests + [ Clash.Tests.Core.AlphaEquivalence.tests + , Clash.Tests.Core.FreeVars.tests + , Clash.Tests.Core.StructuralEquivalence.tests , Clash.Tests.Core.Subst.tests , Clash.Tests.Core.TermLiteral.tests , Clash.Tests.Driver.Manifest.tests , Clash.Tests.Netlist.Id.tests , Clash.Tests.Normalize.Transformations.tests , Clash.Tests.Util.Interpolate.tests + , Test.Clash.Rewrite.tests ] main :: IO ()