diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/clash-lib.cabal b/clash-lib.cabal --- a/clash-lib.cabal +++ b/clash-lib.cabal @@ -1,6 +1,6 @@ Cabal-version: 2.2 Name: clash-lib -Version: 1.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) diff --git a/prims/common/Clash_Signal_Trace.json b/prims/common/Clash_Signal_Trace.json new file mode 100644 --- /dev/null +++ b/prims/common/Clash_Signal_Trace.json @@ -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]" + } + } +] diff --git a/prims/common/Clash_Sized_Internal_Unsigned.json b/prims/common/Clash_Sized_Internal_Unsigned.json --- a/prims/common/Clash_Sized_Internal_Unsigned.json +++ b/prims/common/Clash_Sized_Internal_Unsigned.json @@ -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]" + } + } ] diff --git a/prims/commonverilog/Clash_Sized_Internal_BitVector.json b/prims/commonverilog/Clash_Sized_Internal_BitVector.json --- a/prims/commonverilog/Clash_Sized_Internal_BitVector.json +++ b/prims/commonverilog/Clash_Sized_Internal_BitVector.json @@ -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" : diff --git a/prims/systemverilog/Clash_Sized_Internal_BitVector.json b/prims/systemverilog/Clash_Sized_Internal_BitVector.json --- a/prims/systemverilog/Clash_Sized_Internal_BitVector.json +++ b/prims/systemverilog/Clash_Sized_Internal_BitVector.json @@ -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" } diff --git a/prims/verilog/Clash_Sized_Internal_BitVector.json b/prims/verilog/Clash_Sized_Internal_BitVector.json --- a/prims/verilog/Clash_Sized_Internal_BitVector.json +++ b/prims/verilog/Clash_Sized_Internal_BitVector.json @@ -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" } diff --git a/prims/vhdl/Clash_Explicit_BlockRam.json b/prims/vhdl/Clash_Explicit_BlockRam.json --- a/prims/vhdl/Clash_Explicit_BlockRam.json +++ b/prims/vhdl/Clash_Explicit_BlockRam.json @@ -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 diff --git a/prims/vhdl/Clash_Sized_Internal_BitVector.json b/prims/vhdl/Clash_Sized_Internal_BitVector.json --- a/prims/vhdl/Clash_Sized_Internal_BitVector.json +++ b/prims/vhdl/Clash_Sized_Internal_BitVector.json @@ -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" : diff --git a/prims/vhdl/Clash_Sized_RTree.json b/prims/vhdl/Clash_Sized_RTree.json --- a/prims/vhdl/Clash_Sized_RTree.json +++ b/prims/vhdl/Clash_Sized_RTree.json @@ -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" : diff --git a/src/Clash/Backend/SystemVerilog.hs b/src/Clash/Backend/SystemVerilog.hs --- a/src/Clash/Backend/SystemVerilog.hs +++ b/src/Clash/Backend/SystemVerilog.hs @@ -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: diff --git a/src/Clash/Backend/VHDL.hs b/src/Clash/Backend/VHDL.hs --- a/src/Clash/Backend/VHDL.hs +++ b/src/Clash/Backend/VHDL.hs @@ -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) diff --git a/src/Clash/Backend/Verilog.hs b/src/Clash/Backend/Verilog.hs --- a/src/Clash/Backend/Verilog.hs +++ b/src/Clash/Backend/Verilog.hs @@ -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 diff --git a/src/Clash/Core/EqSolver.hs b/src/Clash/Core/EqSolver.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Core/EqSolver.hs @@ -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 + diff --git a/src/Clash/Core/Evaluator.hs b/src/Clash/Core/Evaluator.hs --- a/src/Clash/Core/Evaluator.hs +++ b/src/Clash/Core/Evaluator.hs @@ -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 diff --git a/src/Clash/Core/Pretty.hs b/src/Clash/Core/Pretty.hs --- a/src/Clash/Core/Pretty.hs +++ b/src/Clash/Core/Pretty.hs @@ -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 diff --git a/src/Clash/Core/Subst.hs b/src/Clash/Core/Subst.hs --- a/src/Clash/Core/Subst.hs +++ b/src/Clash/Core/Subst.hs @@ -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 diff --git a/src/Clash/Core/Term.hs b/src/Clash/Core/Term.hs --- a/src/Clash/Core/Term.hs +++ b/src/Clash/Core/Term.hs @@ -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 + diff --git a/src/Clash/Core/TermInfo.hs b/src/Clash/Core/TermInfo.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Core/TermInfo.hs @@ -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 + diff --git a/src/Clash/Core/Type.hs b/src/Clash/Core/Type.hs --- a/src/Clash/Core/Type.hs +++ b/src/Clash/Core/Type.hs @@ -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 diff --git a/src/Clash/Core/Util.hs b/src/Clash/Core/Util.hs --- a/src/Clash/Core/Util.hs +++ b/src/Clash/Core/Util.hs @@ -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 diff --git a/src/Clash/Core/VarEnv.hs b/src/Clash/Core/VarEnv.hs --- a/src/Clash/Core/VarEnv.hs +++ b/src/Clash/Core/VarEnv.hs @@ -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) diff --git a/src/Clash/Debug.hs b/src/Clash/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Debug.hs @@ -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 + diff --git a/src/Clash/Driver.hs b/src/Clash/Driver.hs --- a/src/Clash/Driver.hs +++ b/src/Clash/Driver.hs @@ -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) diff --git a/src/Clash/Driver/Types.hs b/src/Clash/Driver/Types.hs --- a/src/Clash/Driver/Types.hs +++ b/src/Clash/Driver/Types.hs @@ -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 diff --git a/src/Clash/Netlist.hs b/src/Clash/Netlist.hs --- a/src/Clash/Netlist.hs +++ b/src/Clash/Netlist.hs @@ -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 diff --git a/src/Clash/Netlist/BlackBox.hs b/src/Clash/Netlist/BlackBox.hs --- a/src/Clash/Netlist/BlackBox.hs +++ b/src/Clash/Netlist/BlackBox.hs @@ -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 diff --git a/src/Clash/Netlist/BlackBox/Util.hs b/src/Clash/Netlist/BlackBox/Util.hs --- a/src/Clash/Netlist/BlackBox/Util.hs +++ b/src/Clash/Netlist/BlackBox/Util.hs @@ -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 diff --git a/src/Clash/Netlist/Util.hs b/src/Clash/Netlist/Util.hs --- a/src/Clash/Netlist/Util.hs +++ b/src/Clash/Netlist/Util.hs @@ -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 diff --git a/src/Clash/Normalize.hs b/src/Clash/Normalize.hs --- a/src/Clash/Normalize.hs +++ b/src/Clash/Normalize.hs @@ -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)) !-> diff --git a/src/Clash/Normalize/DEC.hs b/src/Clash/Normalize/DEC.hs --- a/src/Clash/Normalize/DEC.hs +++ b/src/Clash/Normalize/DEC.hs @@ -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 diff --git a/src/Clash/Normalize/PrimitiveReductions.hs b/src/Clash/Normalize/PrimitiveReductions.hs --- a/src/Clash/Normalize/PrimitiveReductions.hs +++ b/src/Clash/Normalize/PrimitiveReductions.hs @@ -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 diff --git a/src/Clash/Normalize/Transformations.hs b/src/Clash/Normalize/Transformations.hs --- a/src/Clash/Normalize/Transformations.hs +++ b/src/Clash/Normalize/Transformations.hs @@ -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 diff --git a/src/Clash/Normalize/Util.hs b/src/Clash/Normalize/Util.hs --- a/src/Clash/Normalize/Util.hs +++ b/src/Clash/Normalize/Util.hs @@ -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. diff --git a/src/Clash/Rewrite/Combinators.hs b/src/Clash/Rewrite/Combinators.hs --- a/src/Clash/Rewrite/Combinators.hs +++ b/src/Clash/Rewrite/Combinators.hs @@ -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 diff --git a/src/Clash/Rewrite/Util.hs b/src/Clash/Rewrite/Util.hs --- a/src/Clash/Rewrite/Util.hs +++ b/src/Clash/Rewrite/Util.hs @@ -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) diff --git a/src/Clash/Util.hs b/src/Clash/Util.hs --- a/src/Clash/Util.hs +++ b/src/Clash/Util.hs @@ -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) diff --git a/src/Data/List/Extra.hs b/src/Data/List/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Data/List/Extra.hs @@ -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 + diff --git a/src/Data/Semigroup/Monad/Extra.hs b/src/Data/Semigroup/Monad/Extra.hs --- a/src/Data/Semigroup/Monad/Extra.hs +++ b/src/Data/Semigroup/Monad/Extra.hs @@ -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