clash-lib 1.2.0 → 1.2.1

raw patch · 39 files changed

+1700/−1289 lines, 39 filesdep ~basedep ~clash-preludedep ~extraPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, clash-prelude, extra, time

API changes (from Hackage documentation)

Files

• CHANGELOG.md +18/−0
• clash-lib.cabal +12/−7
• prims/common/Clash_Signal_Trace.json +67/−0
• prims/common/Clash_Sized_Internal_Unsigned.json +24/−0
• prims/commonverilog/Clash_Sized_Internal_BitVector.json +6/−6
• prims/systemverilog/Clash_Sized_Internal_BitVector.json +7/−6
• prims/verilog/Clash_Sized_Internal_BitVector.json +7/−6
• prims/vhdl/Clash_Explicit_BlockRam.json +7/−5
• prims/vhdl/Clash_Sized_Internal_BitVector.json +14/−13
• prims/vhdl/Clash_Sized_RTree.json +2/−2
• src/Clash/Backend/SystemVerilog.hs +3/−1
• src/Clash/Backend/VHDL.hs +371/−261
• src/Clash/Backend/Verilog.hs +292/−95
• src/Clash/Core/EqSolver.hs +159/−0
• src/Clash/Core/Evaluator.hs +2/−1
• src/Clash/Core/Pretty.hs +2/−1
• src/Clash/Core/Subst.hs +65/−3
• src/Clash/Core/Term.hs +95/−17
• src/Clash/Core/TermInfo.hs +230/−0
• src/Clash/Core/Type.hs +14/−7
• src/Clash/Core/Util.hs +9/−535
• src/Clash/Core/VarEnv.hs +4/−2
• src/Clash/Debug.hs +31/−0
• src/Clash/Driver.hs +8/−7
• src/Clash/Driver/Types.hs +1/−1
• src/Clash/Netlist.hs +6/−4
• src/Clash/Netlist/BlackBox.hs +29/−9
• src/Clash/Netlist/BlackBox/Util.hs +1/−0
• src/Clash/Netlist/Util.hs +24/−20
• src/Clash/Normalize.hs +5/−4
• src/Clash/Normalize/DEC.hs +8/−7
• src/Clash/Normalize/PrimitiveReductions.hs +4/−3
• src/Clash/Normalize/Transformations.hs +29/−38
• src/Clash/Normalize/Util.hs +7/−7
• src/Clash/Rewrite/Combinators.hs +1/−2
• src/Clash/Rewrite/Util.hs +4/−5
• src/Clash/Util.hs +13/−214
• src/Data/List/Extra.hs +110/−0
• src/Data/Semigroup/Monad/Extra.hs +9/−0

@@ -1,5 +1,23 @@ # Changelog for the Clash project +## 1.2.1 *April 23rd 2020*+* Changed:+ * Treat `Signed 0`, `Unsigned 0`, `Index 1`, `BitVector 0` as unit. In effect this means that 'minBound' and 'maxBound' return 0, whereas previously they might crash [#1183](https://github.com/clash-lang/clash-compiler/issues/1183)+ * Infix use of `deepseqX` is now right-associative++* Added:+  * Add 'natToInteger', 'natToNatural', and 'natToNum'. Similar to 'snatTo*', but works solely on a type argument instead of an SNat.+  * `Clash.Sized.Vector.unfoldr` and `Clash.Sized.Vector.unfoldrI` to construct vectors from a seed value+  * Added NFDataX instances for `Data.Monoid.{First,Last}`++* Fixed:+ * The Verilog backend can now deal with non-contiguous ranges in custom bit-representations.+ * Synthesizing BitPack instances for type with phantom parameter fails [#1242](https://github.com/clash-lang/clash-compiler/issues/1242)+ * Synthesis of `fromBNat (toBNat d5)` failed due to `unsafeCoerce` coercing from `Any`+ * Memory leak in register primitives [#1256](https://github.com/clash-lang/clash-compiler/issues/1256)+ * Illegal VHDL slice when projecting nested SOP type [#1254](https://github.com/clash-lang/clash-compiler/issues/1254)+ * Vivado VHDL code path (`-fclash-hdlsyn Vivado`) generates illegal VHDL [#1264](https://github.com/clash-lang/clash-compiler/issues/1264)+ ## 1.2.0 *March 5th 2020* As promised when releasing 1.0, we've tried our best to keep the API stable. We think most designs will continue to compile with this new version, although special

@@ -1,6 +1,6 @@ Cabal-version:        2.2 Name:                 clash-lib-Version:              1.2.0+Version:              1.2.1 Synopsis:             CAES Language for Synchronous Hardware - As a Library Description:   Clash is a functional hardware description language that borrows both its@@ -120,7 +120,7 @@   import:             common-options   HS-Source-Dirs:     src -  ghc-options:        -Wall+  ghc-options:        -Wall -Wcompat   CPP-Options:        -DCABAL    other-extensions:   CPP@@ -138,10 +138,10 @@   Build-depends:      aeson                   >= 0.6.2.0  && < 1.5,                       ansi-terminal           >= 0.8.0.0  && < 0.11,                       attoparsec              >= 0.10.4.0 && < 0.14,-                      base                    >= 4.10     && < 5,+                      base                    >= 4.11     && < 5,                       binary                  >= 0.8.5    && < 0.11,                       bytestring              >= 0.10.0.2 && < 0.11,-                      clash-prelude           == 1.2.0,+                      clash-prelude           == 1.2.1,                       concurrent-supply       >= 0.1.7    && < 0.2,                       containers              >= 0.5.0.0  && < 0.7,                       data-binary-ieee754     >= 0.4.4    && < 0.6,@@ -151,7 +151,7 @@                       directory               >= 1.2.0.1  && < 1.4,                       errors                  >= 1.4.2    && < 2.4,                       exceptions              >= 0.8.3    && < 0.11.0,-                      extra                   >= 1.6.18   && < 1.7,+                      extra                   >= 1.6.18   && < 1.8,                       filepath                >= 1.3.0.1  && < 1.5,                       ghc                     >= 8.4.0    && < 8.9,                       ghc-boot-th,@@ -172,7 +172,7 @@                       temporary               >= 1.2.1    && < 1.4,                       text                    >= 1.2.2    && < 1.3,                       text-show               >= 3.7      && < 3.9,-                      time                    >= 1.4.0.1  && < 1.10,+                      time                    >= 1.4.0.1  && < 1.11,                       transformers            >= 0.5.2.0  && < 0.6,                       trifecta                >= 1.7.1.1  && < 2.2,                       vector                  >= 0.11     && < 1.0,@@ -189,6 +189,7 @@                       Clash.Backend.VHDL                        Clash.Core.DataCon+                      Clash.Core.EqSolver                       Clash.Core.Evaluator                       Clash.Core.Evaluator.Types                       Clash.Core.FreeVars@@ -197,6 +198,7 @@                       Clash.Core.Pretty                       Clash.Core.Subst                       Clash.Core.Term+                      Clash.Core.TermInfo                       Clash.Core.TermLiteral                       Clash.Core.TermLiteral.TH                       Clash.Core.TyCon@@ -206,6 +208,8 @@                       Clash.Core.Var                       Clash.Core.VarEnv +                      Clash.Debug+                       Clash.Driver                       Clash.Driver.Types @@ -246,6 +250,7 @@                       Clash.Util.Interpolate                       Clash.Pretty +                      Data.List.Extra                       Data.Text.Prettyprint.Doc.Extra    Other-Modules:      Clash.Annotations.TopEntity.Extra@@ -268,7 +273,7 @@   type:             exitcode-stdio-1.0   default-language: Haskell2010   main-is:          unittests.hs-  ghc-options:      -Wall+  ghc-options:      -Wall -Wcompat   hs-source-dirs:   tests    if !flag(unittests)

@@ -0,0 +1,67 @@+[ { "BlackBox" :+    { "name"      : "Clash.Signal.Trace.traceSignal1"+    , "workInfo"  : "Never"+    , "kind"      : "Expression"+    , "type"      :+"traceSignal1+  :: ( BitPack a    -- ARG[0]+     , NFDataX a    -- ARG[1]+     , Typeable a ) -- ARG[2]+  => String         -- ARG[3]+  -> Signal dom a   -- ARG[4]+  -> Signal dom a"+    , "template" : "~ARG[4]"+    }+  }+, { "BlackBox" :+    { "name"      : "Clash.Signal.Trace.traceVecSignal1"+    , "workInfo"  : "Never"+    , "kind"      : "Expression"+    , "type"      :+"traceVecSignal1+  :: ( KnownNat n             -- ARG[0]+     , BitPack a              -- ARG[1]+     , NFDataX a              -- ARG[2]+     , Typeable a )           -- ARG[3]+  => String                   -- ARG[4]+  -> Signal dom (Vec (n+1) a) -- ARG[5]+  -> Signal dom (Vec (n+1) a)"+    , "template" : "~ARG[5]"+    }+  }+, { "BlackBox" :+    { "name"      : "Clash.Signal.Trace.traceSignal"+    , "workInfo"  : "Never"+    , "kind"      : "Expression"+    , "type"      :+"traceSignal+  :: forall dom a+   . ( KnownDomain dom -- ARG[0]+     , BitPack a       -- ARG[1]+     , NFDataX a       -- ARG[2]+     , Typeable a )    -- ARG[3]+  => String            -- ARG[4]+  -> Signal dom a      -- ARG[5]+  -> Signal dom a"+    , "template" : "~ARG[5]"+    }+  }+, { "BlackBox" :+    { "name"      : "Clash.Signal.Trace.traceVecSignal"+    , "workInfo"  : "Never"+    , "kind"      : "Expression"+    , "type"      :+"traceVecSignal+  :: forall dom a n+   . ( KnownDomain dom        -- ARG[0]+     , KnownNat n             -- ARG[1]+     , BitPack a              -- ARG[2]+     , NFDataX a              -- ARG[3]+     , Typeable a )           -- ARG[4]+  => String                   -- ARG[5]+  -> Signal dom (Vec (n+1) a) -- ARG[6]+  -> Signal dom (Vec (n+1) a)"+    , "template" : "~ARG[6]"+    }+  }+]

@@ -19,4 +19,28 @@     , "template"  : "~ARG[0] / ~ARG[1]"     }   }+, { "BlackBox" :+    { "name"      : "Clash.Sized.Internal.Unsigned.unsignedToWord"+    , "kind"      : "Expression"+    , "template"  : "~ARG[0]"+    }+  }+, { "BlackBox" :+    { "name"      : "Clash.Sized.Internal.Unsigned.unsigned8toWord8"+    , "kind"      : "Expression"+    , "template"  : "~ARG[0]"+    }+  }+, { "BlackBox" :+    { "name"      : "Clash.Sized.Internal.Unsigned.unsigned16toWord16"+    , "kind"      : "Expression"+    , "template"  : "~ARG[0]"+    }+  }+, { "BlackBox" :+    { "name"      : "Clash.Sized.Internal.Unsigned.unsigned32toWord32"+    , "kind"      : "Expression"+    , "template"  : "~ARG[0]"+    }+  } ]

@@ -325,22 +325,22 @@ , { "BlackBox" :     { "name"      : "Clash.Sized.Internal.BitVector.and#"     , "kind"      : "Expression"-    , "type"      : "and# :: BitVector n -> BitVector n -> BitVector n"-    , "template"  : "~ARG[0] & ~ARG[1]"+    , "type"      : "and# :: KnownNat n => BitVector n -> BitVector n -> BitVector n"+    , "template"  : "~ARG[1] & ~ARG[2]"     }   } , { "BlackBox" :     { "name"      : "Clash.Sized.Internal.BitVector.or#"     , "kind"      : "Expression"-    , "type"      : "or# :: BitVector n -> BitVector n -> BitVector n"-    , "template"  : "~ARG[0] | ~ARG[1]"+    , "type"      : "or# :: KnownNat n => BitVector n -> BitVector n -> BitVector n"+    , "template"  : "~ARG[1] | ~ARG[2]"     }   } , { "BlackBox" :     { "name"      : "Clash.Sized.Internal.BitVector.xor#"     , "kind"      : "Expression"-    , "type"      : "xor# :: BitVector n -> BitVector n -> BitVector n"-    , "template"  : "~ARG[0] ^ ~ARG[1]"+    , "type"      : "xor# :: KnownNat => BitVector n -> BitVector n -> BitVector n"+    , "template"  : "~ARG[1] ^ ~ARG[2]"     }   } , { "BlackBox" :

@@ -21,16 +21,17 @@     , "workInfo" : "Never"     , "kind" : "Declaration"     , "type" :-"setSlice# :: BitVector (m + 1 + i) -- ARG[0]-           -> SNat m                -- ARG[1]-           -> SNat n                -- ARG[2]-           -> BitVector (m + 1 - n) -- ARG[3]+"setSlice# :: SNat (m + 1 + i)+           -> BitVector (m + 1 + i) -- ARG[1]+           -> SNat m                -- ARG[2]+           -> SNat n                -- ARG[3]+           -> BitVector (m + 1 - n) -- ARG[4]            -> BitVector (m + 1 + i)"     , "template" : "// setSlice begin always_comb begin-  ~RESULT = ~ARG[0];-  ~RESULT[~LIT[1] : ~LIT[2]] = ~ARG[3];+  ~RESULT = ~ARG[1];+  ~RESULT[~LIT[2] : ~LIT[3]] = ~ARG[4]; end // setSlice end"     }

@@ -22,17 +22,18 @@     , "workInfo" : "Never"     , "kind" : "Declaration"     , "type" :-"setSlice# :: BitVector (m + 1 + i) -- ARG[0]-           -> SNat m                -- ARG[1]-           -> SNat n                -- ARG[2]-           -> BitVector (m + 1 - n) -- ARG[3]+"setSlice# :: SNat (m + 1 + i)+           -> BitVector (m + 1 + i) -- ARG[1]+           -> SNat m                -- ARG[2]+           -> SNat n                -- ARG[3]+           -> BitVector (m + 1 - n) -- ARG[4]            -> BitVector (m + 1 + i)"     , "outputReg" : true     , "template" : "// setSlice begin always @(*) begin-  ~RESULT = ~ARG[0];-  ~RESULT[~LIT[1] : ~LIT[2]] = ~VAR[din][3];+  ~RESULT = ~ARG[1];+  ~RESULT[~LIT[2] : ~LIT[3]] = ~VAR[din][4]; end // setSlice end"     }

@@ -73,8 +73,9 @@   -> Signal dom a"     , "template" : "-- blockRamU begin-~GENSYM[~RESULT_blockRam][1] : block-  type ~GENSYM[ram_t][8] is array (0 to integer'(~LIT[5])-1) of ~TYP[9];+~GENSYM[~RESULT_blockRam][1] : block~IF~VIVADO~THEN+  type ~GENSYM[ram_t][8] is array (0 to integer'(~LIT[5])-1) of std_logic_vector(~SIZE[~TYP[9]]-1 downto 0);~ELSE+  type ~SYM[8] is array (0 to integer'(~LIT[5])-1) of ~TYP[9];~FI   signal ~GENSYM[~RESULT_RAM][2] : ~SYM[8];   signal ~GENSYM[rd][4]  : integer range 0 to ~LIT[5] - 1;   signal ~GENSYM[wr][5]  : integer range 0 to ~LIT[5] - 1;@@ -132,9 +133,10 @@   -> Signal dom a"     , "template" : "-- blockRam1 begin-~GENSYM[~RESULT_blockRam][1] : block-  type ~GENSYM[ram_t][8] is array (0 to integer'(~LIT[5])-1) of ~TYP[6];-  signal ~GENSYM[~RESULT_RAM][2] : ~SYM[8] := (others => ~CONST[6]);+~GENSYM[~RESULT_blockRam][1] : block~IF~VIVADO~THEN+  type ~GENSYM[ram_t][8] is array (0 to integer'(~LIT[5])-1) of std_logic_vector(~SIZE[~TYP[6]]-1 downto 0);~ELSE+  type ~SYM[8] is array (0 to integer'(~LIT[5])-1) of ~TYP[6];~FI+  signal ~GENSYM[~RESULT_RAM][2] : ~SYM[8] := (others => ~IF~VIVADO~THEN~TOBV[~CONST[6]][~TYP[6]]~ELSE~CONST[6]~FI);   signal ~GENSYM[rd][4]  : integer range 0 to ~LIT[5] - 1;   signal ~GENSYM[wr][5]  : integer range 0 to ~LIT[5] - 1; begin

@@ -301,18 +301,19 @@     , "workInfo" : "Never"     , "kind" : "Declaration"     , "type" :-"setSlice# :: BitVector (m + 1 + i) -- ARG[0]-           -> SNat m                -- ARG[1]-           -> SNat n                -- ARG[2]-           -> BitVector (m + 1 - n) -- ARG[3]+"setSlice# :: SNat (m + 1 + i)+           => BitVector (m + 1 + i) -- ARG[1]+           -> SNat m                -- ARG[2]+           -> SNat n                -- ARG[3]+           -> BitVector (m + 1 - n) -- ARG[4]            -> BitVector (m + 1 + i)"     , "template" : "-- setSlice begin-~GENSYM[setSlice][0] : process(~VAR[bv][0]~VARS[3])+~GENSYM[setSlice][0] : process(~VAR[bv][0]~VARS[4])   variable ~GENSYM[ivec][1] : ~TYP[0]; begin-  ~SYM[1] := ~ARG[0];-  ~SYM[1](~LIT[1] downto ~LIT[2]) := ~VAR[bv][3];+  ~SYM[1] := ~ARG[1];+  ~SYM[1](~LIT[2] downto ~LIT[3]) := ~VAR[bv][4];   ~RESULT <= ~SYM[1]; end process; -- setSlice end"@@ -500,22 +501,22 @@ , { "BlackBox" :     { "name"      : "Clash.Sized.Internal.BitVector.and#"     , "kind"      : "Expression"-    , "type"      : "and# :: BitVector n -> BitVector n -> BitVector n"-    , "template"  : "~ARG[0] and ~ARG[1]"+    , "type"      : "and# :: KnownNat n => BitVector n -> BitVector n -> BitVector n"+    , "template"  : "~ARG[1] and ~ARG[2]"     }   } , { "BlackBox" :     { "name"      : "Clash.Sized.Internal.BitVector.or#"     , "kind"      : "Expression"-    , "type"      : "or# :: BitVector n -> BitVector n -> BitVector n"-    , "template"  : "~ARG[0] or ~ARG[1]"+    , "type"      : "or# :: KnownNat n => BitVector n -> BitVector n -> BitVector n"+    , "template"  : "~ARG[1] or ~ARG[2]"     }   } , { "BlackBox" :     { "name"      : "Clash.Sized.Internal.BitVector.xor#"     , "kind"      : "Expression"-    , "type"      : "xor# :: BitVector n -> BitVector n -> BitVector n"-    , "template"  : "~ARG[0] xor ~ARG[1]"+    , "type"      : "xor# :: KnownNat n => BitVector n -> BitVector n -> BitVector n"+    , "template"  : "~ARG[1] xor ~ARG[2]"     }   } , { "BlackBox" :

@@ -3,7 +3,7 @@     , "workInfo"  : "Never"     , "kind"      : "Expression"     , "type"      : "replicate :: SNat n -> a -> RTree d a"-    , "template"  : "~TYPMO'(0 to (2**~LIT[0])-1 => ~ARG[1])"+    , "template"  : "~TYPMO'(0 to (2**~LIT[0])-1 => ~IF~VIVADO~THEN~TOBV[~TYPM[1]'(~ARG[1])][~TYP[1]]~ELSE~ARG[1]~FI)"     }   } , { "BlackBox" :@@ -11,7 +11,7 @@     , "workInfo"  : "Never"     , "kind"      : "Expression"     , "type"      : "textract :: RTree 0 a -> a"-    , "template"  : "~IF ~VIVADO ~THEN ~FROMBV[~VAR[t][0]][~TYPO] ~ELSE ~VAR[t][0](0) ~FI"+    , "template"  : "~IF ~VIVADO ~THEN ~FROMBV[~VAR[t][0](0)][~TYPO] ~ELSE ~VAR[t][0](0) ~FI"     }   } , { "BlackBox" :

@@ -27,6 +27,7 @@ import           Data.HashSet                         (HashSet) import qualified Data.HashSet                         as HashSet import           Data.List                            (nub, nubBy)+import           Data.List.Extra                      ((<:>)) import           Data.Maybe                           (catMaybes,fromMaybe,mapMaybe) #if !MIN_VERSION_base(4,11,0) import           Data.Monoid                          hiding (Sum, Product)@@ -45,6 +46,7 @@ import           Clash.Annotations.BitRepresentation.Util   (BitOrigin(Lit, Field), bitOrigins, bitRanges) import           Clash.Core.Var                       (Attr'(..))+import           Clash.Debug                          (traceIf) import           Clash.Backend import           Clash.Backend.Verilog   (bits, bit_char, encodingNote, exprLit, include, noEmptyInit, uselibs)@@ -56,7 +58,7 @@ import           Clash.Netlist.Util                   hiding (mkIdentifier, extendIdentifier) import           Clash.Signal.Internal                (ActiveEdge (..)) import           Clash.Util-  (SrcSpan, noSrcSpan, curLoc, makeCached, (<:>), first, on, traceIf, indexNote)+  (SrcSpan, noSrcSpan, curLoc, makeCached, first, on, indexNote) import           Clash.Util.Graph                     (reverseTopSort)  -- | State for the 'Clash.Backend.SystemVerilog.SystemVerilogM' monad:

@@ -31,6 +31,7 @@ import qualified Data.HashSet                         as HashSet import           Data.List   (mapAccumL, nub, nubBy, intersperse, group, sort)+import           Data.List.Extra                      ((<:>), equalLength) import           Data.Maybe                           (catMaybes,fromMaybe,mapMaybe) #if !MIN_VERSION_base(4,11,0) import           Data.Monoid                          hiding (Sum, Product)@@ -54,6 +55,7 @@   (BitOrigin(Lit, Field), bitOrigins, bitRanges) import           Clash.Backend import           Clash.Core.Var                       (Attr'(..),attrName)+import           Clash.Debug                          (traceIf) import           Clash.Netlist.BlackBox.Types         (HdlSyn (..)) import           Clash.Netlist.BlackBox.Util   (extractLiterals, renderBlackBox, renderFilePath)@@ -61,10 +63,11 @@ import           Clash.Netlist.Types                  hiding (_intWidth, intWidth) import           Clash.Netlist.Util                   hiding (mkIdentifier) import           Clash.Util-  (SrcSpan, noSrcSpan, clogBase, curLoc, first, makeCached, on, traceIf, (<:>),-   indexNote)+  (SrcSpan, noSrcSpan, clogBase, curLoc, first, makeCached, on, indexNote) import           Clash.Util.Graph                     (reverseTopSort) +import           Clash.Backend.Verilog (Range (..), continueWithRange)+ -- | State for the 'Clash.Netlist.VHDL.VHDLM' monad: data VHDLState =   VHDLState@@ -131,9 +134,9 @@   toBV _ id_      = do     nm <- Mon $ use modNm     pretty (TextS.toLower nm) <> "_types.toSLV" <> parens (pretty id_)-  fromBV _ id_  = do+  fromBV t id_  = do     nm <- Mon $ use modNm-    pretty (TextS.toLower nm) <> "_types.fromSLV" <> parens (pretty id_)+    qualTyName t <> "'" <> parens (pretty (TextS.toLower nm) <> "_types.fromSLV" <> parens (pretty id_))   hdlSyn          = use hdlsyn   mkIdentifier    = do       allowExtended <- use extendedIds@@ -1464,222 +1467,10 @@   -> VHDLM Doc expr_ _ (Literal sizeM lit) = exprLit sizeM lit expr_ _ (Identifier id_ Nothing) = pretty id_-expr_ _ (Identifier id_ (Just (Indexed (CustomSP _id dataRepr _size args,dcI,fI)))) =-  case fieldTy of-    Void {} ->-      error (unexpectedProjectionErrorMsg dataRepr dcI fI)-    _ -> do-      nm <- Mon $ use modNm-      let cast = qualTyName resultType <> squote-      let fSLV = stringS (TextS.toLower nm) <> "_types.fromSLV"-      cast <> parens (fSLV <> parens (hcat $ punctuate " & " $ ranges))- where-  resultType = fieldTypes !! fI-  (ConstrRepr' _name _n _mask _value anns, _, fieldTypes) = args !! dcI -  ranges =-    mapM range $ bitRanges (anns !! fI)--  range (start, end) =-    pretty id_ <> parens (int start <+> "downto" <+> int end)--  fieldTy = indexNote ($(curLoc) ++ "panic") fieldTypes fI--expr_ b (Identifier id_ (Just (Indexed (ty@(SP _ args),dcI,fI)))) = do-  nm <- Mon $ use modNm-  case b of-    True ->-      (case normaliseType argTy of-        BitVector {} -> id-        _ -> (\x -> pretty (TextS.toLower nm) <> "_types.fromSLV" <> parens x))-      (pretty id_ <> parens (int start <+> "downto" <+> int end))-    _ -> fromSLV argTy id_ start end- where-   argTys   = snd $ args !! dcI-   argTy    = argTys !! fI-   argSize  = typeSize argTy-   other    = otherSize argTys (fI-1)-   start    = typeSize ty - 1 - conSize ty - other-   end      = start - argSize + 1--expr_ _ (Identifier id_ (Just (Indexed (CustomProduct _ dataRepr _ _ tys, dcI, fI)))) =-  case fieldTy of-    Void {} ->-      error (unexpectedProjectionErrorMsg dataRepr dcI fI)-    _ -> do-      modNm' <- Mon (use modNm)-      let cast = qualTyName fieldTy <> squote-      let fSLV = stringS (TextS.toLower modNm') <> "_types.fromSLV"-      cast <> parens (fSLV <> parens (hcat $ punctuate " & " $ ranges))- where-  (fieldAnn, fieldTy) = indexNote ($(curLoc) ++ "panic") tys fI-  ranges = mapM range (bitRanges fieldAnn)-  range (start, end) = pretty id_ <> parens (int start <+> "downto" <+> int end)--expr_ _ (Identifier id_ (Just (Indexed (ty@(Product _ labels tys),_,fI)))) =-  pretty id_ <> dot <> tyName ty <> selectProductField labels tys fI--expr_ _ (Identifier id_ (Just (Indexed ((Vector _ elTy),1,0)))) = do-  syn <- Mon hdlSyn-  case syn of-    Vivado -> do-      id' <- fmap (T.toStrict . renderOneLine) (pretty id_ <> parens (int 0))-      fromSLV elTy id' (typeSize elTy - 1) 0-    _ -> pretty id_ <> parens (int 0)-expr_ _ (Identifier id_ (Just (Indexed ((Vector n _),1,1)))) = pretty id_ <> parens (int 1 <+> "to" <+> int (n-1))---- This is a "Hack", we cannot construct trees with a negative depth. This is--- here so that we can recognise merged RTree modifiers. See the code in--- @Clash.Backend.nestM@ which construct these tree modifiers.-expr_ _ (Identifier id_ (Just (Indexed (RTree (-1) _,l,r)))) =-  pretty id_ <> parens (int l <+> "to" <+> int (r-1))--expr_ _ (Identifier id_ (Just (Indexed ((RTree 0 elTy),0,0)))) = do-  syn <- Mon hdlSyn-  case syn of-    Vivado -> do-      id' <- fmap (T.toStrict . renderOneLine) (pretty id_ <> parens (int 0))-      fromSLV elTy id' (typeSize elTy - 1) 0-    _ -> pretty id_ <> parens (int 0)-expr_ _ (Identifier id_ (Just (Indexed ((RTree n _),1,0)))) =-  let z = 2^(n-1)-  in  pretty id_ <> parens (int 0 <+> "to" <+> int (z-1))-expr_ _ (Identifier id_ (Just (Indexed ((RTree n _),1,1)))) =-  let z  = 2^(n-1)-      z' = 2^n-  in  pretty id_ <> parens (int z <+> "to" <+> int (z'-1))---- This is a HACK for Clash.Driver.TopWrapper.mkOutput--- Vector's don't have a 10'th constructor, this is just so that we can--- recognize the particular case-expr_ _ (Identifier id_ (Just (Indexed ((Vector _ elTy),10,fI)))) = do-  syn <- Mon hdlSyn-  case syn of-    Vivado -> do-      id' <- fmap (T.toStrict . renderOneLine) (pretty id_ <> parens (int fI))-      fromSLV elTy id' (typeSize elTy - 1) 0-    _ -> pretty id_ <> parens (int fI)---- This is a HACK for Clash.Driver.TopWrapper.mkOutput--- RTree's don't have a 10'th constructor, this is just so that we can--- recognize the particular case-expr_ _ (Identifier id_ (Just (Indexed ((RTree _ elTy),10,fI)))) = do+expr_ _ (Identifier id_ (Just m)) = do   syn <- Mon hdlSyn-  case syn of-    Vivado -> do-      id' <- fmap (T.toStrict . renderOneLine) (pretty id_ <> parens (int fI))-      fromSLV elTy id' (typeSize elTy - 1) 0-    _ -> pretty id_ <> parens (int fI)--expr_ _ (Identifier id_ (Just (DC (ty@(SP _ _),_)))) = pretty id_ <> parens (int start <+> "downto" <+> int end)-  where-    start = typeSize ty - 1-    end   = typeSize ty - conSize ty---- [Note] integer projection------ The idea behind these expressions is to translate cases like:------ > :: Int8 -> Int#--- > \case I8# i -> i------ Which is fine, because no bits are lost. However, these expression might--- also be the result of the W/W transformation (or uses of unsafeToInteger)--- for:------ > :: Signed 128 -> Integer--- > \case S i -> i------ which is very bad because `Integer` is represented by 64 bits meaning we--- we lose the top 64 bits in the above translation.------ Just as bad is that------ > :: Word8 -> Word#--- > \case W8# w -> w------ > :: Unsigned 8 -> Integer--- > \case U i -> i------ result in the same expression... even though their resulting types are--- different. TODO: this needs  to be fixed!-expr_ _ (Identifier id_ (Just (Indexed ((Signed w),_,_))))  = do-  iw <- Mon $ use intWidth-  traceIf (iw < w) ($(curLoc) ++ "WARNING: result smaller than argument") $-    "resize" <> parens (pretty id_ <> "," <> int iw)-expr_ _ (Identifier id_ (Just (Indexed ((Unsigned w),_,_)))) = do-  iw <- Mon $ use intWidth-  traceIf (iw < w) ($(curLoc) ++ "WARNING: result smaller than argument") $-    "resize" <> parens (pretty id_ <> "," <> int iw)---- [Note] mask projection------ This covers the case of either:------ `Clash.Sized.Internal.BitVector.unsafeToMask` or------ > :: BitVector 8 -> Integer--- > \case BV m wild -> m------ introduced by the W/W transformation. Both of which we prefer not to see--- but will allow. Since the mask is pretty much a simulation artifact we--- emit don't cares so stuff gets optimised away.-expr_ _ (Identifier _ (Just (Indexed ((BitVector _),_,0)))) = do-  iw <- Mon $ use intWidth-  traceIf True ($(curLoc) ++ "WARNING: synthesizing bitvector mask to dontcare") $-    sizedQualTyNameErrValue (Signed iw)---- [Note] bitvector projection------ This covers the case of either:------ `Clash.Sized.Internal.BitVector.unsafeToInteger` or------ > :: BitVector 8 -> Integer--- > \case BV wild i -> i------ introduced by the-expr_ _ (Identifier id_ (Just (Indexed ((BitVector w),_,1)))) = do-  iw <- Mon $ use intWidth-  traceIf (iw < w) ($(curLoc) ++ "WARNING: result smaller than argument") $-    "signed" <> parens ("std_logic_vector" <> parens ("resize" <>-      parens ("unsigned" <> parens (pretty id_) <> "," <> int iw)))--expr_ _ (Identifier id_ (Just (Sliced (BitVector _,start,end)))) =-  pretty id_ <> parens (int start <+> "downto" <+> int end)--expr_ b (Identifier id_ (Just (Nested (Indexed ((Vector n elTy),1,1)) m0))) = go 1 m0- where-  go s (Nested (Indexed ((Vector {}),1,1)) m1) = go (s+1) m1-  go s (Indexed (Vector {},1,1)) = pretty id_ <> parens (int (s+1) <+> "to" <+> int (n-1))-  go s (Indexed (Vector {},1,0)) = do-    syn <- Mon hdlSyn-    case syn of-      Vivado -> do-        id' <- fmap (T.toStrict . renderOneLine) (pretty id_ <> parens (int s))-        fromSLV elTy id' (typeSize elTy - 1) 0-      _ -> pretty id_ <> parens (int s)-  -- This is a HACK for Clash.Driver.TopWrapper.mkOutput--- Vector's don't have a 10'th constructor, this is just so that we can--- recognize the particular case-  go s (Indexed (Vector {},10,fI)) = do-    syn <- Mon hdlSyn-    case syn of-      Vivado -> do-        id' <- fmap (T.toStrict . renderOneLine) (pretty id_ <> parens (int (s+fI)))-        fromSLV elTy id' (typeSize elTy - 1) 0-      _ -> pretty id_ <> parens (int (s+fI))-  go s m1 = do-    k <- pretty id_ <> parens (int s <+> "to" <+> int (n-1))-    expr b (Identifier (T.toStrict $ renderOneLine k) (Just m1))--expr_ b (Identifier id_ (Just (Nested m1 m2))) = case nestM m1 m2 of-  Just m3 -> expr_ b (Identifier id_ (Just m3))-  _ -> do-    k <- expr_ True (Identifier id_ (Just m1))-    expr_ b (Identifier (T.toStrict $ renderOneLine k) (Just m2))--expr_ _ (Identifier id_ (Just _)) = pretty id_+  maybe (pretty id_) (foldr renderModifier (pretty id_)) (buildModifier syn [] m)  expr_ b (DataCon _ (DC (Void {}, -1)) [e]) =  expr_ b e @@ -1980,15 +1771,16 @@     tName    = tyName t     selNames = map (fmap (T.toStrict . renderOneLine) ) [pretty id_ <> dot <> tName <> selectProductField labels tys i | i <- [0..(length tys)-1]]     selIds   = map (fmap (\n -> Identifier n Nothing)) selNames-toSLV (Product _ _ tys) (DataCon _ _ es) = do+toSLV (Product _ _ tys) (DataCon _ _ es) | equalLength tys es =+  -- Need equalLenght for code seen in ZipWithUnitVector   encloseSep lparen rparen " & " (zipWithM toSLV tys es) toSLV (CustomProduct _ _ _ _ _) e = do   -- Custom representations are represented as bitvectors in HDL, so we don't   -- need to do anything.   expr_ False e-toSLV (Product _ _ _) e = do+toSLV t@(Product _ _ _) e = do   nm <- Mon $ use modNm-  pretty (TextS.toLower nm) <> "_types.toSLV" <> parens (expr_ False e)+  pretty (TextS.toLower nm) <> "_types.toSLV" <> parens (qualTyName t <> "'" <> parens (expr_ False e)) toSLV (SP _ _) e       = expr_ False e toSLV (CustomSP _ _ _ _) e =   -- Custom representations are represented as bitvectors in HDL, so we don't@@ -2013,48 +1805,11 @@ toSLV (Vector _ _) e = do   nm <- Mon $ use modNm   pretty (TextS.toLower nm) <> "_types.toSLV" <> parens (expr_ False e)+toSLV (RTree _ _) e = do+  nm <- Mon (use modNm)+  pretty (TextS.toLower nm) <> "_types.toSLV" <> parens (expr_ False e) toSLV hty e = error $ $(curLoc) ++  "toSLV:\n\nType: " ++ show hty ++ "\n\nExpression: " ++ show e -fromSLV :: HasCallStack => HWType -> Identifier -> Int -> Int -> VHDLM Doc-fromSLV Bool              id_ start _   = do-  nm <- Mon $ use modNm-  pretty (TextS.toLower nm) <> "_types.fromSLV" <> parens (pretty id_ <> parens (int start <+> "downto" <+> int start))-fromSLV Bit                 id_ start _   = pretty id_ <> parens (int start)-fromSLV (BitVector _)       id_ start end = pretty id_ <> parens (int start <+> "downto" <+> int end)-fromSLV (Index _)           id_ start end = "unsigned" <> parens (pretty id_ <> parens (int start <+> "downto" <+> int end))-fromSLV (Signed _)          id_ start end = "signed" <> parens (pretty id_ <> parens (int start <+> "downto" <+> int end))-fromSLV (Unsigned _)        id_ start end = "unsigned" <> parens (pretty id_ <> parens (int start <+> "downto" <+> int end))-fromSLV (Sum _ _)           id_ start end = pretty id_ <> parens (int start <+> "downto" <+> int end)-fromSLV (CustomSum _ _ _ _) id_ start end = pretty id_ <> parens (int start <+> "downto" <+> int end)-fromSLV t@(Product _ labels tys) id_ start _ = do-    tupled $ zipWithM (\s e -> s <+> rarrow <+> e) selNames args-  where-    tName      = tyName t-    selNames   = [tName <> selectProductField labels tys i | i <- [0..]]-    argLengths = map typeSize tys-    starts     = start : snd (mapAccumL ((join (,) .) . (-)) start argLengths)-    ends       = map (+1) (tail starts)-    args       = zipWith3 (`fromSLV` id_) tys starts ends--fromSLV (CustomSP _ _ _ _)  id_ start end = pretty id_ <> parens (int start <+> "downto" <+> int end)-fromSLV (CustomProduct {})  id_ start end = pretty id_ <> parens (int start <+> "downto" <+> int end)-fromSLV (SP _ _)            id_ start end = pretty id_ <> parens (int start <+> "downto" <+> int end)-fromSLV (Vector n elTy)     id_ start _   =-    if n > 1 then tupled args-             else parens (int 0 <+> rarrow <+> fmap head args)-  where-    argLength = typeSize elTy-    starts    = take (n + 1) $ iterate (subtract argLength) start-    ends      = map (+1) (tail starts)-    args      = do syn <- Mon hdlSyn-                   let elTy' = case syn of-                                 Vivado -> BitVector (argLength - 1)-                                 _ -> elTy-                   zipWithM (fromSLV elTy' id_) starts ends-fromSLV (Clock {})        id_ start _   = pretty id_ <> parens (int start)-fromSLV (Reset {})        id_ start _   = pretty id_ <> parens (int start)-fromSLV hty               _   _     _   = error $ $(curLoc) ++ "fromSLV: " ++ show hty- dcToExpr :: HWType -> Int -> Expr dcToExpr ty i = Literal (Just (ty,conSize ty)) (NumLit (toInteger i)) @@ -2080,3 +1835,358 @@ tupledSemi = align . encloseSep (flatAlt (lparen <+> emptyDoc) lparen)                                 (flatAlt (emptyDoc <+> rparen) rparen)                                 (semi <+> emptyDoc)++-- | VHDL name modifiers+data VHDLModifier+  -- | SLV slice (descending index)+  = Range    Range+  -- | Element selection+  | Idx      Int+  -- | Array slice (ascending index)+  | Slice    Int Int+  -- | Selected names+  | Select   (VHDLM Doc)+  -- | Projecting a 'Word#' out of a 'Word8', or 'Int#' ouf of an 'Int8', see+  -- [Note] integer projection+  | Resize+  -- | Projecting a 'Natural' out of a 'BitVector', see [Note] bitvector projection+  | ResizeAndConvert+  -- | Projecting the mask out of a 'BitVector', see [Note] mask projection+  | DontCare++-- | Create a sequence of VHDL name modifiers from our internal 'Modifier'+-- data type. Note that the modifiers are in "reverse" order, so build a+-- complete modified name using 'foldr' over the list by this function.+--+-- [Note] Continuing from an SLV slice+-- SOP and custom products are represented as std_logic_vector, this means that+-- their elements are also std_logic_vector. So when we project an element out+-- of an SOP or custom project, and want to do a further projection on that,+-- we have to do further SLV slicing; instead of e.g. creating a 'selected'+-- modifier. Finally, when we render the modified name, we have to check+-- whether the ultimately projected type needs to be converted from this SLV+-- slice, to the proper type.+buildModifier+  :: HasCallStack+  => HdlSyn+  -> [(VHDLModifier,HWType)]+  -- ^ The list of modifiers so far, note that this list is in reverse order+  -- in which they should eventually be applied to the name we want to modify+  -> Modifier+  -> Maybe [(VHDLModifier,HWType)]+  -- ^ 'Nothing' indicates that the 'Modifier' does not result into a VHDL name+  -- modifier. i.e. we can use the identifier as is; this happens when we get+  -- projections out of product types with only one non-zero field.+buildModifier _ prevM (Sliced (_,start,end)) = case prevM of+  (prev:rest)+    | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice+      Just (first Range (continueWithRange [(start,end)] hty r) : rest)+  _ ->+      Just ((Range (Contiguous start end),hty) : prevM)+ where+  hty = BitVector (start-end+1)++buildModifier _ prevM (Indexed (ty@(SP _ args),dcI,fI)) = case prevM of+  (prev:rest)+    | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice+      Just (first Range (continueWithRange [(start,end)] argTy r) : rest)+  _ ->+      Just ((Range (Contiguous start end),argTy) : prevM)+ where+  argTys   = snd (indexNote "SOP type: invalid constructor index" args dcI)+  argTy    = indexNote "SOP type: invalid field index" argTys fI+  argSize  = typeSize argTy+  other    = otherSize argTys (fI-1)+  start    = typeSize ty - 1 - conSize ty - other+  end      = start - argSize + 1++buildModifier _ prevM (Indexed (ty@(Product _ labels tys),_,fI)) = case prevM of+  (prev:rest)+    | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice+      let argSize = typeSize argTy+          otherSz = otherSize tys (fI - 1)+          start   = typeSize ty - 1 - otherSz+          end     = start - argSize + 1+      in  Just (first Range (continueWithRange [(start,end)] argTy r) : rest)+  _ ->+      let d = dot <> tyName ty <> selectProductField labels tys fI+      in  Just ((Select d,argTy):prevM)+ where+  argTy = indexNote "Product type: invalid field index" tys fI++buildModifier syn prevM (Indexed (ty@(Vector _ argTy),1,0)) = case prevM of+  (prev:rest)+    | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice+      let argSize = typeSize argTy+          start   = typeSize ty - 1+          end     = start - argSize + 1+      in  Just (first Range (continueWithRange [(start,end)] argTy r) : rest)+    | (Slice start _,Vector _ argTyP) <- prev+    , argTy == argTyP ->+      -- If the last modifier was an array slice, we just pick its first element+      Just (vivadoRange syn argTy ((Idx start,argTy):rest))+  _ ->+      Just (vivadoRange syn argTy ((Idx 0,argTy):prevM))++buildModifier _ prevM (Indexed (ty@(Vector n argTy),1,1)) = case prevM of+  (prev:rest)+    | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice+      let argSize = typeSize argTy+          start   = typeSize ty - argSize - 1+      in  Just (first Range (continueWithRange [(start,0)] tyN r) : rest)+    | (Slice start end,Vector _ argTyP) <- prev+    , argTy == argTyP ->+      -- If the last modifier was an array slice, we just pick the tail of that slice+      Just ((Slice (start + 1) end,tyN) : rest)+  _ ->+      Just ((Slice 1 (n-1),tyN) : prevM)+ where+  tyN = Vector (n-1) argTy++buildModifier syn prevM (Indexed (ty@(RTree _ argTy),0,0)) = case prevM of+  (prev:rest)+    | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice+      let start = typeSize ty - 1+      in  Just (first Range (continueWithRange [(start,0)] argTy r) : rest)+    | (Slice start _,RTree _ argTyP) <- prev+    , argTy == argTyP ->+      -- If the last modifier was an array slice, we just pick its first element+      Just (vivadoRange syn argTy ((Idx start,argTy):rest))+  _ ->+      Just (vivadoRange syn argTy ((Idx 0,argTy):prevM))++buildModifier _ prevM (Indexed (ty@(RTree d argTy),1,0)) = case prevM of+  (prev:rest)+    | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice+      let start = typeSize ty - 1+          end   = typeSize ty `div` 2+      in  Just (first Range (continueWithRange [(start,end)] tyN r) : rest)+    | (Slice start _,RTree _ argTyP) <- prev+    , argTy == argTyP ->+      -- If the last modifier was an array slice, we just pick the left half+      Just ((Slice start (start+z-1),tyN) : rest)+  _ ->+      Just ((Slice 0 (z-1),tyN) : prevM)+ where+  tyN = RTree (d-1) argTy+  z   = 2^(d - 1)++buildModifier _ prevM (Indexed (ty@(RTree d argTy),1,1)) = case prevM of+  (prev:rest)+    | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice+      let start = typeSize ty `div` 2 - 1+      in  Just (first Range (continueWithRange [(start,0)] tyN r) : rest)+    | (Slice _ end,RTree _ argTyP) <- prev+    , argTy == argTyP ->+      -- If the last modifier was an array slice, we just pick the right half+      Just ((Slice (end - z + 1) end,tyN) : rest)+  _ ->+      Just ((Slice z (z'-1),tyN) : prevM)+ where+  tyN = RTree (d-1) argTy+  z   = 2^(d - 1)+  z'  = 2^d++-- This is a HACK for Clash.Driver.TopWrapper.mkOutput+-- Vector's don't have a 10'th constructor, this is just so that we can+-- recognize the particular case+buildModifier syn prevM (Indexed (ty@(Vector _ argTy),10,fI)) = case prevM of+  (prev:rest)+    | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice+      let argSize = typeSize argTy+          start   = typeSize ty - (fI * argSize) - 1+          end     = start - argSize + 1+      in  Just (first Range (continueWithRange [(start,end)] argTy r) : rest)+    | (Slice start _,Vector _ argTyP) <- prev+    , argTy == argTyP ->+      -- If the last modifier was an array slice, we offset from its starting element+      Just (vivadoRange syn argTy ((Idx (start+fI),argTy):rest))+  _ ->+      Just (vivadoRange syn argTy (((Idx fI,argTy):prevM)))++-- This is a HACK for Clash.Driver.TopWrapper.mkOutput+-- RTree's don't have a 10'th constructor, this is just so that we can+-- recognize the particular case+buildModifier syn prevM (Indexed (ty@(RTree _ argTy),10,fI)) = case prevM of+  (prev:rest)+    | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice+      let argSize = typeSize argTy+          start   = typeSize ty - (fI * argSize) - 1+          end     = start - argSize + 1+      in  Just (first Range (continueWithRange [(start,end)] argTy r) : rest)+    | (Slice start _,RTree 1 argTyP) <- prev+    , argTy == argTyP ->+      -- If the last modifier was an array slice, we offset from its starting element+      Just (vivadoRange syn argTy ((Idx (start+fI),argTy):rest))+  _ ->+      Just (vivadoRange syn argTy ((Idx fI,argTy):prevM))++buildModifier _ prevM (Indexed (CustomSP _ dataRepr size args,dcI,fI))+  | Void {} <- argTy+  = error (unexpectedProjectionErrorMsg dataRepr dcI fI)+  | otherwise+  = case prevM of+    (prev:rest)+      | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice+        Just (first Range (continueWithRange ses argTy r) : rest)+    _ ->+        Just (first Range (continueWithRange ses argTy (Contiguous (size-1) 0)) : prevM)+ where+  (ConstrRepr' _name _n _mask _value anns, _, argTys) =+    indexNote "Custom SOP type: invalid constructor index" args dcI+  ses = bitRanges (indexNote "Custom SOP type: invalid annotation index" anns fI)+  argTy = indexNote "Custom SOP type: invalid field index" argTys fI++buildModifier _ prevM (Indexed (CustomProduct _ dataRepr size _ args,dcI,fI))+  | Void {} <- argTy+  = error (unexpectedProjectionErrorMsg dataRepr dcI fI)+  | DataRepr' _typ _size [cRepr] <- dataRepr+  , ConstrRepr' _cName _pos _mask _val fieldAnns <- cRepr+  , let ses = bitRanges (indexNote "Custom product type: invalid annotation index"+                         fieldAnns fI)+  = case prevM of+      (prev:rest)+        | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice+          Just (first Range (continueWithRange ses argTy r) : rest)+      _ ->+          Just (first Range (continueWithRange ses argTy (Contiguous (size-1) 0)):prevM)+ where+  argTy = snd (indexNote "Custom product type: invalid field index" args fI)++buildModifier _ prevM (DC (ty@(SP _ _),_)) = case prevM of+  (prev:rest)+    | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice+      Just (first Range (continueWithRange [(start,end)] tyN r) : rest)+  _ ->+      Just ((Range (Contiguous start end),tyN):prevM)+ where+  start = typeSize ty - 1+  end   = typeSize ty - conSize ty+  tyN   = BitVector (start - end + 1)++buildModifier syn prevM (Nested m1 m2) = case buildModifier syn prevM m1 of+  Nothing -> buildModifier syn prevM m2+  Just prevM1 -> case buildModifier syn prevM1 m2 of+      -- In case the second modifier is `Nothing` that means we want the entire+      -- thing calculated by the first modifier+      Nothing -> Just prevM1+      m       -> m++-- [Note] integer projection+--+-- The idea behind these expressions is to translate cases like:+--+-- > :: Int8 -> Int#+-- > \case I8# i -> i+--+-- Which is fine, because no bits are lost. However, these expression might+-- also be the result of the W/W transformation (or uses of unsafeToInteger)+-- for:+--+-- > :: Signed 128 -> Integer+-- > \case S i -> i+--+-- which is very bad because `Integer` is represented by 64 bits meaning we+-- we lose the top 64 bits in the above translation.+--+-- Just as bad is that+--+-- > :: Word8 -> Word#+-- > \case W8# w -> w+--+-- > :: Unsigned 8 -> Integer+-- > \case U i -> i+--+-- result in the same expression... even though their resulting types are+-- different. TODO: this needs  to be fixed!+buildModifier _ prevM (Indexed (ty@(Signed _),_,_)) = Just ((Resize,ty):prevM)+buildModifier _ prevM (Indexed (ty@(Unsigned _),_,_)) = Just ((Resize,ty):prevM)++-- [Note] mask projection+--+-- This covers the case of either:+--+-- `Clash.Sized.Internal.BitVector.unsafeToMask` or+--+-- > :: BitVector 8 -> Integer+-- > \case BV m wild -> m+--+-- introduced by the W/W transformation. Both of which we prefer not to see+-- but will allow. Since the mask is pretty much a simulation artifact we+-- emit don't cares so stuff gets optimised away.+buildModifier _ prevM (Indexed (ty@(BitVector _),_,0)) = Just ((DontCare,ty):prevM)++-- [Note] bitvector projection+--+-- This covers the case of either:+--+-- `Clash.Sized.Internal.BitVector.unsafeToNatural` or+--+-- > :: BitVector 8 -> Integer+-- > \case BV wild i -> i+--+-- introduced by the W/W transformation. Both of which we prefer not to see+-- but will allow.+buildModifier _ prevM (Indexed (ty@(BitVector _),_,1)) = Just ((ResizeAndConvert,ty):prevM)++buildModifier _ _ _ = Nothing++-- | Add an SLV slice for the entire element when we're in the Vivado code-path.+-- This is needed after an element projection from an array (Vec or RTree), as+-- elements are stored as SLVs in the Vivado code-path. This enabled two things:+--+-- 1. Nested modifiers treat the projected element as an SLV, and adjust their+--    projection behavior accordingly.+-- 2. Projected elements are converted from SLV to the proper VHDL type.+vivadoRange+  :: HdlSyn+  -> HWType+  -> [(VHDLModifier, HWType)]+  -> [(VHDLModifier, HWType)]+vivadoRange syn ty mods = case syn of+  Vivado -> (Range (Contiguous (typeSize ty - 1) 0),ty):mods+  _ -> mods++-- | Render a VHDL modifier on to of a (potentially modified) VHDL name+renderModifier+  :: (VHDLModifier,HWType)+  -> VHDLM Doc+  -- ^ (Potentially modified) VHDL name+  -> VHDLM Doc+  -- ^ Modified VHDL name+renderModifier (Idx n,_) doc = doc <> parens (int n)+renderModifier (Slice start end,_) doc = doc <> parens (int start <+> "to" <+> int end)+renderModifier (Select sel,_) doc = doc <> sel+-- See [Note] integer projection+renderModifier (Resize,ty) doc = do+  iw <- Mon (use intWidth)+  -- These integer projections always come last, so it's safe not to return a+  -- modified name, but an expression instead.+  traceIf (iw < typeSize ty) ($(curLoc) ++ "WARNING: result smaller than argument") $+    "resize" <> parens (doc <> "," <> int iw)+renderModifier (ResizeAndConvert,ty) doc = do+  iw <- Mon (use intWidth)+  -- These natural projections always come last, so it's safe not to return a+  -- modified name, but an expression instead.+  traceIf (iw < typeSize ty) ($(curLoc) ++ "WARNING: result smaller than argument") $+    "resize" <> parens ("unsigned" <> parens doc <> "," <> int iw)+-- See [Note] mask projection+renderModifier (DontCare,_) _ = do+  iw <- Mon (use intWidth)+  -- These mask projections always come last, so it's safe not to return a+  -- modified name, but an expression instead.+  traceIf True ($(curLoc) ++ "WARNING: rendering bitvector mask as dontcare") $+    sizedQualTyNameErrValue (Signed iw)+renderModifier (Range r,t) doc = do+  nm <- Mon (use modNm)+  let doc1 = case r of+        Contiguous start end -> slice start end+        Split rs -> parens (hcat (punctuate " & " (mapM (\(s,e,_) -> slice s e) rs)))+  case normaliseType t of+    BitVector _ -> doc1+    -- See [Note] Continuing from an SLV slice+    _ ->+      qualTyName t <> "'" <>+      parens (pretty (TextS.toLower nm) <> "_types.fromSLV" <> parens doc1)+ where+  slice s e = doc <> parens (int s <+> "downto" <+> int e)

@@ -24,6 +24,9 @@   , bits   , bit_char   , noEmptyInit+  -- * split ranges+  , Range (..)+  , continueWithRange   ) where @@ -34,13 +37,16 @@ import           Data.Bits                            (Bits, testBit) import           Data.HashMap.Strict                  (HashMap) import qualified Data.HashMap.Strict                  as HashMap+import           Data.HashSet                         (HashSet) import qualified Data.HashSet                         as HashSet import           Data.Maybe                           (catMaybes,fromMaybe,mapMaybe)-import           Data.List                            (nub, nubBy)+import           Data.List+  (mapAccumL, mapAccumR, nubBy, foldl')+import           Data.List.Extra                      ((<:>)) #if !MIN_VERSION_base(4,11,0) import           Data.Monoid                          hiding (Product, Sum) #endif-import           Data.Semigroup.Monad+import           Data.Semigroup.Monad.Extra import           Data.Text.Lazy                       (pack) import qualified Data.Text.Lazy                       as Text import qualified Data.Text                            as TextS@@ -49,15 +55,15 @@ import           GHC.Stack                            (HasCallStack)  import           Clash.Annotations.Primitive          (HDL (..))-import           Clash.Annotations.BitRepresentation  (BitMask) import           Clash.Annotations.BitRepresentation.ClashLib   (bitsToBits) import           Clash.Annotations.BitRepresentation.Internal   (ConstrRepr'(..), DataRepr'(..), ConstrRepr'(..)) import           Clash.Annotations.BitRepresentation.Util-  (BitOrigin(Lit, Field), bitOrigins, bitRanges, isContinuousMask)+  (BitOrigin(Lit, Field), bitOrigins, bitRanges) import           Clash.Core.Var                       (Attr'(..)) import           Clash.Backend+import           Clash.Debug                          (traceIf) import           Clash.Netlist.BlackBox.Types         (HdlSyn) import           Clash.Netlist.BlackBox.Util   (extractLiterals, renderBlackBox, renderFilePath)@@ -66,8 +72,7 @@ import           Clash.Netlist.Util                   hiding (mkIdentifier, extendIdentifier) import           Clash.Signal.Internal                (ActiveEdge (..)) import           Clash.Util-  (SrcSpan, noSrcSpan, curLoc, traceIf, (<:>), on, first, indexNote)-+  (SrcSpan, noSrcSpan, curLoc, on, first, indexNote, makeCached, second)  -- | State for the 'Clash.Backend.Verilog.VerilogM' monad: data VerilogState =@@ -76,13 +81,15 @@     , _idSeen    :: HashMap Identifier Word     , _srcSpan   :: SrcSpan     , _includes  :: [(String,Doc)]-    , _imports   :: [Text.Text]-    , _libraries :: [Text.Text]+    , _imports   :: HashSet Text.Text+    , _libraries :: HashSet Text.Text     , _dataFiles      :: [(String,FilePath)]     -- ^ Files to be copied: (filename, old path)     , _memoryDataFiles:: [(String,String)]     -- ^ Files to be stored: (filename, contents). These files are generated     -- during the execution of 'genNetlist'.+    , _customConstrs :: HashMap Identifier Identifier+    -- ^ Custom data constructor => Verilog function name     , _intWidth  :: Int -- ^ Int/Word/Integer bit-width     , _hdlsyn    :: HdlSyn     , _escapedIds :: Bool@@ -92,7 +99,16 @@ makeLenses ''VerilogState  instance Backend VerilogState where-  initBackend     = VerilogState 0 HashMap.empty noSrcSpan [] [] [] [] []+  initBackend     = VerilogState+                      0+                      HashMap.empty+                      noSrcSpan+                      []+                      HashSet.empty+                      HashSet.empty+                      []+                      []+                      HashMap.empty   hdlKind         = const Verilog   primDirs        = const $ do root <- primsRoot                                return [ root System.FilePath.</> "common"@@ -163,9 +179,9 @@         pure decs <> line <>         insts ds   unextend = return rmSlash-  addIncludes inc = includes %= (inc++)-  addLibraries libs = libraries %= (libs ++)-  addImports inps = imports %= (inps ++)+  addIncludes inc = includes %= (inc ++)+  addLibraries libs = libraries %= (\s -> foldl' (flip HashSet.insert) s libs)+  addImports inps = imports %= (\s -> foldl' (flip HashSet.insert) s inps)   addAndSetData f = do     fs <- use dataFiles     let (fs',f') = renderFilePath fs f@@ -241,13 +257,17 @@     iE = maybe emptyDoc (noEmptyInit . expr_ False) iEM  module_ :: Component -> VerilogM Doc-module_ c = addSeen c *> modVerilog <* Mon (imports .= [])+module_ c =+  addSeen c *> modVerilog <* Mon (imports .= HashSet.empty >> libraries .= HashSet.empty)   where     modVerilog = do       body <- modBody       imps <- Mon $ use imports       libs <- Mon $ use libraries-      modHeader <> line <> modPorts <> line <> include (nub imps) <> uselibs (nub libs) <> pure body <> line <> modEnding+      modHeader <> line <> modPorts <> line <>+        include (HashSet.toList imps) <>+        uselibs (HashSet.toList libs) <>+        pure body <> line <> modEnding      modHeader  = "module" <+> stringS (componentName c)     modPorts   = indent 4 (tupleInputs inPorts <> line <> tupleOutputs outPorts <> semi)@@ -331,8 +351,8 @@   :: HWType   -> Int   -> VerilogM Doc-verilogRecSel ty i = case modifier 0 (Indexed (ty,0,i)) of-  Just (start,end,_resTy) -> brackets (int start <> colon <> int end)+verilogRecSel ty i = case modifier (Contiguous 0 0) (Indexed (ty,0,i)) of+  Just (Contiguous start end,_resTy) -> brackets (int start <> colon <> int end)   _ -> error "Can't make a record selector"  decls :: [Declaration] -> VerilogM Doc@@ -579,18 +599,166 @@ seqs (SeqDecl (TickDecl id_):ds) = "//" <+> stringS id_ <> line <> seqs ds seqs (d:ds) = seq_ d <> line <> line <> seqs ds +-- | Range slice, can be contiguous, or split into multiple sub-ranges+data Range+  = Contiguous Int Int+  | Split [(Int,Int,Provenance)]++-- | Original index range of a split range element+data Provenance+  = Provenance Int Int++-- | Slice ranges out of a split-range element+inRange+  :: [(Int,Int)]+  -- ^ start and end indexes into the original data type+  -> (Int,Int,Provenance)+  -- ^ Element of a split range+  -> ([(Int,Int)],[(Int,Int,Provenance)])+  -- ^+  -- 1. stand and end indexes to be sliced from the rest of the split range elements+  -- 2. Subset of the current split range for the projected data type+inRange [] _ = ([],[])+inRange ((start,end):ses) orig@(_,endRange,Provenance _ endProvenance) =+{-+The following explains the index calculations++== Start ==+-----------------------------------+|     2     | |    1   | |   0    |  <- split range element number+|15|14|13|12| |10| 9| 8| | 4| 3| 2|  <- split range indexes+-----------------------------------+| 9| 8| 7| 6| | 5| 4| 3| | 2| 1| 0|  <- original indexes of the data type (provenance)+-----------------------------------+                   4          1      <- `start` and `end` index that we want to slice++== split range element 2 ==+startOffset: start(4) - endProvenance(6) = -2++next start: 4+next end:   1++== split range element 1 ==+startOffset: start(4) - endProvenance(3) = 1+endOffSet  : end(1) - endProvenance(3) = -2++startRangeNew: endRange(8) + startOffSet(1) = 9+endRangeNew  : endRange(8)++startProvenanceNew: start(4) - end(1)                    = 3+endProvenanceNew  : startProvenanceNew(3)-startOffset(1) = 2++newSplitRange:+-------+|  1  |+| 9| 8| <- new split range element+-------+| 3| 2| <- index into the projected data type++next start: endProvenance(3) - 1 = 2+next end  : 1++== split range element 0 ==+startOffset: start(2) - endProvenance(0) = 2+endOffset  : end(1) - endProvenance(0)   = 1++startRangeNew: endRange(2) + startOffSet(2) = 4+endRangeNew  : endRange(2) + endOffSet(1)   = 3++startProvenanceNew: start(2) - end(1) = 1+endProvenanceNew  :                   = 0++newSplitRange:+-------+|  0  |+| 4| 3| <- new split range element+-------+| 1| 0| <- index into the projected data type+-}+  let startOffset = start - endProvenance+      endOffset   = end   - endProvenance+  in+  if startOffset >= 0 then+    let startRangeNew = endRange + startOffset+        endRangeNew =+          if endOffset >= 0 then+             endRange + endOffset+          else+            endRange++        startProvenanceNew = start - end+        endProvenanceNew =+          if endOffset >= 0 then+            0+          else+            startProvenanceNew - startOffset++        newSplitRange =+          ( startRangeNew+          , endRangeNew+          , Provenance startProvenanceNew endProvenanceNew)+    in+    if endOffset >= 0 then+      -- try to slice the next start+end in the current split range element+      second (newSplitRange:) (inRange ses orig)+    else+      -- continue the slice in the next split range element+      ((endProvenance-1,end):ses,[newSplitRange])+  else+    -- start offset beyond last bit in the element of the split range+    ((start,end):ses,[])++-- | Create an Split range element+buildSplitRange+  :: Int+  -- ^ Offset+  -> Int+  -- ^ End index into the original data type+  -> (Int,Int)+  -- ^ start and end index for this sub-range+  -> (Int,(Int,Int,Provenance))+buildSplitRange offset eP (s,e) =+  let d = s-e in+  (eP+d+1,(s + offset, e + offset, Provenance (eP+d) eP))++-- | Select a sub-range from a range+continueWithRange+  :: [(Int,Int)]+  -- ^ Starts and ends+  -> HWType+  -- ^ Type of the projection+  -> Range+  -- ^ Range selected so far+  -> (Range, HWType)+continueWithRange ses hty r = case r of+  Contiguous _ offset -> case ses of+    [(start,end)] ->+      (Contiguous (start+offset) (end+offset), hty)+    ses1 ->+      let ses2 = snd (mapAccumR (buildSplitRange offset) 0 ses1) in+      (Split ses2, hty)+  Split rs -> case concat (snd (mapAccumL inRange ses rs)) of+    [] -> error "internal error"+    [(s1,e1,_)] -> (Contiguous s1 e1,hty)+    rs1 -> (Split rs1,hty)+ -- | Calculate the beginning and end index into a variable, to get the -- desired field. -- Also returns the HWType of the result. modifier   :: HasCallStack-  => Int-  -- ^ Offset, only used when we have nested modifiers+  => Range+  -- ^ Range selected so far   -> Modifier-  -> Maybe (Int,Int,HWType)-modifier offset (Sliced (BitVector _,start,end)) = Just (start+offset,end+offset, BitVector (start-end+1))+  -> Maybe (Range,HWType)+modifier r (Sliced (BitVector _,start,end)) =+  Just (continueWithRange [(start,end)] hty r)+  where+    hty = BitVector (start-end-1) -modifier offset (Indexed (ty@(SP _ args),dcI,fI)) = Just (start+offset,end+offset, argTy)++modifier r (Indexed (ty@(SP _ args),dcI,fI)) =+  Just (continueWithRange [(start,end)] argTy r)   where     argTys   = snd $ args !! dcI     argTy    = argTys !! fI@@ -599,7 +767,8 @@     start    = typeSize ty - 1 - conSize ty - other     end      = start - argSize + 1 -modifier offset (Indexed (ty@(Product _ _ argTys),_,fI)) = Just (start+offset,end+offset, argTy)+modifier r (Indexed (ty@(Product _ _ argTys),_,fI)) =+  Just (continueWithRange [(start,end)] argTy r)   where     argTy   = argTys !! fI     argSize = typeSize argTy@@ -607,34 +776,43 @@     start   = typeSize ty - 1 - otherSz     end     = start - argSize + 1 -modifier offset (Indexed (ty@(Vector _ argTy),1,0)) = Just (start+offset,end+offset, argTy)+modifier r (Indexed (ty@(Vector _ argTy),1,0)) =+  Just (continueWithRange [(start,end)] argTy r)   where     argSize = typeSize argTy     start   = typeSize ty - 1     end     = start - argSize + 1 -modifier offset (Indexed (ty@(Vector n argTy),1,1)) = Just (start+offset,offset,Vector (n-1) argTy)+modifier r (Indexed (ty@(Vector n argTy),1,1)) =+  Just (continueWithRange [(start,0)] hty r)   where     argSize = typeSize argTy     start   = typeSize ty - argSize - 1+    hty     = Vector (n-1) argTy -modifier offset (Indexed (ty@(RTree 0 argTy),0,0)) = Just (start+offset,offset, argTy)+modifier r (Indexed (ty@(RTree 0 argTy),0,0)) =+  Just (continueWithRange [(start,0)] argTy r)   where     start   = typeSize ty - 1 -modifier offset (Indexed (ty@(RTree d argTy),1,0)) = Just (start+offset,end+offset,RTree (d-1) argTy)+modifier r (Indexed (ty@(RTree d argTy),1,0)) =+  Just (continueWithRange [(start,end)] hty r)   where     start   = typeSize ty - 1     end     = typeSize ty `div` 2+    hty     = RTree (d-1) argTy -modifier offset (Indexed (ty@(RTree d argTy),1,1)) = Just (start+offset,offset, RTree (d-1) argTy)+modifier r (Indexed (ty@(RTree d argTy),1,1)) =+  Just (continueWithRange [(start,0)] hty r)   where     start   = (typeSize ty `div` 2) - 1+    hty     = RTree (d-1) argTy  -- This is a HACK for Clash.Driver.TopWrapper.mkOutput -- Vector's don't have a 10'th constructor, this is just so that we can -- recognize the particular case-modifier offset (Indexed (ty@(Vector _ argTy),10,fI)) = Just (start+offset,end+offset, argTy)+modifier r (Indexed (ty@(Vector _ argTy),10,fI)) =+  Just (continueWithRange [(start,end)] argTy r)   where     argSize = typeSize argTy     start   = typeSize ty - (fI * argSize) - 1@@ -643,51 +821,40 @@ -- This is a HACK for Clash.Driver.TopWrapper.mkOutput -- RTree's don't have a 10'th constructor, this is just so that we can -- recognize the particular case-modifier offset (Indexed (ty@(RTree _ argTy),10,fI)) = Just (start+offset,end+offset, argTy)+modifier r (Indexed (ty@(RTree _ argTy),10,fI)) =+  Just (continueWithRange [(start,end)] argTy r)   where     argSize = typeSize argTy     start   = typeSize ty - (fI * argSize) - 1     end     = start - argSize + 1 -modifier offset (Indexed (CustomSP typName _dataRepr _size args,dcI,fI)) =-  case bitRanges (anns !! fI) of-    [(start,end)] ->-      Just (start+offset,end+offset, argTy)-    _ ->-      error $ $(curLoc) ++ "Cannot handle projection out of a "-           ++ "non-contiguously or zero-width encoded field. Tried to project "-           ++ "field " ++ show fI ++ " of constructor " ++ show dcI ++ " of "-           ++ "data type " ++ show typName ++  "."- where-  (ConstrRepr' _name _n _mask _value anns, _, argTys) = args !! dcI-  argTy = argTys !! fI+modifier r (Indexed (CustomSP _typName _dataRepr _size args,dcI,fI)) =+  Just (continueWithRange ses argTy r)+  where+    ses = bitRanges (anns !! fI)+    (ConstrRepr' _name _n _mask _value anns, _, argTys) = args !! dcI+    argTy = argTys !! fI -modifier offset (Indexed (CustomProduct typName dataRepr _size _maybeFieldNames args,dcI,fI))+modifier r (Indexed (CustomProduct _typName dataRepr _size _maybeFieldNames args,_,fI))   | DataRepr' _typ _size [cRepr] <- dataRepr-  , ConstrRepr' _cName _pos _mask _val fieldAnns <- cRepr =-  case bitRanges (fieldAnns !! fI) of-    [(start,end)] ->-      Just (start+offset,end+offset, argTy)-    _ ->-      error $ $(curLoc) ++ "Cannot handle projection out of a "-           ++ "non-contiguously or zero-width encoded field. Tried to project "-           ++ "field " ++ show fI ++ " of constructor " ++ show dcI ++ " of "-           ++ "data type " ++ show typName ++ "."+  , ConstrRepr' _cName _pos _mask _val fieldAnns <- cRepr+  = let ses = bitRanges (fieldAnns !! fI) in Just (continueWithRange ses argTy r)  where   argTy = map snd args !! fI -modifier offset (DC (ty@(SP _ _),_)) = Just (start+offset,end+offset, ty)+modifier r (DC (ty@(SP _ _),_)) =+  Just (continueWithRange [(start,end)] ty r)   where     start = typeSize ty - 1     end   = typeSize ty - conSize ty -modifier offset (Nested m1 m2) = do-  case modifier offset m1 of-    Nothing    -> modifier offset m2-    Just (s,e,argTy) -> case modifier e m2 of+modifier r (Nested m1 m2) = do+  case modifier r m1 of+    Nothing -> modifier r m2+    Just (r1,argTy) -> case modifier r1 m2 of       -- In case the second modifier is `Nothing` that means we want the entire       -- thing calculated by the first modifier-      Nothing -> Just (s,e,argTy)+      Nothing -> Just (r1,argTy)       m       -> m  modifier _ _ = Nothing@@ -702,45 +869,67 @@   -> [(HWType, Expr)]   -- ^ Arguments applied to constructor   -> VerilogM Doc-customReprDataCon dataRepr constrRepr args =-  (flip fromMaybe) (errOnNonContinuous 0 anns) $-  braces $ hcat $ punctuate ", " $ mapM range' origins-    where-      anns = crFieldAnns constrRepr-      size = drSize dataRepr+customReprDataCon dataRepr constrRepr [] =+  let origins = bitOrigins dataRepr constrRepr :: [BitOrigin] in+  case origins of+    [Lit (bitsToBits -> ns)] ->+      int (length ns) <> squote <> "b" <> hcat (mapM (bit_char undefValue) ns)+    _ -> error "internal error"+customReprDataCon dataRepr constrRepr args = do+  funId <- mkConstrFunction+  Mon (imports %= HashSet.insert (Text.pack (TextS.unpack funId ++ ".inc")))+  stringS funId <> tupled (mapM (expr_ False . snd) nzArgs)+ where+  nzArgs = filter ((/=0) . typeSize . fst) args -      errOnNonContinuous :: Int -> [BitMask] -> Maybe a-      errOnNonContinuous _ [] = Nothing-      errOnNonContinuous fieldnr (ann:anns') =-        if isContinuousMask ann then-          errOnNonContinuous (fieldnr + 1) anns'-        else-          error $ $(curLoc) ++ unlines [-              "Error while processing custom bit representation:\n"-            , unwords ["Field", show fieldnr, "of constructor"-            , show (crName constrRepr), "of type\n"]-            , "  " ++ show (drType dataRepr) ++ "\n"-            , "has a non-continuous fieldmask:\n"-            , "  " ++ (map bit_char' $ toBits size ann) ++ "\n"-            , unwords [ "This is not supported in Verilog. Change the mask to a"-                      , "continuous one, or render using VHDL or SystemVerilog."-                      ]-            ]+  mkConstrFunction = makeCached (crName constrRepr) customConstrs $ do+    let size    = drSize dataRepr+        aTys    = map fst args+        origins = bitOrigins dataRepr constrRepr :: [BitOrigin]+    mkId <- Mon mkIdentifier+    let ids = [ mkId Basic (TextS.pack ('v':show n)) | n <- [1..length args] ]+        fId = mkId Basic (crName constrRepr)+    let fInps =+          [ case typeSize t of+              0 -> emptyDoc+              1 -> "input" <+> stringS i <> semi <> line+              n -> "input" <+> brackets (int (n-1) <> colon <> int 0) <+>+                               stringS i <> semi <> line+          | (i,t) <- zip ids aTys+          ] -      -- Build bit representations for all constructor arguments-      argExprs = map (expr_ False) (map snd args) :: [VerilogM Doc]+    let range' (Lit (bitsToBits -> ns)) =+          int (length ns) <> squote <> "b" <> hcat (mapM (bit_char undefValue) ns)+        range' (Field n start end) =+          let v   = ids !! n+              aTy = aTys !! n+          in case typeSize aTy of+               0 -> error "internal error"+               1 -> if start == 0 && end == 0 then+                      stringS v+                    else+                      error "internal error"+               _ -> stringS v <> brackets (int start <> colon <> int end) -      -- Spread bits of constructor arguments using masks-      origins = bitOrigins dataRepr constrRepr :: [BitOrigin]+    let val = case origins of+                []  -> error "internal error"+                [r] -> range' r+                rs  -> listBraces (mapM range' rs) -      range'-        :: BitOrigin-        -> VerilogM Doc-      range' (Lit (bitsToBits -> ns)) =-        int (length ns) <> squote <> "b" <> hcat (mapM (bit_char undefValue) ns)-      range' (Field n _start _end) =-        argExprs !! n+    let oSz = case size of+                0 -> error "internal error"+                1 -> emptyDoc+                n -> brackets (int (n-1) <> colon <> int 0) +    funDoc <-+      "function" <+> oSz <+> stringS fId <> semi <> line <>+      hcat (sequence fInps) <>+      "begin" <> line <>+      indent 2 (stringS fId <+> "=" <+> val <> semi) <> line <>+      "end" <> line <>+      "endfunction"+    Mon (includes %= ((TextS.unpack fId ++ ".inc",funDoc):))+    return fId  -- | Turn a Netlist expression into a Verilog expression expr_ :: Bool -- ^ Enclose in parentheses?@@ -795,11 +984,19 @@   traceIf (iw < w) ($(curLoc) ++ "WARNING: result smaller than argument") $     stringS id_ -expr_ _ (Identifier id_ (Just m)) = case modifier 0 m of+expr_ _ (Identifier id_ (Just m)) = case modifier (Contiguous 0 0) m of   Nothing          -> stringS id_-  Just (start,end,resTy) -> case resTy of-    Signed _ -> "$signed" <> parens (stringS id_ <> brackets (int start <> colon <> int end))-    _        ->                      stringS id_ <> brackets (int start <> colon <> int end)+  Just (Contiguous start end,resTy) -> case resTy of+    Signed _ -> "$signed" <> parens (slice start end)+    _        -> slice start end+  Just (Split rs,resTy) ->+    let rs1 = listBraces (mapM (\(start,end,_) -> slice start end) rs) in+    case resTy of+      Signed _ -> "$signed" <> parens rs1+      _ -> rs1++ where+  slice s e = stringS id_ <> brackets (int s <> colon <> int e)  expr_ b (DataCon _ (DC (Void {}, -1)) [e]) = expr_ b e 

@@ -0,0 +1,159 @@+{-# LANGUAGE OverloadedStrings #-}++module Clash.Core.EqSolver where++import Data.Maybe (catMaybes, mapMaybe)++import Clash.Core.Name (Name(nameOcc))+import Clash.Core.Term+import Clash.Core.TyCon+import Clash.Core.Type+import Clash.Core.Var++-- | Data type that indicates what kind of solution (if any) was found+data TypeEqSolution+  = Solution (TyVar, Type)+  -- ^ Solution was found. Variable equals some integer.+  | AbsurdSolution+  -- ^ A solution was found, but it involved negative naturals.+  | NoSolution+  -- ^ Given type wasn't an equation, or it was unsolvable.+    deriving (Show, Eq)++catSolutions :: [TypeEqSolution] -> [(TyVar, Type)]+catSolutions = mapMaybe getSol+ where+  getSol (Solution s) = Just s+  getSol _ = Nothing++-- | Solve given equations and return all non-absurd solutions+solveNonAbsurds :: TyConMap -> [(Type, Type)] -> [(TyVar, Type)]+solveNonAbsurds _tcm [] = []+solveNonAbsurds tcm (eq:eqs) =+  solved ++ solveNonAbsurds tcm eqs+ where+  solvers = [pure . solveAdd, solveEq tcm]+  solved = catSolutions (concat [s eq | s <- solvers])++-- | Solve simple equalities such as:+--+--   * a ~ 3+--   * 3 ~ a+--   * SomeType a b ~ SomeType 3 5+--   * SomeType 3 5 ~ SomeType a b+--   * SomeType a 5 ~ SomeType 3 b+--+solveEq :: TyConMap -> (Type, Type) -> [TypeEqSolution]+solveEq tcm (coreView tcm -> left, coreView tcm -> right) =+  case (left, right) of+    (VarTy tyVar, ConstTy {}) ->+      -- a ~ 3+      [Solution (tyVar, right)]+    (ConstTy {}, VarTy tyVar) ->+      -- 3 ~ a+      [Solution (tyVar, left)]+    (ConstTy {}, ConstTy {}) ->+      -- Int /= Char+      if left /= right then [AbsurdSolution] else []+    (LitTy {}, LitTy {}) ->+      -- 3 /= 5+      if left /= right then [AbsurdSolution] else []+    _ ->+      -- The call to 'coreView' at the start of 'solveEq' should have reduced+      -- all solvable type families. If we encounter one here that means the+      -- type family is stuck (and that we shouldn't compare it to anything!).+      if any (isTypeFamilyApplication tcm) [left, right] then+        []+      else+        case (tyView left, tyView right) of+          (TyConApp leftNm leftTys, TyConApp rightNm rightTys) ->+            -- SomeType a b ~ SomeType 3 5 (or other way around)+            if leftNm == rightNm then+              concat (map (solveEq tcm) (zip leftTys rightTys))+            else+              [AbsurdSolution]+          _ ->+            []++-- | Solve equations supported by @normalizeAdd@. See documentation of+-- @TypeEqSolution@ to understand the return value.+solveAdd+  :: (Type, Type)+  -> TypeEqSolution+solveAdd ab =+  case normalizeAdd ab of+    Just (n, m, VarTy tyVar) ->+      if n >= 0 && m >= 0 && n - m >= 0 then+        Solution (tyVar, (LitTy (NumTy (n - m))))+      else+        AbsurdSolution+    _ ->+      NoSolution++-- | Given the left and right side of an equation, normalize it such that+-- equations of the following forms:+--+--     * 5     ~ n + 2+--     * 5     ~ 2 + n+--     * n + 2 ~ 5+--     * 2 + n ~ 5+--+-- are returned as (5, 2, n)+normalizeAdd+  :: (Type, Type)+  -> Maybe (Integer, Integer, Type)+normalizeAdd (a, b) = do+  (n, rhs) <- lhsLit a b+  case tyView rhs of+    TyConApp (nameOcc -> "GHC.TypeNats.+") [left, right] -> do+      (m, o) <- lhsLit left right+      return (n, m, o)+    _ ->+      Nothing+ where+  lhsLit x                 (LitTy (NumTy n)) = Just (n, x)+  lhsLit (LitTy (NumTy n)) y                 = Just (n, y)+  lhsLit _                 _                 = Nothing++-- | Tests for unreachable alternative due to types being "absurd". See+-- @isAbsurdEq@ for more info.+isAbsurdAlt+  :: TyConMap+  -> Alt+  -> Bool+isAbsurdAlt tcm alt =+  any (isAbsurdEq tcm) (altEqs tcm alt)++-- | Determines if an "equation" obtained through @altEqs@ or @typeEq@ is+-- absurd. That is, it tests if two types that are definitely not equal are+-- asserted to be equal OR if the computation of the types yield some absurd+-- (intermediate) result such as -1.+isAbsurdEq+  :: TyConMap+  -> (Type, Type)+  -> Bool+isAbsurdEq tcm ((left0, right0)) =+  case (coreView tcm left0, coreView tcm right0) of+    (solveAdd -> AbsurdSolution) -> True+    lr -> any (==AbsurdSolution) (solveEq tcm lr)++-- | Get constraint equations+altEqs+  :: TyConMap+  -> Alt+  -> [(Type, Type)]+altEqs tcm (pat, _term) =+ catMaybes (map (typeEq tcm . varType) (snd (patIds pat)))++-- | If type is an equation, return LHS and RHS.+typeEq+  :: TyConMap+  -> Type+  -> Maybe (Type, Type)+typeEq tcm ty =+ case tyView (coreView tcm ty) of+  TyConApp (nameOcc -> "GHC.Prim.~#") [_, _, left, right] ->+    Just (coreView tcm left, coreView tcm right)+  _ ->+    Nothing+

@@ -26,7 +26,6 @@ import qualified Data.Primitive.ByteArray                as BA import qualified Data.Text as Text import qualified Data.Vector.Primitive                   as PV-import           Debug.Trace import           GHC.Integer.GMP.Internals   (Integer (..), BigNat (..)) @@ -38,11 +37,13 @@ import           Clash.Core.Pretty import           Clash.Core.Subst import           Clash.Core.Term+import           Clash.Core.TermInfo import           Clash.Core.TyCon import           Clash.Core.Type import           Clash.Core.Util import           Clash.Core.Var import           Clash.Core.VarEnv+import           Clash.Debug import           Clash.Driver.Types                      (BindingMap, Binding(..)) import           Clash.Pretty import           Clash.Unique

@@ -32,10 +32,10 @@ import Data.Default                     (Default(..)) import Data.Text                        (Text) import Control.Monad.Identity+import Data.List.Extra                  ((<:>)) import qualified Data.Text              as T import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Internal-import Debug.Trace                      (trace) import GHC.Show                         (showMultiLineString) import Numeric                          (fromRat) import qualified Outputable             as GHC@@ -49,6 +49,7 @@ import Clash.Core.Type                  (ConstTy (..), Kind, LitTy (..),                                          Type (..), TypeView (..), tyView) import Clash.Core.Var                   (Id, TyVar, Var (..), IdScope(..))+import Clash.Debug                      (trace) import Clash.Util import Clash.Pretty 

@@ -27,6 +27,9 @@   , substTy   , substTyWith   , substTyInVar+  , substGlobalsInExistentials+  , substInExistentials+  , substInExistentialsList     -- * Substitution into terms     -- ** Substitution environments   , Subst (..)@@ -55,6 +58,7 @@ import           Data.Coerce               (coerce) import           Data.Text.Prettyprint.Doc import qualified Data.List                 as List+import qualified Data.List.Extra           as List import           Data.Ord                  (comparing)  import           Clash.Core.FreeVars@@ -65,6 +69,7 @@ import           Clash.Core.Type           (Type (..)) import           Clash.Core.VarEnv import           Clash.Core.Var            (Id, Var (..), TyVar, isGlobalId)+import           Clash.Debug               (debugIsOn) import           Clash.Unique import           Clash.Util import           Clash.Pretty@@ -239,7 +244,7 @@   -> Subst zipTvSubst tvs tys   | debugIsOn-  , neLength tvs tys+  , not (List.equalLength tvs tys)   = pprTrace "zipTvSubst" (ppr tvs <> line <> ppr tys) emptySubst   | otherwise   = Subst (mkInScopeSet (tyFVsOfTypes tys)) emptyVarEnv tenv emptyVarEnv@@ -250,7 +255,7 @@   :: [TyVar]   -> [Type]   -> VarEnv Type-zipTyEnv tvs tys = mkVarEnv (zipEqual tvs tys)+zipTyEnv tvs tys = mkVarEnv (List.zipEqual tvs tys)  -- | Extend the substitution environment with a new 'Id' substitution extendIdSubst@@ -357,6 +362,63 @@   | otherwise   = substTy' subst ty +-- Safely substitute global type variables in a list of potentially+-- shadowing type variables.+substGlobalsInExistentials+  :: HasCallStack+  => InScopeSet+  -- ^ Variables in scope+  -> [TyVar]+  -- ^ List of existentials to apply the substitution for+  -> [(TyVar, Type)]+  -- ^ Substitutions+  -> [TyVar]+substGlobalsInExistentials is exts substs0 = result+  -- TODO: Is is actually possible that existentials shadow each other? If they+  -- TODO: can't, we can remove this function+  where+    iss     = scanl extendInScopeSet is exts+    substs1 = map (\is_ -> extendTvSubstList (mkSubst is_) substs0) iss+    result  = zipWith substTyInVar substs1 exts++-- | Safely substitute type variables in a list of existentials. This function+-- will account for cases where existentials shadow each other.+substInExistentialsList+  :: HasCallStack+  => InScopeSet+  -- ^ Variables in scope+  -> [TyVar]+  -- ^ List of existentials to apply the substitution for+  -> [(TyVar, Type)]+  -- ^ Substitutions+  -> [TyVar]+substInExistentialsList is exts substs =+  foldl (substInExistentials is) exts substs++-- | Safely substitute a type variable in a list of existentials. This function+-- will account for cases where existentials shadow each other.+substInExistentials+  :: HasCallStack+  => InScopeSet+  -- ^ Variables in scope+  -> [TyVar]+  -- ^ List of existentials to apply the substitution for+  -> (TyVar, Type)+  -- ^ Substitution+  -> [TyVar]+substInExistentials is exts subst@(typeVar, _type) =+  -- TODO: Is is actually possible that existentials shadow each other? If they+  -- TODO: can't, we can remove this function+  case List.elemIndices typeVar exts of+    [] ->+      -- We're not replacing any of the existentials, but a global variable+      substGlobalsInExistentials is exts [subst]+    (last -> i) ->+      -- We're replacing an existential. That means we're not touching any+      -- variables that were introduced before it. For all variables after it,+      -- it is as we would replace global variables in them.+      take (i+1) exts ++ substGlobalsInExistentials is (drop (i+1) exts) [subst]+ -- | This checks if the substitution satisfies the invariant from 'TvSbust's -- Note [The substitution invariant]. checkValidSubst@@ -610,7 +672,7 @@   -> Type   -> Type substTyWith tvs tys =-  ASSERT( tvs `equalLength` tys )+  ASSERT( List.equalLength tvs tys )   substTy (zipTvSubst tvs tys)  -- | Ensure that non of the binders in an expression shadow each-other, nor

@@ -15,27 +15,50 @@  module Clash.Core.Term   ( Term (..)+  , mkAbstraction+  , mkTyLams+  , mkLams+  , mkApps+  , mkTyApps+  , mkTmApps+  , mkTicks   , TmName+  , idToVar+  , varToId   , LetBinding   , Pat (..)+  , patIds+  , patVars   , Alt-  , TickInfo (..), NameMod (..)+  , TickInfo (..)+  , stripTicks+  , partitionTicks+  , NameMod (..)   , PrimInfo (..)   , WorkInfo (..)-  , CoreContext (..), Context, isLambdaBodyCtx, isTickCtx, walkTerm-  , collectArgs, collectArgsTicks, collectTicks, collectTermIds, primArg-  , partitionTicks-  )-where+  , CoreContext (..)+  , Context+  , isLambdaBodyCtx+  , isTickCtx+  , walkTerm+  , collectArgs+  , collectArgsTicks+  , collectTicks+  , collectTermIds+  , collectBndrs+  , primArg+  ) where  -- External Modules import Control.DeepSeq import Data.Binary                             (Binary)+import Data.Coerce                             (coerce) import qualified Data.DList                    as DList import Data.Either                             (lefts, rights)+import Data.Foldable                           (foldl') import Data.Maybe                              (catMaybes) import Data.Hashable                           (Hashable)-import Data.List                               (partition)+import Data.List                               (nub, partition) import Data.Text                               (Text) import GHC.Generics import SrcLoc                                  (SrcSpan)@@ -45,8 +68,9 @@ import Clash.Core.Literal                      (Literal) import Clash.Core.Name                         (Name (..)) import {-# SOURCE #-} Clash.Core.Subst         () -- instance Eq Type-import {-# SOURCE #-} Clash.Core.Type          (Type)-import Clash.Core.Var                          (Id, TyVar)+import {-# SOURCE #-} Clash.Core.Type+import Clash.Core.Var                          (Var(Id), Id)+import Clash.Util                              (curLoc)  -- | Term representation in the CoreHW language: System F + LetRec + Case data Term@@ -126,6 +150,42 @@  type Alt = (Pat,Term) +-- | Get the list of term-binders out of a DataType pattern+patIds :: Pat -> ([TyVar],[Id])+patIds (DataPat _  tvs ids) = (tvs,ids)+patIds _                    = ([],[])++patVars :: Pat -> [Var a]+patVars (DataPat _ tvs ids) = coerce tvs ++ coerce ids+patVars _ = []++-- | Abstract a term over a list of term and type variables+mkAbstraction :: Term -> [Either Id TyVar] -> Term+mkAbstraction = foldr (either Lam TyLam)++-- | Abstract a term over a list of term variables+mkTyLams :: Term -> [TyVar] -> Term+mkTyLams tm = mkAbstraction tm . map Right++-- | Abstract a term over a list of type variables+mkLams :: Term -> [Id] -> Term+mkLams tm = mkAbstraction tm . map Left++-- | Apply a list of types and terms to a term+mkApps :: Term -> [Either Term Type] -> Term+mkApps = foldl' (\e a -> either (App e) (TyApp e) a)++-- | Apply a list of terms to a term+mkTmApps :: Term -> [Term] -> Term+mkTmApps = foldl' App++-- | Apply a list of types to a term+mkTyApps :: Term -> [Type] -> Term+mkTyApps = foldl' TyApp++mkTicks :: Term -> [TickInfo] -> Term+mkTicks tm ticks = foldl' (\e s -> Tick s e) tm (nub ticks)+ -- | Context in which a term appears data CoreContext   = AppFun@@ -194,9 +254,12 @@ isTickCtx (TickC _) = True isTickCtx _         = False +stripTicks :: Term -> Term+stripTicks (Tick _ e) = stripTicks e+stripTicks e = e+ -- | Split a (Type)Application in the applied term and it arguments-collectArgs :: Term-            -> (Term, [Either Term Type])+collectArgs :: Term -> (Term, [Either Term Type]) collectArgs = go []   where     go args (App e1 e2) = go (Left e2:args) e1@@ -204,17 +267,13 @@     go args (Tick _ e)  = go args e     go args e           = (e, args) -collectTicks-  :: Term-  -> (Term, [TickInfo])+collectTicks :: Term -> (Term, [TickInfo]) collectTicks = go []  where   go ticks (Tick s e) = go (s:ticks) e   go ticks e          = (e,ticks) -collectArgsTicks-  :: Term-  -> (Term, [Either Term Type], [TickInfo])+collectArgsTicks :: Term -> (Term, [Either Term Type], [TickInfo]) collectArgsTicks = go [] []  where   go args ticks (App e1 e2) = go (Left e2:args) ticks     e1@@ -222,6 +281,14 @@   go args ticks (Tick s e)  = go args           (s:ticks) e   go args ticks e           = (e, args, ticks) +-- | Split a (Type)Abstraction in the bound variables and the abstracted term+collectBndrs :: Term -> ([Either Id TyVar], Term)+collectBndrs = go []+ where+  go bs (Lam v e')    = go (Left v:bs) e'+  go bs (TyLam tv e') = go (Right tv:bs) e'+  go bs e'            = (reverse bs,e')+ -- | Given a function application, find the primitive it's applied. Yields -- Nothing if given term is not an application or if it is not a primitive. primArg@@ -285,3 +352,14 @@   pat (DataPat _ _ ids) = ids   pat (LitPat _) = []   pat DefaultPat = []++-- | Make variable reference out of term variable+idToVar :: Id -> Term+idToVar i@(Id {}) = Var i+idToVar tv        = error $ $(curLoc) ++ "idToVar: tyVar: " ++ show tv++-- | Make a term variable out of a variable reference+varToId :: Term -> Id+varToId (Var i) = i+varToId e       = error $ $(curLoc) ++ "varToId: not a var: " ++ show e+

@@ -0,0 +1,230 @@+{-# LANGUAGE QuasiQuotes #-}++module Clash.Core.TermInfo where++import Data.Text.Prettyprint.Doc (line)++import Clash.Core.DataCon+import Clash.Core.FreeVars+import Clash.Core.Literal+import Clash.Core.Pretty+import Clash.Core.Subst+import Clash.Core.Term+import Clash.Core.TyCon (TyConMap)+import Clash.Core.Type+import Clash.Core.Var+import Clash.Core.VarEnv+import Clash.Debug (debugIsOn)+import Clash.Util+import Clash.Util.Interpolate as I++termSize :: Term -> Word+termSize (Var {})     = 1+termSize (Data {})    = 1+termSize (Literal {}) = 1+termSize (Prim {})    = 1+termSize (Lam _ e)    = termSize e + 1+termSize (TyLam _ e)  = termSize e+termSize (App e1 e2)  = termSize e1 + termSize e2+termSize (TyApp e _)  = termSize e+termSize (Cast e _ _) = termSize e+termSize (Tick _ e)   = termSize e+termSize (Letrec bndrs e) = sum (bodySz:bndrSzs)+ where+  bndrSzs = map (termSize . snd) bndrs+  bodySz  = termSize e+termSize (Case subj _ alts) = sum (subjSz:altSzs)+ where+  subjSz = termSize subj+  altSzs = map (termSize . snd) alts++-- | Determine the type of a term+termType :: TyConMap -> Term -> Type+termType m e = case e of+  Var t          -> varType t+  Data dc        -> dcType dc+  Literal l      -> literalType l+  Prim t         -> primType t+  Lam v e'       -> mkFunTy (varType v) (termType m e')+  TyLam tv e'    -> ForAllTy tv (termType m e')+  App _ _        -> case collectArgs e of+                      (fun, args) -> applyTypeToArgs e m (termType m fun) args+  TyApp _ _      -> case collectArgs e of+                      (fun, args) -> applyTypeToArgs e m (termType m fun) args+  Letrec _ e'    -> termType m e'+  Case _ ty _    -> ty+  Cast _ _ ty2   -> ty2+  Tick _ e'      -> termType m e'++-- | Get the result type of a polymorphic function given a list of arguments+applyTypeToArgs+  :: Term+  -> TyConMap+  -> Type+  -> [Either Term Type]+  -> Type+applyTypeToArgs e m opTy args = go opTy args+ where+  go opTy' []               = opTy'+  go opTy' (Right ty:args') = goTyArgs opTy' [ty] args'+  go opTy' (Left _:args')   = case splitFunTy m opTy' of+    Just (_,resTy) -> go resTy args'+    _ -> error $ unlines ["applyTypeToArgs:"+                         ,"Expression: " ++ showPpr e+                         ,"Type: " ++ showPpr opTy+                         ,"Args: " ++ unlines (map (either showPpr showPpr) args)+                         ]++  goTyArgs opTy' revTys (Right ty:args') = goTyArgs opTy' (ty:revTys) args'+  goTyArgs opTy' revTys args'            = go (piResultTys m opTy' (reverse revTys)) args'++-- | Like 'piResultTyMaybe', but errors out when a type application is not+-- valid.+--+-- Do not iterate 'piResultTy', because it's inefficient to substitute one+-- variable at a time; instead use 'piResultTys'+piResultTy+  :: HasCallStack+  => TyConMap+  -> Type+  -> Type+  -> Type+piResultTy m ty arg = case piResultTyMaybe m ty arg of+  Just res -> res+  Nothing  -> pprPanic "piResultTy" (ppr ty <> line <> ppr arg)++-- | Like 'piResultTys' but for a single argument.+--+-- Do not iterate 'piResultTyMaybe', because it's inefficient to substitute one+-- variable at a time; instead use 'piResultTys'+piResultTyMaybe+  :: HasCallStack+  => TyConMap+  -> Type+  -> Type+  -> Maybe Type+piResultTyMaybe m ty arg+  | Just ty' <- coreView1 m ty+  = piResultTyMaybe m ty' arg+  | FunTy a res <- tyView ty+  = if debugIsOn && not (aeqType a arg) then error [I.i|+      Unexpected application. A function with type:++        #{showPpr ty}++      Got applied to an argument of type:++        #{showPpr arg}+    |]+    else+      Just res+  | ForAllTy tv res <- ty+  = let emptySubst = mkSubst (mkInScopeSet (tyFVsOfTypes [arg,res]))+    in  Just (substTy (extendTvSubst emptySubst tv arg) res)+  | otherwise+  = Nothing++-- | @(piResultTys f_ty [ty1, ..., tyn])@ give sthe type of @(f ty1 .. tyn)@+-- where @f :: f_ty@+--+-- 'piResultTys' is interesting because:+--+--    1. 'f_ty' may have more foralls than there are args+--    2. Less obviously, it may have fewer foralls+--+-- Fore case 2. think of:+--+--   piResultTys (forall a . a) [forall b.b, Int]+--+-- This really can happen, such as situations involving 'undefined's type:+--+--   undefined :: forall a. a+--+--   undefined (forall b. b -> b) Int+--+-- This term should have the type @(Int -> Int)@, but notice that there are+-- more type args than foralls in 'undefined's type.+--+-- For efficiency reasons, when there are no foralls, we simply drop arrows from+-- a function type/kind.+piResultTys+  :: HasCallStack+  => TyConMap+  -> Type+  -> [Type]+  -> Type+piResultTys _ ty [] = ty+piResultTys m ty origArgs@(arg:args)+  | Just ty' <- coreView1 m ty+  = piResultTys m ty' origArgs+  | FunTy a res <- tyView ty+  = if debugIsOn && not (aeqType a arg) then error [I.i|+      Unexpected application. A function with type:++        #{showPpr ty}++      Got applied to an argument of type:++        #{showPpr arg}+    |]+    else+      piResultTys m res args+  | ForAllTy tv res <- ty+  = go (extendVarEnv tv arg emptyVarEnv) res args+  | otherwise+  = pprPanic "piResultTys1" (ppr ty <> line <> ppr origArgs)+ where+  inScope = mkInScopeSet (tyFVsOfTypes (ty:origArgs))++  go env ty' [] = substTy (mkTvSubst inScope env) ty'+  go env ty' allArgs@(arg':args')+    | Just ty'' <- coreView1 m ty'+    = go env ty'' allArgs+    | FunTy _ res <- tyView ty'+    = go env res args'+    | ForAllTy tv res <- ty'+    = go (extendVarEnv tv arg' env) res args'+    | VarTy tv <- ty'+    , Just ty'' <- lookupVarEnv tv env+      -- Deals with (piResultTys  (forall a.a) [forall b.b, Int])+    = piResultTys m ty'' allArgs+    | otherwise+    = pprPanic "piResultTys2" (ppr ty' <> line <> ppr origArgs <> line <> ppr allArgs)++-- | Does a term have a function type?+isFun :: TyConMap -> Term -> Bool+isFun m t = isFunTy m (termType m t)++-- | Does a term have a function or polymorphic type?+isPolyFun :: TyConMap -> Term -> Bool+isPolyFun m t = isPolyFunCoreTy m (termType m t)++-- | Is a term a term-abstraction?+isLam :: Term -> Bool+isLam (Lam {}) = True+isLam _        = False++-- | Is a term a recursive let-binding?+isLet :: Term -> Bool+isLet (Letrec {}) = True+isLet _           = False++-- | Is a term a variable reference?+isVar :: Term -> Bool+isVar (Var {}) = True+isVar _        = False++isLocalVar :: Term -> Bool+isLocalVar (Var v) = isLocalId v+isLocalVar _ = False++-- | Is a term a datatype constructor?+isCon :: Term -> Bool+isCon (Data {}) = True+isCon _         = False++-- | Is a term a primitive?+isPrim :: Term -> Bool+isPrim (Prim {}) = True+isPrim _         = False+

@@ -63,6 +63,7 @@ import           Data.Coerce            (coerce) import           Data.Hashable          (Hashable) import           Data.List              (foldl')+import           Data.List.Extra        (splitAtList) import           Data.Maybe             (isJust, mapMaybe) import           GHC.Base               (isTrue#,(==#)) import           GHC.Generics           (Generic(..))@@ -452,10 +453,8 @@       Just ty' | ty' `aeqType` ty -> Just s       _ -> Nothing     go ty1 (reduceTypeFamily tcm -> Just ty2) = go ty1 ty2 -- See [Note: lazy type families]-    go ty1@(LitTy _) ty2 = if ty1 `aeqType` ty2 then Just s else Nothing-    go (tyView -> TyConApp tc argTys) (tyView -> TyConApp tc' argTys')-      | tc == tc'-      = foldl' (funSubst tcm) (Just s) (zip argTys argTys')+    -- [Note] funSubst FunTy+    --     -- Whenever type classes have associated types whose instances 'map' to     -- functions, we try to find substitutions in the LHS and RHS of these     -- (type-level) functions. Because we use @funSubst@ recursively, we@@ -472,9 +471,17 @@     -- matching against `Char -> Char` we'd find a duplicate `a -> Char`. We     -- can't think of any (type-checking) cases where these mappings would map     -- to different types, so this is OK for our purposes.-    go (tyView -> FunTy a b) (tyView -> FunTy a' b') =-      (++) <$> funSubst tcm (Just s) (a, a')-           <*> funSubst tcm (Just s) (b, b')+    go (AppTy a1 r1) (AppTy a2 r2) = do+      s1 <- funSubst tcm (Just s) (a1, a2)+      funSubst tcm (Just s1) (r1, r2)++    go ty1@(ConstTy _) ty2 =+      -- Looks through AnnType+      if ty1 `aeqType` ty2 then Just s else Nothing++    go ty1@(LitTy _) ty2 =+      -- Looks through AnnType+      if ty1 `aeqType` ty2 then Just s else Nothing      go _ _ = Nothing 

@@ -17,18 +17,15 @@ import           Control.Concurrent.Supply     (Supply, freshId) import qualified Control.Lens                  as Lens import Control.Monad.Trans.Except              (Except, throwE)-import           Data.Coerce                   (coerce) import qualified Data.HashSet                  as HashSet import qualified Data.Graph                    as Graph-import Data.List-  (foldl', mapAccumR, elemIndices, nub)+import Data.List                               (foldl', mapAccumR)+import Data.List.Extra                         (zipEqual) import Data.Maybe   (fromJust, isJust, mapMaybe, catMaybes) import qualified Data.Set                      as Set import qualified Data.Set.Lens                 as Lens-import qualified Data.String.Interpolate       as I import qualified Data.Text                     as T-import           Data.Text.Prettyprint.Doc     (line) #if !MIN_VERSION_base(4,11,0) import           Data.Semigroup #endif@@ -37,541 +34,22 @@ import           Unique                  (getKey)  import Clash.Core.DataCon-  (DataCon (MkData), dcType, dcUnivTyVars, dcExtTyVars, dcArgTys)-import Clash.Core.FreeVars-  (tyFVsOfTypes, typeFreeVars, freeLocalIds)-import Clash.Core.Literal                      (literalType)+import Clash.Core.EqSolver+import Clash.Core.FreeVars               (tyFVsOfTypes, typeFreeVars, freeLocalIds) import Clash.Core.Name   (Name (..), OccName, mkUnsafeInternalName, mkUnsafeSystemName)-import Clash.Core.Pretty                       (ppr, showPpr)+import Clash.Core.Pretty                 (showPpr) import Clash.Core.Subst-  (extendTvSubst, mkSubst, mkTvSubst, substTy, substTyWith,-   substTyInVar, extendTvSubstList, aeqType) import Clash.Core.Term-  (LetBinding, Pat (..), PrimInfo (..), Term (..), Alt, WorkInfo (..),-   TickInfo (..), collectArgs)+import Clash.Core.TyCon                  (TyConMap, tyConDataCons) import Clash.Core.Type-  (Kind, LitTy (..), Type (..), TypeView (..),-   coreView, coreView1, isFunTy, isPolyFunCoreTy, mkFunTy, splitFunTy, tyView,-   undefinedTy, isTypeFamilyApplication)-import Clash.Core.TyCon-  (TyConMap, tyConDataCons)-import Clash.Core.TysPrim                      (typeNatKind)-import Clash.Core.Var-  (Id, TyVar, Var (..), isLocalId, mkLocalId, mkTyVar)+import Clash.Core.TysPrim                (typeNatKind)+import Clash.Core.Var                    (Id, Var(..), mkLocalId, mkTyVar) import Clash.Core.VarEnv-  (InScopeSet, VarEnv, emptyVarEnv, extendInScopeSet, extendVarEnv,-   lookupVarEnv, mkInScopeSet, uniqAway, extendInScopeSetList, unionInScope,-   mkVarSet, unionVarSet, unitVarSet, emptyVarSet)+import Clash.Debug                       (traceIf) import Clash.Unique import Clash.Util --- | Type environment/context-type Gamma = VarEnv Type--- | Kind environment/context-type Delta = VarEnv Kind---- | Given the left and right side of an equation, normalize it such that--- equations of the following forms:------     * 5     ~ n + 2---     * 5     ~ 2 + n---     * n + 2 ~ 5---     * 2 + n ~ 5------ are returned as (5, 2, n)-normalizeAdd-  :: (Type, Type)-  -> Maybe (Integer, Integer, Type)-normalizeAdd (a, b) = do-  (n, rhs) <- lhsLit a b-  case tyView rhs of-    TyConApp (nameOcc -> "GHC.TypeNats.+") [left, right] -> do-      (m, o) <- lhsLit left right-      return (n, m, o)-    _ ->-      Nothing- where-  lhsLit x                 (LitTy (NumTy n)) = Just (n, x)-  lhsLit (LitTy (NumTy n)) y                 = Just (n, y)-  lhsLit _                 _                 = Nothing---- | Data type that indicates what kind of solution (if any) was found-data TypeEqSolution-  = Solution (TyVar, Type)-  -- ^ Solution was found. Variable equals some integer.-  | AbsurdSolution-  -- ^ A solution was found, but it involved negative naturals.-  | NoSolution-  -- ^ Given type wasn't an equation, or it was unsolvable.-    deriving (Show, Eq)--catSolutions :: [TypeEqSolution] -> [(TyVar, Type)]-catSolutions = mapMaybe getSol- where-  getSol (Solution s) = Just s-  getSol _ = Nothing---- | Solve given equations and return all non-absurd solutions-solveNonAbsurds :: TyConMap -> [(Type, Type)] -> [(TyVar, Type)]-solveNonAbsurds _tcm [] = []-solveNonAbsurds tcm (eq:eqs) =-  solved ++ solveNonAbsurds tcm eqs- where-  solvers = [pure . solveAdd, solveEq tcm]-  solved = catSolutions (concat [s eq | s <- solvers])---- | Solve simple equalities such as:------   * a ~ 3---   * 3 ~ a---   * SomeType a b ~ SomeType 3 5---   * SomeType 3 5 ~ SomeType a b---   * SomeType a 5 ~ SomeType 3 b----solveEq :: TyConMap -> (Type, Type) -> [TypeEqSolution]-solveEq tcm (coreView tcm -> left, coreView tcm -> right) =-  case (left, right) of-    (VarTy tyVar, ConstTy {}) ->-      -- a ~ 3-      [Solution (tyVar, right)]-    (ConstTy {}, VarTy tyVar) ->-      -- 3 ~ a-      [Solution (tyVar, left)]-    (ConstTy {}, ConstTy {}) ->-      -- Int /= Char-      if left /= right then [AbsurdSolution] else []-    (LitTy {}, LitTy {}) ->-      -- 3 /= 5-      if left /= right then [AbsurdSolution] else []-    _ ->-      -- The call to 'coreView' at the start of 'solveEq' should have reduced-      -- all solvable type families. If we encounter one here that means the-      -- type family is stuck (and that we shouldn't compare it to anything!).-      if any (isTypeFamilyApplication tcm) [left, right] then-        []-      else-        case (tyView left, tyView right) of-          (TyConApp leftNm leftTys, TyConApp rightNm rightTys) ->-            -- SomeType a b ~ SomeType 3 5 (or other way around)-            if leftNm == rightNm then-              concat (map (solveEq tcm) (zip leftTys rightTys))-            else-              [AbsurdSolution]-          _ ->-            []---- | Solve equations supported by @normalizeAdd@. See documentation of--- @TypeEqSolution@ to understand the return value.-solveAdd-  :: (Type, Type)-  -> TypeEqSolution-solveAdd ab =-  case normalizeAdd ab of-    Just (n, m, VarTy tyVar) ->-      if n >= 0 && m >= 0 && n - m >= 0 then-        Solution (tyVar, (LitTy (NumTy (n - m))))-      else-        AbsurdSolution-    _ ->-      NoSolution---- | If type is an equation, return LHS and RHS.-typeEq-  :: TyConMap-  -> Type-  -> Maybe (Type, Type)-typeEq tcm ty =- case tyView (coreView tcm ty) of-  TyConApp (nameOcc -> "GHC.Prim.~#") [_, _, left, right] ->-    Just (coreView tcm left, coreView tcm right)-  _ ->-    Nothing---- | Get constraint equations-altEqs-  :: TyConMap-  -> Alt-  -> [(Type, Type)]-altEqs tcm (pat, _term) =- catMaybes (map (typeEq tcm . varType) (snd (patIds pat)))---- | Tests for unreachable alternative due to types being "absurd". See--- @isAbsurdEq@ for more info.-isAbsurdAlt-  :: TyConMap-  -> Alt-  -> Bool-isAbsurdAlt tcm alt =-  any (isAbsurdEq tcm) (altEqs tcm alt)---- | Determines if an "equation" obtained through @altEqs@ or @typeEq@ is--- absurd. That is, it tests if two types that are definitely not equal are--- asserted to be equal OR if the computation of the types yield some absurd--- (intermediate) result such as -1.-isAbsurdEq-  :: TyConMap-  -> (Type, Type)-  -> Bool-isAbsurdEq tcm ((left0, right0)) =-  case (coreView tcm left0, coreView tcm right0) of-    (solveAdd -> AbsurdSolution) -> True-    lr -> any (==AbsurdSolution) (solveEq tcm lr)---- Safely substitute global type variables in a list of potentially--- shadowing type variables.-substGlobalsInExistentials-  :: HasCallStack-  => InScopeSet-  -- ^ Variables in scope-  -> [TyVar]-  -- ^ List of existentials to apply the substitution for-  -> [(TyVar, Type)]-  -- ^ Substitutions-  -> [TyVar]-substGlobalsInExistentials is exts substs0 = result-  -- TODO: Is is actually possible that existentials shadow each other? If they-  -- TODO: can't, we can remove this function-  where-    iss     = scanl extendInScopeSet is exts-    substs1 = map (\is_ -> extendTvSubstList (mkSubst is_) substs0) iss-    result  = zipWith substTyInVar substs1 exts---- | Safely substitute type variables in a list of existentials. This function--- will account for cases where existentials shadow each other.-substInExistentialsList-  :: HasCallStack-  => InScopeSet-  -- ^ Variables in scope-  -> [TyVar]-  -- ^ List of existentials to apply the substitution for-  -> [(TyVar, Type)]-  -- ^ Substitutions-  -> [TyVar]-substInExistentialsList is exts substs =-  foldl (substInExistentials is) exts substs---- | Safely substitute a type variable in a list of existentials. This function--- will account for cases where existentials shadow each other.-substInExistentials-  :: HasCallStack-  => InScopeSet-  -- ^ Variables in scope-  -> [TyVar]-  -- ^ List of existentials to apply the substitution for-  -> (TyVar, Type)-  -- ^ Substitution-  -> [TyVar]-substInExistentials is exts subst@(typeVar, _type) =-  -- TODO: Is is actually possible that existentials shadow each other? If they-  -- TODO: can't, we can remove this function-  case elemIndices typeVar exts of-    [] ->-      -- We're not replacing any of the existentials, but a global variable-      substGlobalsInExistentials is exts [subst]-    (last -> i) ->-      -- We're replacing an existential. That means we're not touching any-      -- variables that were introduced before it. For all variables after it,-      -- it is as we would replace global variables in them.-      take (i+1) exts ++ substGlobalsInExistentials is (drop (i+1) exts) [subst]---- | Determine the type of a term-termType-  :: TyConMap-  -> Term-  -> Type-termType m e = case e of-  Var t          -> varType t-  Data dc        -> dcType dc-  Literal l      -> literalType l-  Prim t         -> primType t-  Lam v e'       -> mkFunTy (varType v) (termType m e')-  TyLam tv e'    -> ForAllTy tv (termType m e')-  App _ _        -> case collectArgs e of-                      (fun, args) -> applyTypeToArgs e m (termType m fun) args-  TyApp _ _      -> case collectArgs e of-                      (fun, args) -> applyTypeToArgs e m (termType m fun) args-  Letrec _ e'    -> termType m e'-  Case _ ty _    -> ty-  Cast _ _ ty2   -> ty2-  Tick _ e'      -> termType m e'---- | Split a (Type)Abstraction in the bound variables and the abstracted term-collectBndrs :: Term-             -> ([Either Id TyVar], Term)-collectBndrs = go []-  where-    go bs (Lam v e')    = go (Left v:bs) e'-    go bs (TyLam tv e') = go (Right tv:bs) e'-    go bs e'            = (reverse bs,e')---- | Get the result type of a polymorphic function given a list of arguments-applyTypeToArgs-  :: Term-  -> TyConMap-  -> Type-  -> [Either Term Type]-  -> Type-applyTypeToArgs e m opTy args = go opTy args- where-  go opTy' []               = opTy'-  go opTy' (Right ty:args') = goTyArgs opTy' [ty] args'-  go opTy' (Left _:args')   = case splitFunTy m opTy' of-    Just (_,resTy) -> go resTy args'-    _ -> error $ unlines ["applyTypeToArgs:"-                         ,"Expression: " ++ showPpr e-                         ,"Type: " ++ showPpr opTy-                         ,"Args: " ++ unlines (map (either showPpr showPpr) args)-                         ]--  goTyArgs opTy' revTys (Right ty:args') = goTyArgs opTy' (ty:revTys) args'-  goTyArgs opTy' revTys args'            = go (piResultTys m opTy' (reverse revTys)) args'---- | Like 'piResultTyMaybe', but errors out when a type application is not--- valid.------ Do not iterate 'piResultTy', because it's inefficient to substitute one--- variable at a time; instead use 'piResultTys'-piResultTy-  :: HasCallStack-  => TyConMap-  -> Type-  -> Type-  -> Type-piResultTy m ty arg = case piResultTyMaybe m ty arg of-  Just res -> res-  Nothing  -> pprPanic "piResultTy" (ppr ty <> line <> ppr arg)---- | Like 'piResultTys' but for a single argument.------ Do not iterate 'piResultTyMaybe', because it's inefficient to substitute one--- variable at a time; instead use 'piResultTys'-piResultTyMaybe-  :: HasCallStack-  => TyConMap-  -> Type-  -> Type-  -> Maybe Type-piResultTyMaybe m ty arg-  | Just ty' <- coreView1 m ty-  = piResultTyMaybe m ty' arg-  | FunTy a res <- tyView ty-  = if debugIsOn && not (aeqType a arg) then error [I.i|-      Unexpected application. A function with type:--        #{showPpr ty}--      Got applied to an argument of type:--        #{showPpr arg}-    |]-    else-      Just res-  | ForAllTy tv res <- ty-  = let emptySubst = mkSubst (mkInScopeSet (tyFVsOfTypes [arg,res]))-    in  Just (substTy (extendTvSubst emptySubst tv arg) res)-  | otherwise-  = Nothing---- | @(piResultTys f_ty [ty1, ..., tyn])@ give sthe type of @(f ty1 .. tyn)@--- where @f :: f_ty@------ 'piResultTys' is interesting because:------    1. 'f_ty' may have more foralls than there are args---    2. Less obviously, it may have fewer foralls------ Fore case 2. think of:------   piResultTys (forall a . a) [forall b.b, Int]------ This really can happen, such as situations involving 'undefined's type:------   undefined :: forall a. a------   undefined (forall b. b -> b) Int------ This term should have the type @(Int -> Int)@, but notice that there are--- more type args than foralls in 'undefined's type.------ For efficiency reasons, when there are no foralls, we simply drop arrows from--- a function type/kind.-piResultTys-  :: HasCallStack-  => TyConMap-  -> Type-  -> [Type]-  -> Type-piResultTys _ ty [] = ty-piResultTys m ty origArgs@(arg:args)-  | Just ty' <- coreView1 m ty-  = piResultTys m ty' origArgs-  | FunTy a res <- tyView ty-  = if debugIsOn && not (aeqType a arg) then error [I.i|-      Unexpected application. A function with type:--        #{showPpr ty}--      Got applied to an argument of type:--        #{showPpr arg}-    |]-    else-      piResultTys m res args-  | ForAllTy tv res <- ty-  = go (extendVarEnv tv arg emptyVarEnv) res args-  | otherwise-  = pprPanic "piResultTys1" (ppr ty <> line <> ppr origArgs)- where-  inScope = mkInScopeSet (tyFVsOfTypes (ty:origArgs))--  go env ty' [] = substTy (mkTvSubst inScope env) ty'-  go env ty' allArgs@(arg':args')-    | Just ty'' <- coreView1 m ty'-    = go env ty'' allArgs-    | FunTy _ res <- tyView ty'-    = go env res args'-    | ForAllTy tv res <- ty'-    = go (extendVarEnv tv arg' env) res args'-    | VarTy tv <- ty'-    , Just ty'' <- lookupVarEnv tv env-      -- Deals with (piResultTys  (forall a.a) [forall b.b, Int])-    = piResultTys m ty'' allArgs-    | otherwise-    = pprPanic "piResultTys2" (ppr ty' <> line <> ppr origArgs <> line <> ppr allArgs)---- | Get the list of term-binders out of a DataType pattern-patIds :: Pat -> ([TyVar],[Id])-patIds (DataPat _  tvs ids) = (tvs,ids)-patIds _                    = ([],[])--patVars :: Pat -> [Var a]-patVars (DataPat _ tvs ids) = coerce tvs ++ coerce ids-patVars _ = []---- | Abstract a term over a list of term and type variables-mkAbstraction :: Term-              -> [Either Id TyVar]-              -> Term-mkAbstraction = foldr (either Lam TyLam)---- | Abstract a term over a list of term variables-mkTyLams :: Term-         -> [TyVar]-         -> Term-mkTyLams tm = mkAbstraction tm . map Right---- | Abstract a term over a list of type variables-mkLams :: Term-       -> [Id]-       -> Term-mkLams tm = mkAbstraction tm . map Left---- | Apply a list of types and terms to a term-mkApps :: Term-       -> [Either Term Type]-       -> Term-mkApps = foldl' (\e a -> either (App e) (TyApp e) a)---- | Apply a list of terms to a term-mkTmApps :: Term-         -> [Term]-         -> Term-mkTmApps = foldl' App---- | Apply a list of types to a term-mkTyApps :: Term-         -> [Type]-         -> Term-mkTyApps = foldl' TyApp--mkTicks-  :: Term-  -> [TickInfo]-  -> Term-mkTicks tm ticks = foldl' (\e s -> Tick s e) tm (nub ticks)---- | Does a term have a function type?-isFun :: TyConMap-      -> Term-      -> Bool-isFun m t = isFunTy m (termType m t)---- | Does a term have a function or polymorphic type?-isPolyFun :: TyConMap-          -> Term-          -> Bool-isPolyFun m t = isPolyFunCoreTy m (termType m t)---- | Is a term a term-abstraction?-isLam :: Term-      -> Bool-isLam (Lam {}) = True-isLam _        = False---- | Is a term a recursive let-binding?-isLet :: Term-      -> Bool-isLet (Letrec {}) = True-isLet _           = False---- | Is a term a variable reference?-isVar :: Term-      -> Bool-isVar (Var {}) = True-isVar _        = False--isLocalVar-  :: Term-  -> Bool-isLocalVar (Var v) = isLocalId v-isLocalVar _ = False---- | Is a term a datatype constructor?-isCon :: Term-      -> Bool-isCon (Data {}) = True-isCon _         = False---- | Is a term a primitive?-isPrim :: Term-       -> Bool-isPrim (Prim {}) = True-isPrim _         = False---- | Make variable reference out of term variable-idToVar :: Id-        -> Term-idToVar i@(Id {}) = Var i-idToVar tv        = error $ $(curLoc) ++ "idToVar: tyVar: " ++ showPpr tv---- | Make a term variable out of a variable reference-varToId :: Term-        -> Id-varToId (Var i) = i-varToId e       = error $ $(curLoc) ++ "varToId: not a var: " ++ showPpr e--termSize :: Term-         -> Word-termSize (Var {})     = 1-termSize (Data {})    = 1-termSize (Literal {}) = 1-termSize (Prim {})    = 1-termSize (Lam _ e)    = termSize e + 1-termSize (TyLam _ e)  = termSize e-termSize (App e1 e2)  = termSize e1 + termSize e2-termSize (TyApp e _)  = termSize e-termSize (Cast e _ _) = termSize e-termSize (Tick _ e)   = termSize e-termSize (Letrec bndrs e) = sum (bodySz:bndrSzs)- where-  bndrSzs = map (termSize . snd) bndrs-  bodySz  = termSize e-termSize (Case subj _ alts) = sum (subjSz:altSzs)- where-  subjSz = termSize subj-  altSzs = map (termSize . snd) alts- -- | Create a vector of supplied elements mkVec :: DataCon -- ^ The Nil constructor       -> DataCon -- ^ The Cons (:>) constructor@@ -960,10 +438,6 @@       -- See Note [The substitution invariant]       subst   = extendTvSubstList (mkSubst is) (univTVs `zipEqual` args)   in  map (substTy subst) (dcArgTys dc)--stripTicks :: Term -> Term-stripTicks (Tick _ e) = stripTicks e-stripTicks e = e  -- | Try to reduce an arbitrary type to a literal type (Symbol or Nat), -- and subsequently extract its String representation

@@ -95,6 +95,7 @@ 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) import           Data.Text.Prettyprint.Doc import           GHC.Exts                  (Any)@@ -102,6 +103,7 @@  import           Clash.Core.Pretty         () import           Clash.Core.Var+import           Clash.Debug               (debugIsOn) import           Clash.Unique import           Clash.Util import           Clash.Pretty@@ -554,7 +556,7 @@ rnTyBndrs   :: RnEnv -> [TyVar] -> [TyVar] -> RnEnv rnTyBndrs env tvs1 tvs2 =-  List.foldl' (\s (l,r) -> rnTyBndr s l r) env (zipEqual 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@@ -585,4 +587,4 @@ rnTmBndrs   :: RnEnv -> [Id] -> [Id] -> RnEnv rnTmBndrs env ids1 ids2 =-  List.foldl' (\s (l,r) -> rnTmBndr s l r) env (zipEqual ids1 ids2)+  List.foldl' (\s (l,r) -> rnTmBndr s l r) env (List.zipEqual ids1 ids2)

@@ -0,0 +1,31 @@+{-# LANGUAGE CPP #-}++module Clash.Debug+  ( debugIsOn+  , traceIf+  , traceWith+  , traceShowWith+  , module Debug.Trace+  ) where++import Debug.Trace++debugIsOn :: Bool+#if defined(DEBUG)+debugIsOn = True+#else+debugIsOn = False+#endif++-- | Performs trace when first argument evaluates to 'True'+traceIf :: Bool -> String -> a -> a+traceIf True  msg = trace msg+traceIf False _   = id+{-# INLINE traceIf #-}++traceWith :: (a -> String) -> a -> a+traceWith f a = trace (f a) a++traceShowWith :: Show b => (a -> b) -> a -> a+traceShowWith f a = trace (show (f a)) a+

@@ -85,6 +85,7 @@   (Id, varName, varUniq, varType) import           Clash.Core.VarEnv   (elemVarEnv, emptyVarEnv, lookupVarEnv)+import           Clash.Debug                      (debugIsOn) import           Clash.Driver.Types import           Clash.Netlist                    (genNetlist) import           Clash.Netlist.Util               (genComponentName, genTopComponentName)@@ -107,7 +108,7 @@ import           Clash.Util.Interpolate           (i) import           Clash.Util   (ClashException(..), HasCallStack, first, reportTimeDiff,-   wantedLanguageExtensions, unwantedLanguageExtensions, debugIsOn)+   wantedLanguageExtensions, unwantedLanguageExtensions) import           Clash.Util.Graph                 (reverseTopSort)  -- | Worker function of 'splitTopEntityT'@@ -340,8 +341,8 @@             let terms = callGraphBindings bindingsMap bench in             Just (hash (annM, primMapHash, show clashModDate, terms, optsHash)) -    let succesFlagsI = (opt_inlineLimit opts,opt_specLimit opts,opt_floatSupport opts)-        manifestI    = Manifest (topHash,benchHashM) succesFlagsI [] [] [] [] []+    let successFlagsI = (opt_inlineLimit opts,opt_specLimit opts,opt_floatSupport opts)+        manifestI    = Manifest (topHash,benchHashM) successFlagsI [] [] [] [] []      let       manFile =@@ -357,13 +358,13 @@                   (\man ->                     let allowCache (inl0,spec0,fl0) (inl1,spec1,fl1) =                           inl0 <= inl1 && spec0 <= spec1 && (not (fl0 && not fl1))-                        flagsAllowCache = allowCache (succesFlags man) succesFlagsI+                        flagsAllowCache = allowCache (successFlags man) successFlagsI                     in  (flagsAllowCache && fst (manifestHash man) == topHash                         ,flagsAllowCache && snd (manifestHash man) == benchHashM                         ,man { manifestHash = (topHash,benchHashM)-                             , succesFlags  = if flagsAllowCache-                                                 then succesFlags man-                                                 else succesFlagsI+                             , successFlags  = if flagsAllowCache+                                                 then successFlags man+                                                 else successFlagsI                              }                         ))                   manM)

@@ -189,7 +189,7 @@   { manifestHash :: (Int,Maybe Int)     -- ^ Hash of the TopEntity and all its dependencies     --   + (maybe) Hash of the TestBench and all its dependencies-  , succesFlags  :: (Int,Int,Bool)+  , successFlags  :: (Int,Int,Bool)     -- ^ Compiler flags used to achieve successful compilation:     --     --   * opt_inlineLimit

@@ -33,6 +33,7 @@ import qualified Data.HashMap.Strict              as HashMapS import qualified Data.HashMap.Lazy                as HashMap import           Data.List                        (elemIndex, partition, sortOn)+import           Data.List.Extra                  (zipEqual) import           Data.Maybe   (catMaybes, listToMaybe, mapMaybe, fromMaybe) import qualified Data.Set                         as Set@@ -57,13 +58,14 @@ import           Clash.Core.Name                  (Name(..)) import           Clash.Core.Pretty                (showPpr) import           Clash.Core.Term-  (Alt, Pat (..), Term (..), TickInfo (..), PrimInfo(primName), collectArgs, collectArgsTicks, collectTicks)+  ( Alt, Pat (..), Term (..), TickInfo (..), PrimInfo(primName), collectArgs+  , collectArgsTicks, collectTicks, mkApps, mkTicks, stripTicks) import qualified Clash.Core.Term                  as Core+import           Clash.Core.TermInfo              (termType) import           Clash.Core.Type   (Type (..), coreView1, splitFunForallTy, splitCoreFunForallTy) import           Clash.Core.TyCon                 (TyConMap)-import           Clash.Core.Util-  (mkApps, mkTicks, splitShouldSplit, stripTicks, termType)+import           Clash.Core.Util                  (splitShouldSplit) import           Clash.Core.Var                   (Id, Var (..), isGlobalId) import           Clash.Core.VarEnv   (VarEnv, eltsVarEnv, emptyInScopeSet, emptyVarEnv, extendVarEnv, lookupVarEnv,@@ -623,7 +625,7 @@           -- Filter void arguments, but make sure to render their declarations:           let             argTypeExprs = zip argHWTys (zip argTys argExprs)-            filteredTypeExprs = filterOnFst (not . isVoidMaybe True) argTypeExprs+            filteredTypeExprs = fmap snd $ filter (not . isVoidMaybe True . fst) argTypeExprs             (argTysFiltered, argsFiltered) = unzip filteredTypeExprs            let compOutp = (\(_,x,_) -> x) <$> listToMaybe co

@@ -12,19 +12,21 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}  module Clash.Netlist.BlackBox where  import           Control.Exception             (throw) import           Control.Lens                  ((<<%=),(%=)) import qualified Control.Lens                  as Lens-import           Control.Monad                 (when, replicateM)+import           Control.Monad                 (when, replicateM, zipWithM) import           Control.Monad.IO.Class        (liftIO) import           Data.Char                     (ord) import           Data.Either                   (lefts, partitionEithers) import qualified Data.HashMap.Lazy             as HashMap import qualified Data.IntMap                   as IntMap import           Data.List                     (elemIndex, partition)+import           Data.List.Extra               (countEq, mapAccumLM) import           Data.Maybe                    (catMaybes, fromJust, fromMaybe) import           Data.Semigroup.Monad import qualified Data.Set                      as Set@@ -56,12 +58,13 @@ import           Clash.Core.Pretty             (showPpr) import           Clash.Core.Subst              (extendIdSubst, mkSubst, substTm) import           Clash.Core.Term               as C-  (PrimInfo (..), Term (..), WorkInfo (..), collectArgs, collectArgsTicks)+  (PrimInfo (..), Term (..), WorkInfo (..), collectArgs, collectArgsTicks, collectBndrs, mkApps)+import           Clash.Core.TermInfo import           Clash.Core.Type               as C   (Type (..), ConstTy (..), TypeView (..), mkFunTy, splitFunTys, splitFunTy, tyView) import           Clash.Core.TyCon              as C (TyConMap, tyConDataCons) import           Clash.Core.Util-  (collectBndrs, inverseTopSortLetBindings, isFun, mkApps, splitShouldSplit, termType)+  (inverseTopSortLetBindings, splitShouldSplit) import           Clash.Core.Var                as V   (Id, Var (..), mkLocalId, modifyVarName) import           Clash.Core.VarEnv@@ -70,6 +73,7 @@   (genComponent, mkDcApplication, mkDeclarations, mkExpr, mkNetDecl,    mkProjection, mkSelection, mkFunApp, mkDeclarations') import qualified Clash.Backend                 as Backend+import           Clash.Debug                   (debugIsOn) import           Clash.Driver.Types   (opt_primWarn, opt_color, ClashOpts) import           Clash.Netlist.BlackBox.Types  as B@@ -82,6 +86,7 @@ import           Clash.Signal.Internal         (ActiveEdge (..)) import           Clash.Unique                  (lookupUniqMap') import           Clash.Util+import qualified Clash.Util.Interpolate        as I  -- | Emits (colorized) warning to stderr warn@@ -115,7 +120,7 @@     -- Make context inputs     let resNm = nameOcc (varName resId)     resTy <- unsafeCoreTypeToHWTypeM' $(curLoc) (V.varType resId)-    (imps,impDecls) <- unzip <$> mapM (mkArgument resNm) termArgs+    (imps,impDecls) <- unzip <$> zipWithM (mkArgument bbName resNm) [0..] termArgs     (funs,funDecls) <-       mapAccumLM         (addFunction (V.varType resId))@@ -191,13 +196,17 @@   _                -> False  mkArgument-  :: Identifier+  :: TextS.Text+  -- ^ Blackbox function name+  -> Identifier   -- ^ LHS of the original let-binder+  -> Int+  -- ^ Argument n (zero-indexed). Used for error message.   -> Term   -> NetlistMonad ( (Expr,HWType,Bool)                   , [Declaration]                   )-mkArgument bndr e = do+mkArgument bbName bndr nArg e = do     tcm   <- Lens.use tcCache     let ty = termType tcm e     iw    <- Lens.use intWidth@@ -239,9 +248,20 @@         (Case scrut ty' [alt],[],_) -> do           (projection,decls) <- mkProjection False (NetlistId bndr ty) scrut ty' alt           return ((projection,hwTy,False),decls)-        _ ->-          return ((Identifier (error ($(curLoc) ++ "Forced to evaluate unexpected function argument: " ++ eTyMsg)) Nothing-                  ,hwTy,False),[])+        (Letrec _bnds _term, [], _ticks) -> do+          (exprN, letDecls) <- mkExpr False Concurrent (NetlistId bndr ty) e+          return ((exprN,hwTy,False),letDecls)+        _ -> do+          let errMsg = [I.i|+            Forced to evaluate unexpected function argument:++              #{eTyMsg}++            in 'mkArgument' for argument #{nArg} of blackbox #{show bbName}.+          |]++          return ((Identifier (error ($(curLoc) ++ errMsg)) Nothing, hwTy, False), [])+     return ((e',t,l),d)  -- | Extract a compiled primitive from a guarded primitive. Emit a warning if

@@ -27,6 +27,7 @@ import           Data.Hashable                   (Hashable (..)) import qualified Data.IntMap                     as IntMap import           Data.List                       (nub)+import           Data.List.Extra                 (indexMaybe) #if !MIN_VERSION_base(4,11,0) import           Data.Monoid #endif

@@ -37,6 +37,7 @@ import           Data.String             (fromString) import           Data.List               (intersperse, unzip4, intercalate) import qualified Data.List               as List+import qualified Data.List.Extra         as List import           Data.Maybe              (catMaybes,fromMaybe,isNothing) import           Data.Monoid             (First (..)) import           Text.Printf             (printf)@@ -68,13 +69,14 @@    extendInScopeIdList, mkSubst, substTm) import           Clash.Core.Term   (Alt, LetBinding, Pat (..), Term (..), TickInfo (..), NameMod (..),-   collectArgsTicks, collectTicks, PrimInfo(primName))+   collectArgsTicks, collectTicks, collectBndrs, PrimInfo(primName), mkTicks, stripTicks)+import           Clash.Core.TermInfo import           Clash.Core.TyCon   (TyConName, TyConMap, tyConDataCons) import           Clash.Core.Type         (Type (..), TypeView (..),                                           coreView1, splitTyConAppM, tyView, TyVar) import           Clash.Core.Util-  (collectBndrs, stripTicks, substArgTys, termType, tyLitShow, mkTicks)+  (substArgTys, tyLitShow) import           Clash.Core.Var   (Id, Var (..), mkLocalId, modifyVarName, Attr') import           Clash.Core.VarEnv@@ -630,10 +632,12 @@   -> PortName filterVoidPorts _hwty (PortName s) =   PortName s-filterVoidPorts (FilteredHWType _hwty [filtered]) (PortProduct s ps) =-  PortProduct s [filterVoidPorts f p | (p, (void, f)) <- zip ps filtered, not void]+filterVoidPorts (FilteredHWType _hwty [filtered]) (PortProduct s ps)+  | length filtered > 1+  = PortProduct s [filterVoidPorts f p | (p, (void, f)) <- zip ps filtered, not void] filterVoidPorts (FilteredHWType _hwty fs) (PortProduct s ps)   | length (filter (not.fst) (concat fs)) == 1+  , length fs > 1   , length ps == 2   = PortProduct s ps filterVoidPorts filtered pp@(PortProduct _s _ps) =@@ -691,7 +695,7 @@       let resRead = any (localIdOccursIn res) exprs       -- Rename some of the binders, see 'setBinderName' when this happens.       ((res2,subst1,extraBndr),bndrs1) <--        mapAccumLM (setBinderName substRes res resRead) (res1,substRes,[]) binds+        List.mapAccumLM (setBinderName substRes res resRead) (res1,substRes,[]) binds       -- Make let-binders unique, the result binder is already unique, so we       -- can skip it.       let (bndrsL,r:bndrsR) = break ((== res2)) bndrs1@@ -1385,7 +1389,7 @@                         (extendPorts . t_inputs)                         annM   arguments <- zipWithM appendIdentifier (map (\a -> ("input",snd a)) args) [0..]-  (_,arguments1) <- mapAccumLM (\acc (p,i) -> mkTopInput topM acc p i)+  (_,arguments1) <- List.mapAccumLM (\acc (p,i) -> mkTopInput topM acc p i)                       (zip inNames inTys)                       (zip iPortSupply arguments)   let (iports,wrappers,idsI) = unzip3 arguments1@@ -1506,7 +1510,7 @@       case hwty' of         Vector sz hwty'' -> do           arguments <- mapM (appendIdentifier (i',hwty'')) [0..sz-1]-          (inps'',arguments1) <- mapAccumLM go inps' arguments+          (inps'',arguments1) <- List.mapAccumLM go inps' arguments           let (ports,decls,ids) = unzip3 arguments1               assigns = zipWith (argBV topM) ids                           [ Identifier i' (Just (Indexed (hwty,10,n)))@@ -1518,7 +1522,7 @@          RTree d hwty'' -> do           arguments <- mapM (appendIdentifier (i',hwty'')) [0..2^d-1]-          (inps'',arguments1) <- mapAccumLM go inps' arguments+          (inps'',arguments1) <- List.mapAccumLM go inps' arguments           let (ports,decls,ids) = unzip3 arguments1               assigns = zipWith (argBV topM) ids                           [ Identifier i' (Just (Indexed (hwty,10,n)))@@ -1530,7 +1534,7 @@          Product _ _ hwtys -> do           arguments <- zipWithM appendIdentifier (map (i,) hwtys) [0..]-          (inps'',arguments1) <- mapAccumLM go inps' arguments+          (inps'',arguments1) <- List.mapAccumLM go inps' arguments           let (ports,decls,ids) = unzip3 arguments1               assigns = zipWith (argBV topM) ids                           [ Identifier i' (Just (Indexed (hwty,0,n)))@@ -1562,7 +1566,7 @@         Vector sz hwty'' -> do           arguments <- mapM (appendIdentifier (pN',hwty'')) [0..sz-1]           (inps'',arguments1) <--            mapAccumLM (\acc (p',o') -> mkTopInput topM acc p' o') inps'+            List.mapAccumLM (\acc (p',o') -> mkTopInput topM acc p' o') inps'                        (zip (extendPorts ps) arguments)           let (ports,decls,ids) = unzip3 arguments1               assigns = zipWith (argBV topM) ids@@ -1576,7 +1580,7 @@         RTree d hwty'' -> do           arguments <- mapM (appendIdentifier (pN',hwty'')) [0..2^d-1]           (inps'',arguments1) <--            mapAccumLM (\acc (p',o') -> mkTopInput topM acc p' o') inps'+            List.mapAccumLM (\acc (p',o') -> mkTopInput topM acc p' o') inps'                        (zip (extendPorts ps) arguments)           let (ports,decls,ids) = unzip3 arguments1               assigns = zipWith (argBV topM) ids@@ -1590,7 +1594,7 @@         Product _ _ hwtys -> do           arguments <- zipWithM appendIdentifier (map (pN',) hwtys) [0..]           (inps'',arguments1) <--            mapAccumLM (\acc (p',o') -> mkTopInput topM acc p' o') inps'+            List.mapAccumLM (\acc (p',o') -> mkTopInput topM acc p' o') inps'                        (zip (extendPorts ps) arguments)           let (ports,decls,ids) = unzip3 arguments1               assigns = zipWith (argBV topM) ids@@ -1605,7 +1609,7 @@           let hwtys = [BitVector (conSize hwty'),elTy]           arguments <- zipWithM appendIdentifier (map (pN',) hwtys) [0..]           (inps'',arguments1) <--            mapAccumLM (\acc (p',o') -> mkTopInput topM acc p' o') inps'+            List.mapAccumLM (\acc (p',o') -> mkTopInput topM acc p' o') inps'                        (zip (extendPorts ps) arguments)           let (ports,decls,ids) = unzip3 arguments1           case ids of@@ -1700,7 +1704,7 @@       case hwty' of         Vector sz hwty'' -> do           results <- mapM (appendIdentifier (o',hwty'')) [0..sz-1]-          (outps'',results1) <- mapAccumLM go outps' results+          (outps'',results1) <- List.mapAccumLM go outps' results           let (ports,decls,ids) = unzip3 results1               ids' = map (resBV topM) ids               netassgn = Assignment o' (mkVectorChain sz hwty'' ids')@@ -1711,7 +1715,7 @@          RTree d hwty'' -> do           results <- mapM (appendIdentifier (o',hwty'')) [0..2^d-1]-          (outps'',results1) <- mapAccumLM go outps' results+          (outps'',results1) <- List.mapAccumLM go outps' results           let (ports,decls,ids) = unzip3 results1               ids' = map (resBV topM) ids               netassgn = Assignment o' (mkRTreeChain d hwty'' ids')@@ -1722,7 +1726,7 @@          Product _ _ hwtys -> do           results <- zipWithM appendIdentifier (map (o',) hwtys) [0..]-          (outps'',results1) <- mapAccumLM go outps' results+          (outps'',results1) <- List.mapAccumLM go outps' results           let (ports,decls,ids) = unzip3 results1               ids' = map (resBV topM) ids               netassgn = Assignment o' (DataCon hwty (DC (hwty,0)) ids')@@ -1753,7 +1757,7 @@         Vector sz hwty'' -> do           results <- mapM (appendIdentifier (pN',hwty'')) [0..sz-1]           (outps'',results1) <--            mapAccumLM (\acc (p',o') -> mkTopOutput' topM acc p' o') outps'+            List.mapAccumLM (\acc (p',o') -> mkTopOutput' topM acc p' o') outps'                        (zip (extendPorts ps) results)           let (ports,decls,ids) = unzip3 results1               ids' = map (resBV topM) ids@@ -1766,7 +1770,7 @@         RTree d hwty'' -> do           results <- mapM (appendIdentifier (pN',hwty'')) [0..2^d-1]           (outps'',results1) <--            mapAccumLM (\acc (p',o') -> mkTopOutput' topM acc p' o') outps'+            List.mapAccumLM (\acc (p',o') -> mkTopOutput' topM acc p' o') outps'                        (zip (extendPorts ps) results)           let (ports,decls,ids) = unzip3 results1               ids' = map (resBV topM) ids@@ -1779,7 +1783,7 @@         Product _ _ hwtys -> do           results <- zipWithM appendIdentifier (map (pN',) hwtys) [0..]           (outps'',results1) <--            mapAccumLM (\acc (p',o') -> mkTopOutput' topM acc p' o') outps'+            List.mapAccumLM (\acc (p',o') -> mkTopOutput' topM acc p' o') outps'                        (zip (extendPorts ps) results)           let (ports,decls,ids) = unzip3 results1               ids' = map (resBV topM) ids@@ -1794,7 +1798,7 @@           let hwtys = [BitVector (conSize elTy),elTy]           results <- zipWithM appendIdentifier (map (pN',) hwtys) [0..]           (outps'',results1) <--            mapAccumLM (\acc (p',o') -> mkTopOutput' topM acc p' o') outps'+            List.mapAccumLM (\acc (p',o') -> mkTopOutput' topM acc p' o') outps'                        (zip (extendPorts ps) results)           let (ports,decls,ids) = unzip3 results1               ids1 = map (resBV topM) ids

@@ -42,17 +42,18 @@ import           Clash.Core.Pretty                (PrettyOptions(..), showPpr, showPpr', ppr) import           Clash.Core.Subst   (extendGblSubstList, mkSubst, substTm)-import           Clash.Core.Term                  (Term (..), collectArgsTicks)+import           Clash.Core.Term                  (Term (..), collectArgsTicks+                                                  ,mkApps, mkTicks) import           Clash.Core.Type                  (Type, splitCoreFunForallTy) import           Clash.Core.TyCon   (TyConMap, TyConName) import           Clash.Core.Type                  (isPolyTy)-import           Clash.Core.Util                  (mkApps, mkTicks) import           Clash.Core.Var                   (Id, varName, varType) import           Clash.Core.VarEnv   (VarEnv, elemVarSet, eltsVarEnv, emptyInScopeSet, emptyVarEnv,    extendVarEnv, lookupVarEnv, mapVarEnv, mapMaybeVarEnv,    mkVarEnv, mkVarSet, notElemVarEnv, notElemVarSet, nullVarEnv, unionVarEnv)+import           Clash.Debug                      (traceIf) import           Clash.Driver.Types   (BindingMap, Binding(..), ClashOpts (..), DebugLevel (..)) import           Clash.Netlist.Types@@ -62,7 +63,7 @@ import           Clash.Normalize.Strategy import           Clash.Normalize.Transformations   (appPropFast, bindConstantVar, caseCon, flattenLet, reduceConst, topLet,-   reduceNonRepPrim, removeUnusedExpr)+   reduceNonRepPrim, removeUnusedExpr, deadCode) import           Clash.Normalize.Types import           Clash.Normalize.Util import           Clash.Primitives.Types           (CompiledPrimMap)@@ -389,7 +390,7 @@       repeatR (topdownR (apply "appPropFast" appPropFast >->                  apply "bindConstantVar" bindConstantVar >->                  apply "caseCon" caseCon >->-                 apply "reduceConst" reduceConst >->+                 (apply "reduceConst" reduceConst !-> apply "deadcode" deadCode) >->                  apply "reduceNonRepPrim" reduceNonRepPrim >->                  apply "removeUnusedExpr" removeUnusedExpr >->                  apply "flattenLet" flattenLet)) !->

@@ -47,6 +47,7 @@ import qualified Data.IntMap.Strict               as IM import qualified Data.IntSet                      as IntSet import qualified Data.List                        as List+import qualified Data.List.Extra                  as List import qualified Data.Map.Strict                  as Map import qualified Data.Maybe                       as Maybe import           Data.Monoid                      (All (..))@@ -59,10 +60,10 @@ import Clash.Core.Literal    (Literal (..)) import Clash.Core.Term   (LetBinding, Pat (..), PrimInfo (..), Term (..), TickInfo (..), collectArgs,-   collectArgsTicks)+   collectArgsTicks, mkApps, mkTicks, patIds)+import Clash.Core.TermInfo   (termType) import Clash.Core.TyCon      (tyConDataCons) import Clash.Core.Type       (Type, isPolyFunTy, mkTyConApp, splitFunForallTy)-import Clash.Core.Util       (mkApps, mkTicks, patIds, termType) import Clash.Core.Var        (isGlobalId) import Clash.Core.VarEnv   (InScopeSet, elemInScopeSet, notElemInScopeSet)@@ -218,7 +219,7 @@                   ,[(Term,([Term],CaseTree [(Either Term Type)]))]                   ) collectGlobalsArgs inScope substitution seen args = do-    (_,(args',collected)) <- second unzip <$> mapAccumLM go seen args+    (_,(args',collected)) <- second unzip <$> List.mapAccumLM go seen args     return (args',concat collected)   where     go s (Left tm) = do@@ -265,7 +266,7 @@                   ,[(Term,([Term],CaseTree [(Either Term Type)]))]                   ) collectGlobalsLbs inScope substitution seen lbs = do-    (_,(lbs',collected)) <- second unzip <$> mapAccumLM go seen lbs+    (_,(lbs',collected)) <- second unzip <$> List.mapAccumLM go seen lbs     return (lbs',concat collected)   where     go :: [Term] -> LetBinding@@ -339,7 +340,7 @@ disJointSelProj inScope argTys cs = do     let maxIndex = length argTys - 1         css = map (\i -> fmap ((:[]) . (!!i)) cs) [0..maxIndex]-    (untran,tran) <- partitionM (isUntranslatableType False . snd) (zip [0..] argTys)+    (untran,tran) <- List.partitionM (isUntranslatableType False . snd) (zip [0..] argTys)     let untranCs   = map (css!!) (map fst untran)         untranSels = zipWith (\(_,ty) cs' -> genCase ty Nothing []  cs')                              untran untranCs@@ -457,9 +458,9 @@     Just t | t || anyArgNotConstant -> pure (Just e)     _ | DeDup `elem` ticks -> pure (Just e)     _ -> do-      let isInteresting = uncurry3 (interestingToLift inScope eval) . collectArgsTicks+      let isInteresting = (\(x, y, z) -> interestingToLift inScope eval x y z) . collectArgsTicks       if isHOTy (primType pInfo) then do-        anyInteresting <- anyM (fmap Maybe.isJust . isInteresting) lArgs+        anyInteresting <- List.anyM (fmap Maybe.isJust . isInteresting) lArgs         if anyInteresting then pure (Just e) else pure Nothing       else         pure Nothing

@@ -49,7 +49,8 @@ import           Clash.Core.Pretty                (showPpr) import           Clash.Core.Term   (CoreContext (..), PrimInfo (..), Term (..), WorkInfo (..), Pat (..),-   collectTermIds)+   collectTermIds, mkApps, idToVar)+import           Clash.Core.TermInfo import           Clash.Core.Type                  (LitTy (..), Type (..),                                                    TypeView (..), coreView1,                                                    mkFunTy, mkTyConApp,@@ -58,8 +59,8 @@   (TyConMap, TyConName, tyConDataCons, tyConName) import           Clash.Core.TysPrim               (integerPrimTy, typeNatKind) import           Clash.Core.Util-  (appendToVec, extractElems, extractTElems, idToVar, mkApps, mkRTree,-   mkUniqInternalId, mkUniqSystemTyVar, mkVec, termType, dataConInstArgTys,+  (appendToVec, extractElems, extractTElems, mkRTree,+   mkUniqInternalId, mkUniqSystemTyVar, mkVec, dataConInstArgTys,    primCo, undefinedTm) import           Clash.Core.Var                   (Var (..)) import           Clash.Core.VarEnv

@@ -72,20 +72,21 @@ import qualified Data.Either                 as Either import qualified Data.HashMap.Lazy           as HashMap import qualified Data.HashMap.Strict         as HashMapS-import qualified Data.List                   as List import           Data.List                   ((\\))+import qualified Data.List                   as List+import qualified Data.List.Extra             as List import qualified Data.Maybe                  as Maybe import qualified Data.Monoid                 as Monoid import qualified Data.Primitive.ByteArray    as BA import qualified Data.Text                   as Text import qualified Data.Vector.Primitive       as PV-import           Debug.Trace import           GHC.Integer.GMP.Internals   (Integer (..), BigNat (..))  import           BasicTypes                  (InlineSpec (..))  import           Clash.Annotations.Primitive (extractPrim) import           Clash.Core.DataCon          (DataCon (..))+import           Clash.Core.EqSolver import           Clash.Core.Name   (Name (..), NameSort (..), mkUnsafeSystemName, nameOcc) import           Clash.Core.FreeVars@@ -95,15 +96,8 @@ import           Clash.Core.Literal          (Literal (..)) import           Clash.Core.Pretty           (showPpr) import           Clash.Core.Subst-  (Subst, substTm, mkSubst, extendIdSubst, extendIdSubstList, extendTvSubst,-   extendTvSubstList, freshenTm, substTyInVar, deShadowTerm, deShadowAlt,-   deshadowLetExpr) import           Clash.Core.Term-  ( LetBinding, Pat (..), Term (..), CoreContext (..), PrimInfo (..)-  , TickInfo(..) , WorkInfo(WorkConstant), Alt, TickInfo-  , isLambdaBodyCtx, isTickCtx, collectArgs-  , collectArgsTicks, collectTicks , partitionTicks-  )+import           Clash.Core.TermInfo import           Clash.Core.Type             (Type (..), TypeView (..), applyFunTy,                                               isPolyFunCoreTy, isClassTy,                                               normalizeType, splitFunForallTy,@@ -112,10 +106,7 @@                                               LitTy (..), coreView1) import           Clash.Core.TyCon            (TyConMap, tyConDataCons) import           Clash.Core.Util-  (isCon, isFun, isLet, isPolyFun, isPrim,-   isSignalType, isVar, mkApps, mkLams, mkVec, piResultTy, termSize, termType,-   tyNatSize, patVars, isAbsurdAlt, altEqs, substInExistentialsList,-   solveNonAbsurds, patIds, isLocalVar, undefinedTm, stripTicks, mkTicks,+  ( isSignalType, mkVec, tyNatSize, undefinedTm,    shouldSplit, inverseTopSortLetBindings) import           Clash.Core.Var   (Id, TyVar, Var (..), isGlobalId, isLocalId, mkLocalId)@@ -126,6 +117,7 @@    unitVarSet, mkVarSet, mkInScopeSet, uniqAway, elemInScopeSet, elemVarEnv,    foldlWithUniqueVarEnv', lookupVarEnvDirectly, extendVarEnv, unionVarEnv,    eltsVarEnv, mkVarEnv, eltsVarSet)+import           Clash.Debug import           Clash.Driver.Types          (Binding(..), DebugLevel (..)) import           Clash.Netlist.BlackBox.Types (Element(Err)) import           Clash.Netlist.BlackBox.Util (getUsedArguments)@@ -832,7 +824,7 @@       used    = List.foldl' collectUsed emptyVarEnv (eltsVarSet bodyFVs)   case eltsVarEnv used of     [] -> changed body-    qqL | neLength qqL binds+    qqL | not (List.equalLength qqL binds)         -> changed (Letrec qqL body)         | otherwise         -> return e@@ -1910,9 +1902,8 @@        -- Extract projection of this case statement. Subsequent calls to       -- 'stripProjection' will check if new target is actually used.-      n <- headMaybe fTrace1-      vTarget1 <- indexMaybe xs n-      fTrace2 <- tailMaybe fTrace1+      (n, fTrace2) <- List.uncons fTrace1+      vTarget1 <- List.indexMaybe xs n        stripProjection fTrace2 (Var vTarget1) r @@ -2081,9 +2072,9 @@         let [lhsElTy,rhsElty,resElTy,nTy] = Either.rights args         case runExcept (tyNatSize tcm nTy) of           Right n -> do-            shouldReduce1 <- orM [ pure (ultra || n < 2)+            shouldReduce1 <- List.orM [ pure (ultra || n < 2)                                  , shouldReduce ctx-                                 , anyM isUntranslatableType_not_poly+                                 , List.anyM isUntranslatableType_not_poly                                         [lhsElTy,rhsElty,resElTy] ]             if shouldReduce1                then let [fun,lhsArg,rhsArg] = Either.lefts args@@ -2095,9 +2086,9 @@         let [argElTy,resElTy,nTy] = Either.rights args         case runExcept (tyNatSize tcm nTy) of           Right n -> do-            shouldReduce1 <- orM [ pure (ultra || n < 2 )+            shouldReduce1 <- List.orM [ pure (ultra || n < 2 )                                  , shouldReduce ctx-                                 , anyM isUntranslatableType_not_poly+                                 , List.anyM isUntranslatableType_not_poly                                         [argElTy,resElTy] ]             if shouldReduce1                then let [fun,arg] = Either.lefts args@@ -2115,7 +2106,7 @@         let [aTy,nTy] = Either.rights args         case runExcept (tyNatSize tcm nTy) of           Right n -> do-            shouldReduce1 <- orM [ pure (ultra || n == 0)+            shouldReduce1 <- List.orM [ pure (ultra || n == 0)                                  , shouldReduce ctx                                  , isUntranslatableType_not_poly aTy ]             if shouldReduce1 then@@ -2127,9 +2118,9 @@         let [aTy,bTy,nTy] = Either.rights args         in  case runExcept (tyNatSize tcm nTy) of           Right n -> do-            shouldReduce1 <- orM [ pure ultra+            shouldReduce1 <- List.orM [ pure ultra                                  , shouldReduce ctx-                                 , anyM isUntranslatableType_not_poly [aTy,bTy] ]+                                 , List.anyM isUntranslatableType_not_poly [aTy,bTy] ]             if shouldReduce1               then let [fun,start,arg] = Either.lefts args                    in  (`mkTicks` ticks) <$> reduceFoldr c n aTy fun start arg@@ -2148,7 +2139,7 @@                 | n == 0 -> changed rArg                 | m == 0 -> changed lArg                 | otherwise -> do-                    shouldReduce1 <- orM [ shouldReduce ctx+                    shouldReduce1 <- List.orM [ shouldReduce ctx                                          , isUntranslatableType_not_poly aTy ]                     if shouldReduce1                        then (`mkTicks` ticks) <$> reduceAppend is0 n m aTy lArg rArg@@ -2159,7 +2150,7 @@             [vArg]    = Either.lefts args         case runExcept (tyNatSize tcm nTy) of           Right n -> do-            shouldReduce1 <- orM [ shouldReduce ctx+            shouldReduce1 <- List.orM [ shouldReduce ctx                                  , isUntranslatableType_not_poly aTy ]             if shouldReduce1                then (`mkTicks` ticks) <$> reduceHead is0 (n+1) aTy vArg@@ -2170,7 +2161,7 @@             [vArg]    = Either.lefts args         case runExcept (tyNatSize tcm nTy) of           Right n -> do-            shouldReduce1 <- orM [ shouldReduce ctx+            shouldReduce1 <- List.orM [ shouldReduce ctx                                  , isUntranslatableType_not_poly aTy ]             if shouldReduce1                then (`mkTicks` ticks) <$> reduceTail is0 (n+1) aTy vArg@@ -2181,7 +2172,7 @@             [vArg]    = Either.lefts args         case runExcept (tyNatSize tcm nTy) of           Right n -> do-            shouldReduce1 <- orM [ shouldReduce ctx+            shouldReduce1 <- List.orM [ shouldReduce ctx                                  , isUntranslatableType_not_poly aTy                                  ]             if shouldReduce1@@ -2193,7 +2184,7 @@             [vArg]    = Either.lefts args         case runExcept (tyNatSize tcm nTy) of           Right n -> do-            shouldReduce1 <- orM [ shouldReduce ctx+            shouldReduce1 <- List.orM [ shouldReduce ctx                                  , isUntranslatableType_not_poly aTy ]             if shouldReduce1                then (`mkTicks` ticks) <$> reduceInit is0 (n+1) aTy vArg@@ -2213,7 +2204,7 @@         let ([_sArg,vArg],[nTy,aTy]) = Either.partitionEithers args         case runExcept (tyNatSize tcm nTy) of           Right n -> do-            shouldReduce1 <- orM [ shouldReduce ctx+            shouldReduce1 <- List.orM [ shouldReduce ctx                                  , isUntranslatableType_not_poly aTy                                  ]             if shouldReduce1@@ -2225,7 +2216,7 @@         let ([_knArg,vArg,iArg,aArg],[nTy,aTy]) = Either.partitionEithers args         case runExcept (tyNatSize tcm nTy) of           Right n -> do-            shouldReduce1 <- orM [ pure ultra+            shouldReduce1 <- List.orM [ pure ultra                                  , shouldReduce ctx                                  , isUntranslatableType_not_poly aTy                                  ]@@ -2238,7 +2229,7 @@         let ([_knArg,vArg,iArg],[nTy,aTy]) = Either.partitionEithers args         case runExcept (tyNatSize tcm nTy) of           Right n -> do-            shouldReduce1 <- orM [ pure ultra+            shouldReduce1 <- List.orM [ pure ultra                                  , shouldReduce ctx                                  , isUntranslatableType_not_poly aTy ]             if shouldReduce1@@ -2250,9 +2241,9 @@         let [nTy,argElTy,resElTy] = Either.rights args         case runExcept (tyNatSize tcm nTy) of           Right n -> do-            shouldReduce1 <- orM [ pure (ultra || n < 2)+            shouldReduce1 <- List.orM [ pure (ultra || n < 2)                                  , shouldReduce ctx-                                 , anyM isUntranslatableType_not_poly [argElTy,resElTy] ]+                                 , List.anyM isUntranslatableType_not_poly [argElTy,resElTy] ]             if shouldReduce1                then let [_,fun,arg] = Either.lefts args                     in  (`mkTicks` ticks) <$> reduceImap c n argElTy resElTy fun arg@@ -2279,7 +2270,7 @@         let ([_sArg,vArg],[nTy,aTy]) = Either.partitionEithers args         case runExcept (tyNatSize tcm nTy) of           Right n -> do-            shouldReduce1 <- orM [ shouldReduce ctx+            shouldReduce1 <- List.orM [ shouldReduce ctx                                  , isUntranslatableType False aTy ]             if shouldReduce1                then (`mkTicks` ticks) <$> reduceTReplicate n aTy eTy vArg@@ -2617,7 +2608,7 @@                    freeLocalIds (unionVarEnvWith (+))                    emptyVarEnv (`unitVarEnv` (1 :: Int))                    body-  (is2,binds1) <- second concat <$> mapAccumLM go is1 binds+  (is2,binds1) <- second concat <$> List.mapAccumLM go is1 binds   case binds1 of     -- inline binders into the body when there's only a single binder, and only     -- if that binder doesn't perform any work or is only used once in the body@@ -2788,7 +2779,7 @@   runXOpt <- Lens.view aggressiveXOpt    if runXOpt then do-    defPart <- partitionM (isPrimError . snd) alts+    defPart <- List.partitionM (isPrimError . snd) alts      case defPart of       ([], _)    -> return e

@@ -38,6 +38,7 @@ import           Data.Bifunctor          (bimap) import           Data.Either             (lefts) import qualified Data.List               as List+import qualified Data.List.Extra         as List import qualified Data.Map                as Map import qualified Data.HashMap.Strict     as HashMapS import           Data.Text               (Text)@@ -55,18 +56,18 @@   (deShadowTerm, extendTvSubst, extendTvSubstList, mkSubst, substTm, substTy,    substId, extendIdSubst) import           Clash.Core.Term-  (Context, CoreContext(AppArg), PrimInfo (..), Term (..), WorkInfo (..),-   TickInfo(NameMod), NameMod(PrefixName), collectArgs, collectArgsTicks)+import           Clash.Core.TermInfo     (isPolyFun, termType) import           Clash.Core.TyCon        (TyConMap) import           Clash.Core.Type   (Type(LitTy, VarTy), LitTy(SymTy), TypeView (..), tyView, undefinedTy,    splitFunForallTy, splitTyConAppM, mkPolyFunTy) import           Clash.Core.Util-  (isClockOrReset, isPolyFun, termType, mkApps, mkTicks)+  (isClockOrReset) import           Clash.Core.Var          (Id, TyVar, Var (..), isGlobalId) import           Clash.Core.VarEnv   (VarEnv, emptyInScopeSet, emptyVarEnv, extendVarEnv, extendVarEnvWith,    lookupVarEnv, unionVarEnvWith, unitVarEnv, extendInScopeSetList)+import           Clash.Debug             (traceIf) import           Clash.Driver.Types      (BindingMap, Binding(..), DebugLevel (..)) import {-# SOURCE #-} Clash.Normalize.Strategy (normalization) import           Clash.Normalize.Types@@ -77,8 +78,7 @@ import           Clash.Rewrite.Util   (runRewrite, specialise, mkTmBinderFor, mkDerivedName) import           Clash.Unique-import           Clash.Util-  (SrcSpan, anyM, makeCachedU, traceIf, mapAccumLM)+import           Clash.Util              (SrcSpan, makeCachedU)  -- | Determine if argument should reduce to a constant given a primitive and -- an argument number. Caches results.@@ -117,7 +117,7 @@   :: Context   -- ^ ..in the current transformcontext   -> RewriteMonad NormalizeState Bool-shouldReduce = anyM isConstantArg'+shouldReduce = List.anyM isConstantArg'   where     isConstantArg' (AppArg (Just (nm, _, i))) = isConstantArg nm i     isConstantArg' _ = pure False@@ -231,7 +231,7 @@   -- ^ Subterms   -> RewriteMonad NormalizeState ConstantSpecInfo mergeCsrs ctx ticks oldTerm proposedTerm subTerms = do-  subCsrs <- snd <$> mapAccumLM constantSpecInfoFolder ctx subTerms+  subCsrs <- snd <$> List.mapAccumLM constantSpecInfoFolder ctx subTerms    -- If any arguments are constant (and hence can be constant specced), a new   -- term is created with these constants left in, but variable parts let-bound.

@@ -26,8 +26,7 @@ import qualified Control.Monad.Writer        as Writer import qualified Data.Monoid                 as Monoid -import           Clash.Core.Term             (Term (..), CoreContext (..), primArg)-import           Clash.Core.Util             (patIds)+import           Clash.Core.Term             (Term (..), CoreContext (..), primArg, patIds) import           Clash.Core.VarEnv   (extendInScopeSet, extendInScopeSetList) import           Clash.Rewrite.Types

@@ -36,6 +36,7 @@ import           Data.Coerce                 (coerce) import           Data.Functor.Const          (Const (..)) import           Data.List                   (group, partition, sort)+import           Data.List.Extra             (allM, partitionM) import qualified Data.Map                    as Map import           Data.Maybe                  (catMaybes,isJust,mapMaybe) import qualified Data.Monoid                 as Monoid@@ -66,8 +67,7 @@ import           Clash.Core.Subst   (substTmEnv, aeqTerm, aeqType, extendIdSubst, mkSubst, substTm) import           Clash.Core.Term-  (LetBinding, Pat (..), Term (..), CoreContext (..), Context, PrimInfo (..),-   TmName, WorkInfo (..), TickInfo, collectArgs, collectArgsTicks)+import           Clash.Core.TermInfo import           Clash.Core.TyCon   (TyConMap, tyConDataCons) import           Clash.Core.Type             (KindOrType, Type (..),@@ -75,14 +75,13 @@                                               normalizeType,                                               typeKind, tyView, isPolyFunTy) import           Clash.Core.Util-  (isPolyFun, mkAbstraction, mkApps, mkLams, mkTicks,-   mkTmApps, mkTyApps, mkTyLams, termType, dataConInstArgTysE, isClockOrReset,-   isEnable, piResultTy)+  (dataConInstArgTysE, isClockOrReset, isEnable) import           Clash.Core.Var   (Id, IdScope (..), TyVar, Var (..), isLocalId, mkGlobalId, mkLocalId, mkTyVar) import           Clash.Core.VarEnv   (InScopeSet, VarEnv, elemVarSet, extendInScopeSetList, mkInScopeSet,    uniqAway, uniqAway', mapVarEnv)+import           Clash.Debug (traceIf) import           Clash.Driver.Types   (DebugLevel (..), BindingMap, Binding(..)) import           Clash.Netlist.Util          (representableType)

@@ -24,26 +24,25 @@   ) where -import Control.Applicative            as X (Applicative,(<$>),(<*>),pure) import Control.Arrow                  as X ((***),(&&&),first,second) import qualified Control.Exception    as Exception+import Control.Lens import Control.Monad                  as X ((<=<),(>=>))-import Control.Monad.State            (MonadState,State,StateT,runState)+import Control.Monad.State            (MonadState,StateT) import qualified Control.Monad.State  as State-import Data.Typeable                  (Typeable) import Data.Function                  as X (on) import Data.Hashable                  (Hashable) import Data.HashMap.Lazy              (HashMap) import qualified Data.HashMap.Lazy    as HashMapL+import qualified Data.List.Extra      as List import Data.Maybe                     (fromMaybe, listToMaybe, catMaybes) import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Render.String-import Data.Version                   (Version)-import qualified Data.Time.Format     as Clock-import qualified Data.Time.Clock      as Clock import Data.Time.Clock                (UTCTime)-import Control.Lens-import Debug.Trace                    (trace)+import qualified Data.Time.Clock      as Clock+import qualified Data.Time.Format     as Clock+import Data.Typeable                  (Typeable)+import Data.Version                   (Version) import GHC.Base                       (Int(..),isTrue#,(==#),(+#)) import GHC.Integer.Logarithms         (integerLogBase#) import qualified GHC.LanguageExtensions.Type as LangExt@@ -52,6 +51,8 @@ import qualified Language.Haskell.TH  as TH  import SrcLoc                         (SrcSpan, noSrcSpan)++import Clash.Debug import Clash.Unique  #ifdef CABAL@@ -117,7 +118,7 @@ pprTraceDebug   :: String -> Doc ann -> a -> a pprTraceDebug str doc x-  | debugIsOn = pprDebugAndThen trace (pretty str) doc x+  | debugIsOn = pprTrace str doc x   | otherwise = x  pprDebugAndThen@@ -179,31 +180,6 @@       l %= extendUniqMap key value       return value --- | Run a State-action using the State that is stored in a higher-layer Monad-liftState :: (MonadState s m)-          => Lens' s s' -- ^ Lens to the State in the higher-layer monad-          -> State s' a -- ^ The State-action to perform-          -> m a-liftState l m = do-  s <- use l-  let (a,s') = runState m s-  l .= s'-  return a---- | Functorial version of 'Control.Arrow.first'-firstM :: Functor f-       => (a -> f c)-       -> (a, b)-       -> f (c, b)-firstM f (x,y) = (,y) <$> f x---- | Functorial version of 'Control.Arrow.second'-secondM :: Functor f-        => (b -> f c)-        -> (a, b)-        -> f (a, c)-secondM f (x,y) = (x,) <$> f y- combineM :: (Applicative f)          => (a -> f b)          -> (c -> f d)@@ -211,64 +187,6 @@          -> f (b,d) combineM f g (x,y) = (,) <$> f x <*> g y --- | Performs trace when first argument evaluates to 'True'-traceIf :: Bool -> String -> a -> a-traceIf True  msg = trace msg-traceIf False _   = id-{-# INLINE traceIf #-}---- | A version of 'concatMap' that works with a monadic predicate.-concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]-concatMapM f as = concat <$> sequence (map f as)-{-# INLINE concatMapM #-}---- | Monadic version of 'Data.List.partition'-partitionM :: Monad m-           => (a -> m Bool)-           -> [a]-           -> m ([a], [a])-partitionM _ []     = return ([], [])-partitionM p (x:xs) = do-  test      <- p x-  (ys, ys') <- partitionM p xs-  return $ if test then (x:ys, ys') else (ys, x:ys')---- | Monadic version of 'Data.List.mapAccumL'-mapAccumLM :: (Monad m)-           => (acc -> x -> m (acc,y))-           -> acc-           -> [x]-           -> m (acc,[y])-mapAccumLM _ acc [] = return (acc,[])-mapAccumLM f acc (x:xs) = do-  (acc',y) <- f acc x-  (acc'',ys) <- mapAccumLM f acc' xs-  return (acc'',y:ys)---- | if-then-else as a function on an argument-ifThenElse :: (a -> Bool)-           -> (a -> b)-           -> (a -> b)-           -> a-           -> b-ifThenElse t f g a = if t a then f a else g a--infixr 5 <:>--- | Applicative version of 'GHC.Types.(:)'-(<:>) :: Applicative f-      => f a-      -> f [a]-      -> f [a]-x <:> xs = (:) <$> x <*> xs---- | Safe indexing, returns a 'Nothing' if the index does not exist-indexMaybe :: [a]-           -> Int-           -> Maybe a-indexMaybe [] _     = Nothing-indexMaybe (x:_)  0 = Just x-indexMaybe (_:xs) n = indexMaybe xs (n-1)- -- | Same as 'indexNote' with last two arguments swapped indexNote'   :: HasCallStack@@ -293,25 +211,7 @@   -- ^ Index /n/   -> a   -- ^ Error or element /n/-indexNote note = \xs i -> fromMaybe (error note) (indexMaybe xs i)---- | Safe version of 'head'-headMaybe :: [a] -> Maybe a-headMaybe (a:_) = Just a-headMaybe _ = Nothing---- | Safe version of 'tail'-tailMaybe :: [a] -> Maybe [a]-tailMaybe (_:as) = Just as-tailMaybe _ = Nothing---- | Split the second list at the length of the first list-splitAtList :: [b] -> [a] -> ([a], [a])-splitAtList [] xs         = ([], xs)-splitAtList _ xs@[]       = (xs, xs)-splitAtList (_:xs) (y:ys) = (y:ys', ys'')-    where-      (ys', ys'') = splitAtList xs ys+indexNote note = \xs i -> fromMaybe (error note) (List.indexMaybe xs i)  clashLibVersion :: Version #ifdef CABAL@@ -320,17 +220,6 @@ clashLibVersion = error "development version" #endif --- | Return number of occurrences of an item in a list-countEq-  :: Eq a-  => a-  --  ^ Needle-  -> [a]-  -- ^ Haystack-  -> Int-  -- ^ Times needle was found in haystack-countEq a as = length (filter (== a) as)- -- | \x y -> floor (logBase x y), x > 1 && y > 0 flogBase :: Integer -> Integer -> Maybe Int flogBase x y | x > 1 && y > 0 = Just (I# (integerLogBase# x y))@@ -348,69 +237,6 @@                 else Just (I# z1) clogBase _ _ = Nothing --- | Determine whether two lists are of equal length-equalLength-  :: [a] -> [b] -> Bool-equalLength [] [] = True-equalLength (_:as) (_:bs) = equalLength as bs-equalLength _ _ = False---- | Determine whether two lists are not of equal length-neLength-  :: [a] -> [b] -> Bool-neLength [] [] = False-neLength (_:as) (_:bs) = neLength as bs-neLength _ _ = True---- | Zip two lists of equal length------ NB Errors out for a DEBUG compiler when the two lists are not of equal length-zipEqual-  :: [a] -> [b] -> [(a,b)]-#if !defined(DEBUG)-zipEqual = zip-#else-zipEqual [] [] = []-zipEqual (a:as) (b:bs) = (a,b) : zipEqual as bs-zipEqual _ _ = error "zipEqual"-#endif---- | Is this a DEBUG compiler?-debugIsOn-  :: Bool-#if defined(DEBUG)-debugIsOn = True-#else-debugIsOn = False-#endif---- | Short-circuiting monadic version of 'any'-anyM-  :: (Monad m)-  => (a -> m Bool)-  -> [a]-  -> m Bool-anyM _ []     = return False-anyM p (x:xs) = do-  q <- p x-  if q then-    return True-  else-    anyM p xs---- | short-circuiting monadic version of 'or'-orM-  :: (Monad m)-  => [m Bool]-  -> m Bool-orM [] = pure False-orM (x:xs) = do-  p <- x-  if p then-    pure True-  else-    orM xs- -- | Get the package id of the type of a value -- >>> pkgIdFromTypeable (undefined :: TopEntity) -- "clash-prelude-0.99.3-64904d90747cb49e17166bbc86fec8678918e4ead3847193a395b258e680373c"@@ -430,29 +256,6 @@        | otherwise        = "%-S%03Qs" --- | Converts a curried function to a function on a triple-uncurry3-  :: (a -> b -> c -> d)-  -> (a,b,c)-  -> d-uncurry3 = \f (a,b,c) -> f a b c-{-# INLINE uncurry3 #-}--allM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool-allM _ [] = return True-allM p (x:xs) = do-  q <- p x-  if q then-    allM p xs-  else-    return False--traceWith :: (a -> String) -> a -> a-traceWith f a = trace (f a) a--traceShowWith :: Show b => (a -> b) -> a -> a-traceShowWith f a = trace (show (f a)) a- -- | Left-biased choice on maybes orElse :: Maybe a -> Maybe a -> Maybe a orElse x@(Just _) _y = x@@ -467,7 +270,7 @@ --  * compiling files with clash --  * running output tests with runghc --  * compiling (local) Template/Blackbox functions with Hint-wantedLanguageExtensions, unwantedLanguageExtensions :: [LangExt.Extension]+wantedLanguageExtensions :: [LangExt.Extension] wantedLanguageExtensions =   [ LangExt.BinaryLiterals   , LangExt.ConstraintKinds@@ -495,6 +298,7 @@ #endif   ] +unwantedLanguageExtensions :: [LangExt.Extension] unwantedLanguageExtensions =   [ LangExt.ImplicitPrelude   , LangExt.MonomorphismRestriction@@ -505,8 +309,3 @@   , LangExt.StrictData   ] -filterOnFst :: (a -> Bool) -> [(a, b)] -> [b]-filterOnFst f xs = map snd (filter (f . fst) xs)--filterOnSnd :: (b -> Bool) -> [(a, b)] -> [a]-filterOnSnd f xs = map fst (filter (f . snd) xs)

@@ -0,0 +1,110 @@+{-# LANGUAGE CPP #-}++module Data.List.Extra where++import Control.Applicative (liftA2)++-- | Monadic version of 'Data.List.partition'+partitionM :: (Monad m) => (a -> m Bool) -> [a] -> m ([a], [a])+partitionM _ []     = return ([], [])+partitionM p (x:xs) = do+  test      <- p x+  (ys, ys') <- partitionM p xs+  return $ if test then (x:ys, ys') else (ys, x:ys')++-- | Monadic version of 'Data.List.mapAccumL'+mapAccumLM+  :: (Monad m)+  => (acc -> x -> m (acc,y))+  -> acc+  -> [x]+  -> m (acc,[y])+mapAccumLM _ acc [] = return (acc,[])+mapAccumLM f acc (x:xs) = do+  (acc',y) <- f acc x+  (acc'',ys) <- mapAccumLM f acc' xs+  return (acc'',y:ys)++infixr 5 <:>+-- | Applicative version of 'GHC.Types.(:)'+(<:>) :: Applicative f => f a -> f [a] -> f [a]+(<:>) = liftA2 (:)++-- | Safe indexing, returns a 'Nothing' if the index does not exist+indexMaybe :: [a] -> Int -> Maybe a+indexMaybe [] _     = Nothing+indexMaybe (x:_)  0 = Just x+indexMaybe (_:xs) n = indexMaybe xs (n-1)++splitAtList :: [b] -> [a] -> ([a], [a])+splitAtList [] xs         = ([], xs)+splitAtList _ xs@[]       = (xs, xs)+splitAtList (_:xs) (y:ys) = (y:ys', ys'')+    where+      (ys', ys'') = splitAtList xs ys++equalLength :: [a] -> [b] -> Bool+equalLength [] [] = True+equalLength (_:as) (_:bs) = equalLength as bs+equalLength _ _ = False++-- | Return number of occurrences of an item in a list+countEq+  :: Eq a+  => a+  --  ^ Needle+  -> [a]+  -- ^ Haystack+  -> Int+  -- ^ Times needle was found in haystack+countEq a as = length (filter (== a) as)++-- | Zip two lists of equal length+--+-- NB Errors out for a DEBUG compiler when the two lists are not of equal length+zipEqual+  :: [a] -> [b] -> [(a,b)]+#if !defined(DEBUG)+zipEqual = zip+#else+zipEqual [] [] = []+zipEqual (a:as) (b:bs) = (a,b) : zipEqual as bs+zipEqual _ _ = error "zipEqual"+#endif++-- | Short-circuiting monadic version of 'any'+anyM+  :: (Monad m)+  => (a -> m Bool)+  -> [a]+  -> m Bool+anyM _ []     = return False+anyM p (x:xs) = do+  q <- p x+  if q then+    return True+  else+    anyM p xs++allM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool+allM _ [] = return True+allM p (x:xs) = do+  q <- p x+  if q then+    allM p xs+  else+    return False++-- | short-circuiting monadic version of 'or'+orM+  :: (Monad m)+  => [m Bool]+  -> m Bool+orM [] = pure False+orM (x:xs) = do+  p <- x+  if p then+    pure True+  else+    orM xs+

@@ -1,3 +1,7 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+ {-# OPTIONS_GHC -Wno-orphans #-}  module Data.Semigroup.Monad.Extra@@ -6,8 +10,13 @@ where  import Control.Monad.Fix+import Control.Monad.State import Data.Semigroup.Monad  instance MonadFix f => MonadFix (Mon f) where   mfix f = Mon (mfix (getMon . f)) +instance MonadState s m => MonadState s (Mon m) where+  get = Mon get+  put = Mon . put+  state = Mon . state