clash-lib 1.2.1 → 1.2.2

raw patch · 35 files changed

+2643/−359 lines, 35 filesdep +haskell-src-extsdep +terminal-sizedep ~clash-preludedep ~concurrent-supplydep ~containersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: haskell-src-exts, terminal-size

Dependency ranges changed: clash-prelude, concurrent-supply, containers, data-default, deepseq, ghc, tasty, template-haskell, text, transformers, unordered-containers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +35/−8
• clash-lib.cabal +21/−7
• prims/commonverilog/GHC_Prim.json +80/−0
• prims/verilog/Clash_Sized_Vector.json +2/−2
• prims/vhdl/Clash_Sized_RTree.json +1/−1
• prims/vhdl/Clash_Sized_Vector.json +1/−1
• prims/vhdl/GHC_Prim.json +70/−0
• src/Clash/Backend/SystemVerilog.hs +4/−1
• src/Clash/Backend/VHDL.hs +26/−9
• src/Clash/Backend/Verilog.hs +6/−2
• src/Clash/Core/Evaluator.hs +34/−17
• src/Clash/Core/Name.hs +7/−0
• src/Clash/Core/Pretty.hs +22/−4
• src/Clash/Core/Subst.hs +13/−1
• src/Clash/Core/Term.hs +4/−4
• src/Clash/Core/Util.hs +12/−0
• src/Clash/Core/VarEnv.hs +9/−0
• src/Clash/Driver.hs +8/−3
• src/Clash/Driver/Types.hs +11/−0
• src/Clash/Netlist/Util.hs +101/−4
• src/Clash/Normalize.hs +3/−0
• src/Clash/Normalize/DEC.hs +85/−54
• src/Clash/Normalize/PrimitiveReductions.hs +349/−87
• src/Clash/Normalize/Transformations.hs +235/−113
• src/Clash/Normalize/Util.hs +9/−0
• src/Clash/Pretty.hs +28/−1
• src/Clash/Primitives/DSL.hs +804/−0
• src/Clash/Primitives/Sized/Vector.hs +53/−0
• src/Clash/Rewrite/Types.hs +8/−1
• src/Clash/Rewrite/Util.hs +139/−31
• src/Data/List/Extra.hs +20/−0
• tests/Clash/Tests/Core/Subst.hs +1/−8
• tests/Clash/Tests/Normalize/Transformations.hs +133/−0
• tests/Test/Clash/Rewrite.hs +307/−0
• tests/unittests.hs +2/−0

@@ -1,9 +1,36 @@ # Changelog for the Clash project +## 1.2.2 *June 12th 2020*+++* Changed:+  * The hardwired functions to unroll primitive definitions for 'zipWith', 'map', 'foldr', and 'init' have been changed to only unroll a single step, whereas they would previously unroll the whole definition in one step. This allows Clash to take advantage of the lazy nature of these functions, in turn speeding up compilation speeds significantly in some cases. Part of [PR 1354](https://github.com/clash-lang/clash-compiler/pull/1354).++* Added:+  * Support for GHC 8.10+  * Ability to load designs from precompiled modules (i.e., stored in a package database). See [#1172](https://github.com/clash-lang/clash-compiler/pull/1172)+  * Support for '-main-is' when used with `--vhdl`, `--verilog`, or `--systemverilog`+  * A partial instance for `NFDataX (Signal domain a)`++* Fixed:+  * Clash's evaluator now inlines work free definitions, preventing [situations where it would otherwise get stuck in an infinite loop](https://github.com/clash-lang/clash-compiler/pull/1354#issuecomment-635430374)+  * `caseCon` doesn't apply type-substitution correctly [#1340](https://github.com/clash-lang/clash-compiler/issues/1340)+  * Clash generates illegal SystemVerilog slice [#1313](https://github.com/clash-lang/clash-compiler/issues/1313)+  * Fix result type of head and tail Verilog blackboxes [#1351](https://github.com/clash-lang/clash-compiler/issues/1351)+  * Certain recursive let-expressions in side a alternatives of a case-expression throw the Clash compiler into an infinite loop [#1316](https://github.com/clash-lang/clash-compiler/issues/1316)+  * Fixes issue with one of Clash's transformations, `inlineCleanup`, introducing free variables [#1337](https://github.com/clash-lang/clash-compiler/issues/1337)+  * Fails to propagate type information of existential type [#1310](https://github.com/clash-lang/clash-compiler/issues/1310)+  * Certain case-expressions throw the Clash compiler into an infinite loop [#1320](https://github.com/clash-lang/clash-compiler/issues/1320)+  * Added blackbox implementation for 'Clash.Sized.Vector.iterateI', hence making it usable as a register reset value [#1240](https://github.com/clash-lang/clash-compiler/issues/1240)+  * `iterate` and `iterateI` can now be used in reset values [#1240](https://github.com/clash-lang/clash-compiler/issues/1240)+  * Prim evaluation fails on undefined arguments [#1297](https://github.com/clash-lang/clash-compiler/issues/1297)+  * Missing re-indexing in (Un)Signed fromSLV conversion [#1292](https://github.com/clash-lang/clash-compiler/issues/1292)+  * VHDL: generate a type qualification inside ~TOBV, fixes [#1360](https://github.com/clash-lang/clash-compiler/issues/1360)+ ## 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+  * 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.@@ -11,12 +38,12 @@   * 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)+  * 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

@@ -1,6 +1,6 @@ Cabal-version:        2.2 Name:                 clash-lib-Version:              1.2.1+Version:              1.2.2 Synopsis:             CAES Language for Synchronous Hardware - As a Library Description:   Clash is a functional hardware description language that borrows both its@@ -141,7 +141,7 @@                       base                    >= 4.11     && < 5,                       binary                  >= 0.8.5    && < 0.11,                       bytestring              >= 0.10.0.2 && < 0.11,-                      clash-prelude           == 1.2.1,+                      clash-prelude           == 1.2.2,                       concurrent-supply       >= 0.1.7    && < 0.2,                       containers              >= 0.5.0.0  && < 0.7,                       data-binary-ieee754     >= 0.4.4    && < 0.6,@@ -153,7 +153,7 @@                       exceptions              >= 0.8.3    && < 0.11.0,                       extra                   >= 1.6.18   && < 1.8,                       filepath                >= 1.3.0.1  && < 1.5,-                      ghc                     >= 8.4.0    && < 8.9,+                      ghc                     >= 8.4.0    && < 8.11,                       ghc-boot-th,                       hashable                >= 1.2.1.0  && < 1.4,                       haskell-src-meta        >= 0.8      && < 0.9,@@ -168,8 +168,9 @@                       primitive               >= 0.5.0.1  && < 1.0,                       process                 >= 1.1.0.2  && < 1.7,                       reducers                >= 3.12.2   && < 4.0,-                      template-haskell        >= 2.8.0.0  && < 2.16,+                      template-haskell        >= 2.8.0.0  && < 2.17,                       temporary               >= 1.2.1    && < 1.4,+                      terminal-size           >= 0.3      && < 0.4,                       text                    >= 1.2.2    && < 1.3,                       text-show               >= 3.7      && < 3.9,                       time                    >= 1.4.0.1  && < 1.11,@@ -230,6 +231,7 @@                       Clash.Normalize.Types                       Clash.Normalize.Util +                      Clash.Primitives.DSL                       Clash.Primitives.Types                       Clash.Primitives.Util @@ -250,11 +252,11 @@                       Clash.Util.Interpolate                       Clash.Pretty -                      Data.List.Extra                       Data.Text.Prettyprint.Doc.Extra    Other-Modules:      Clash.Annotations.TopEntity.Extra                       Data.Aeson.Extra+                      Data.List.Extra                       Data.Semigroup.Monad.Extra                       Data.Set.Ordered.Extra                       Data.Vector.Primitive.Extra@@ -286,11 +288,23 @@       ghc-typelits-knownnat,        base,+      containers,+      concurrent-supply,+      data-default,+      deepseq,+      haskell-src-exts,       ghc,       lens,-      tasty         >= 1.2      && < 1.3,-      tasty-hunit+      tasty         >= 1.2      && < 1.4,+      tasty-hunit,+      template-haskell,+      text,+      transformers,+      unordered-containers    Other-Modules: Clash.Tests.Core.FreeVars                  Clash.Tests.Core.Subst                  Clash.Tests.Util.Interpolate+                 Clash.Tests.Normalize.Transformations++                 Test.Clash.Rewrite

@@ -395,4 +395,84 @@ // narrow32Word end"     }   }+, { "BlackBox" :+    { "name"      : "GHC.Prim.bitReverse#"+    , "workInfo"  : "Never"+    , "kind"      : "Declaration"+    , "type"      : "bitReverse# :: Word# -> Word#"+    , "template"  :+"// bitReverse begin+genvar ~GENSYM[i][0];+~GENERATE+for (~SYM[0] = 0; ~SYM[0] < ~IF ~IW64 ~THEN 64 ~ELSE 32 ~FI; ~SYM[0]=~SYM[0]+1) begin : ~GENSYM[bitReverse][2]+  assign ~RESULT[~SYM[0]] = ~VAR[x][0][~IF ~IW64 ~THEN 63 ~ELSE 31 ~FI-~SYM[0]];+end+~ENDGENERATE+// bitReverse end"+    }+  }+, { "BlackBox" :+    { "name"      : "GHC.Prim.bitReverse8#"+    , "workInfo"  : "Never"+    , "kind"      : "Declaration"+    , "type"      : "bitReverse8# :: Word# -> Word#"+    , "template"  :+"// bitReverse8 begin+genvar ~GENSYM[i][0];+~GENERATE+for (~SYM[0] = 0; ~SYM[0] < 8; ~SYM[0]=~SYM[0]+1) begin : ~GENSYM[bitReverse8][2]+  assign ~RESULT[~SYM[0]] = ~VAR[x][0][7-~SYM[0]];+end+~ENDGENERATE+// bitReverse8 end"+    }+  }+, { "BlackBox" :+    { "name"      : "GHC.Prim.bitReverse16#"+    , "workInfo"  : "Never"+    , "kind"      : "Declaration"+    , "type"      : "bitReverse16# :: Word# -> Word#"+    , "template"  :+"// bitReverse16 begin+genvar ~GENSYM[i][0];+~GENERATE+for (~SYM[0] = 0; ~SYM[0] < 16; ~SYM[0]=~SYM[0]+1) begin : ~GENSYM[bitReverse16][2]+  assign ~RESULT[~SYM[0]] = ~VAR[x][0][15-~SYM[0]];+end+~ENDGENERATE+// bitReverse16 end"+    }+  }+, { "BlackBox" :+    { "name"      : "GHC.Prim.bitReverse32#"+    , "workInfo"  : "Never"+    , "kind"      : "Declaration"+    , "type"      : "bitReverse32# :: Word# -> Word#"+    , "template"  :+"// bitReverse32 begin+genvar ~GENSYM[i][0];+~GENERATE+for (~SYM[0] = 0; ~SYM[0] < 32; ~SYM[0]=~SYM[0]+1) begin : ~GENSYM[bitReverse32][2]+  assign ~RESULT[~SYM[0]] = ~VAR[x][0][31-~SYM[0]];+end+~ENDGENERATE+// bitReverse32 end"+    }+  }+, { "BlackBox" :+    { "name"      : "GHC.Prim.bitReverse64#"+    , "workInfo"  : "Never"+    , "kind"      : "Declaration"+    , "type"      : "bitReverse64# :: Word# -> Word#"+    , "template"  :+"// bitReverse64 begin+genvar ~GENSYM[i][0];+~GENERATE+for (~SYM[0] = 0; ~SYM[0] < 64; ~SYM[0]=~SYM[0]+1) begin : ~GENSYM[bitReverse64][2]+  assign ~RESULT[~SYM[0]] = ~VAR[x][0][63-~SYM[0]];+end+~ENDGENERATE+// bitReverse64 end"+    }+  } ]

@@ -3,7 +3,7 @@     , "workInfo"  : "Never"     , "kind"      : "Expression"     , "type"      : "head :: Vec (n + 1) a -> a"-    , "template"  : "~VAR[vec][0][~SIZE[~TYP[0]]-1 -: ~SIZE[~TYPO]]"+    , "template"  : "~FROMBV[~VAR[vec][0][\\~SIZE[~TYP[0]]-1 -: ~SIZE[~TYPO]\\]][~TYPO]"     }   } , { "BlackBox" :@@ -19,7 +19,7 @@     , "workInfo"  : "Never"     , "kind"      : "Expression"     , "type"      : "Vec (n + 1) a -> a"-    , "template"  : "~VAR[vec][0][~SIZE[~TYPO]-1:0]"+    , "template"  : "~FROMBV[~VAR[vec][0][\\~SIZE[~TYPO]-1:0\\]][~TYPO]"     }   } , { "BlackBox" :

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

@@ -333,7 +333,7 @@     , "workInfo"  : "Never"     , "kind"      : "Expression"     , "type"      : "replicate :: SNat n -> a -> Vec n a"-    , "template"  : "~TYPMO'(0 to ~LIT[0]-1 => ~IF ~VIVADO ~THEN ~TOBV[~TYPM[1]'(~ARG[1])][~TYP[1]] ~ELSE ~ARG[1] ~FI)"+    , "template"  : "~TYPMO'(0 to ~LIT[0]-1 => ~IF ~VIVADO ~THEN ~TOBV[~ARG[1]][~TYP[1]] ~ELSE ~ARG[1] ~FI)"     }   } , { "BlackBox" :

@@ -1145,4 +1145,74 @@     , "template"  : "resize(~VAR[w][0](31 downto 0),~SIZE[~TYPO])"     }   }+, { "BlackBox" :+    { "name"      : "GHC.Prim.bitReverse#"+    , "workInfo"  : "Never"+    , "kind"      : "Declaration"+    , "type"      : "bitReverse# :: Word# -> Word#"+    , "template"  :+"-- bitReverse begin+~GENSYM[bitReverse][0] : for ~GENSYM[i][1] in 0 to ~IF ~IW64 ~THEN 63 ~ELSE 31 ~FI generate+begin+~RESULT(~SYM[1]) <= ~VAR[x][0](~IF ~IW64 ~THEN 63 ~ELSE 31 ~FI-~SYM[1]);+end generate;+-- bitReverse end"+    }+  }+, { "BlackBox" :+    { "name"      : "GHC.Prim.bitReverse8#"+    , "workInfo"  : "Never"+    , "kind"      : "Declaration"+    , "type"      : "bitReverse8# :: Word# -> Word#"+    , "template"  :+"-- bitReverse8 begin+~GENSYM[bitReverse8][0] : for ~GENSYM[i][1] in 0 to 7 generate+begin+~RESULT(~SYM[1]) <= ~VAR[x][0](7-~SYM[1]);+end generate;+-- bitReverse8 end"+    }+  }+, { "BlackBox" :+    { "name"      : "GHC.Prim.bitReverse16#"+    , "workInfo"  : "Never"+    , "kind"      : "Declaration"+    , "type"      : "bitReverse16# :: Word# -> Word#"+    , "template"  :+"-- bitReverse16 begin+~GENSYM[bitReverse16][0] : for ~GENSYM[i][1] in 0 to 15 generate+begin+~RESULT(~SYM[1]) <= ~VAR[x][0](15-~SYM[1]);+end generate;+-- bitReverse16 end"+    }+  }+, { "BlackBox" :+    { "name"      : "GHC.Prim.bitReverse32#"+    , "workInfo"  : "Never"+    , "kind"      : "Declaration"+    , "type"      : "bitReverse32# :: Word# -> Word#"+    , "template"  :+"-- bitReverse32 begin+~GENSYM[bitReverse32][0] : for ~GENSYM[i][1] in 0 to 31 generate+begin+~RESULT(~SYM[1]) <= ~VAR[x][0](31-~SYM[1]);+end generate;+-- bitReverse32 end"+    }+  }+, { "BlackBox" :+    { "name"      : "GHC.Prim.bitReverse64#"+    , "workInfo"  : "Never"+    , "kind"      : "Declaration"+    , "type"      : "bitReverse64# :: Word# -> Word#"+    , "template"  :+"-- bitReverse64 begin+~GENSYM[bitReverse64][0] : for ~GENSYM[i][1] in 0 to 63 generate+begin+~RESULT(~SYM[1]) <= ~VAR[x][0](63-~SYM[1]);+end generate;+-- bitReverse64 end"+    }+  } ]

@@ -1382,7 +1382,9 @@     _ -> Just (m:mods, BitVector (start-end+1))  modifier offset mods (Indexed (ty@(SP _ args),dcI,fI)) =-  Just (Right (NRange (start+offset) (end+offset)):mods, argTy)+  case mods of+    Right {}:rest -> Just (m:rest, argTy)+    _ -> Just (m:mods,argTy)   where     argTys   = snd $ args !! dcI     argTy    = argTys !! fI@@ -1390,6 +1392,7 @@     other    = otherSize argTys (fI-1)     start    = typeSize ty - 1 - conSize ty - other     end      = start - argSize + 1+    m        = Right (NRange (start+offset) (end+offset))  modifier offset mods (Indexed (ty@(Product _ _ argTys),_,fI)) =   let m = Right (NRange (start+offset) (end+offset)) in

@@ -131,12 +131,22 @@   inst            = inst_   expr            = expr_   iwWidth         = use intWidth-  toBV _ id_      = do-    nm <- Mon $ use modNm-    pretty (TextS.toLower nm) <> "_types.toSLV" <> parens (pretty id_)-  fromBV t id_  = do-    nm <- Mon $ use modNm-    qualTyName t <> "'" <> parens (pretty (TextS.toLower nm) <> "_types.fromSLV" <> parens (pretty id_))+  toBV t id_+    | isBV t = pretty id_+    | otherwise = do+      nm <- Mon $ use modNm+      seen <- use seenIdentifiers+      -- This is a bit hacky, as id_ is just a rendered expression.+      -- But if it's a bare identifier that we've seen before,+      -- then this identifier has a defined type and we can skip the explicit type qualification.+      let e | T.toStrict id_ `HashMapS.member` seen = pretty id_+            | otherwise = hdlTypeMark t <> squote <> parens (pretty id_)+      pretty (TextS.toLower nm) <> "_types.toSLV" <> parens e+  fromBV t id_+    | isBV t = pretty id_+    | otherwise = do+      nm <- Mon $ use modNm+      qualTyName t <> "'" <> parens (pretty (TextS.toLower nm) <> "_types.fromSLV" <> parens (pretty id_))   hdlSyn          = use hdlsyn   mkIdentifier    = do       allowExtended <- use extendedIds@@ -207,6 +217,11 @@  type VHDLM a = Mon (State VHDLState) a +-- Check if the underlying type is a BitVector+isBV :: HWType -> Bool+isBV (normaliseType -> BitVector _) = True+isBV _ = False+ -- | Time units: are added to 'reservedWords' as simulators trip over signals -- named after them. timeUnits :: [Identifier]@@ -601,8 +616,9 @@       indent 2 ("return" <+> "std_logic_vector" <> parens ("s") <> semi) <> line <>     "end" <> semi <> line <>     "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "signed" <+> "is" <> line <>+      indent 2 ("alias islv : std_logic_vector(0 to slv'length - 1) is slv;") <> line <>     "begin" <> line <>-      indent 2 ("return" <+> "signed" <> parens ("slv") <> semi) <> line <>+      indent 2 ("return" <+> "signed" <> parens ("islv") <> semi) <> line <>     "end" <> semi   ) @@ -614,8 +630,9 @@       indent 2 ("return" <+> "std_logic_vector" <> parens ("u") <> semi) <> line <>     "end" <> semi <> line <>     "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "unsigned" <+> "is"  <> line <>+      indent 2 "alias islv : std_logic_vector(0 to slv'length - 1) is slv;" <> line <>     "begin" <> line <>-      indent 2 ("return" <+> "unsigned" <> parens ("slv") <> semi) <> line <>+      indent 2 ("return" <+> "unsigned" <> parens ("islv") <> semi) <> line <>     "end" <> semi    )@@ -814,7 +831,7 @@           -- See: [Note] Hack entity attributes in architecture           Other -> indent 2 (rports p <> if null attrs then emptyDoc else                               line <> line <> rattrs) <> line <> "end" <> semi-          _     -> indent 2 (rports p) <> "end" <> semi+          _     -> indent 2 (rports p) <> line <> "end" <> semi       )   where     ports l = sequence $ [port iName hwType "in" l Nothing | (iName, hwType) <- inputs c]

@@ -139,8 +139,12 @@   inst            = inst_   expr            = expr_   iwWidth         = use intWidth-  toBV _          = string-  fromBV _        = string+  toBV ty e       = case ty of+    Signed _ -> "$unsigned" <> parens (string e)+    _ -> string e+  fromBV ty e     = case ty of+    Signed _ -> "$signed" <> parens (string e)+    _ -> string e   hdlSyn          = use hdlsyn   mkIdentifier    = do       allowEscaped <- use escapedIds

@@ -12,6 +12,7 @@  {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} @@ -49,6 +50,11 @@ import           Clash.Unique import           Clash.Util                              (curLoc) +isUndefinedPrimVal :: Value -> Bool+isUndefinedPrimVal (PrimVal (PrimInfo{primName}) _ _) =+  primName == "Clash.Transformations.undefined"+isUndefinedPrimVal _ = False+ whnf'   :: PrimStep   -> PrimUnwind@@ -253,7 +259,8 @@       let tys = fst $ splitFunForallTy (primType p)        in case compare (length args) (length tys) of             EQ -> case lefts args of-                    [] | primName p == "Clash.Transformations.removedArg" ->+                    [] | primName p `elem` [ "Clash.Transformations.removedArg"+                                           , "Clash.Transformations.undefined" ] ->                             unwind tcm m (PrimVal p (rights args) [])                         | otherwise ->@@ -353,10 +360,10 @@   go kf m'  where   go (Update s x)             = return . update s x v-  go (Apply x)                = return . apply v x-  go (Instantiate ty)         = return . instantiate v ty+  go (Apply x)                = return . apply tcm v x+  go (Instantiate ty)         = return . instantiate tcm v ty   go (PrimApply p tys vs tms) = mPrimUnwind m tcm p tys vs v tms-  go (Scrutinise _ as)        = return . scrutinise v as+  go (Scrutinise altTy as)    = return . scrutinise v altTy as   go (Tickish _)              = return . setTerm (valToTerm v)  -- | Update the Heap with the evaluated term@@ -365,36 +372,42 @@   setTerm term . heapInsert s x term  -- | Apply a value to a function-apply :: Value -> Id -> Machine -> Machine-apply (Lambda x' e) x m =+apply :: TyConMap -> Value -> Id -> Machine -> Machine+apply _tcm (Lambda x' e) x m =   setTerm (substTm "Evaluator.apply" subst e) m  where   subst  = extendIdSubst subst0 x' (Var x)   subst0 = mkSubst $ extendInScopeSet (mScopeNames m) x+apply tcm pVal@(PrimVal (PrimInfo{primType}) tys []) x m+  | isUndefinedPrimVal pVal+  = setTerm (undefinedTm (piResultTys tcm primType (tys++[varType x]))) m -apply _ _ _ = error "Evaluator.apply: Not a lambda"+apply _ _ _ _ = error "Evaluator.apply: Not a lambda"  -- | Instantiate a type-abstraction-instantiate :: Value -> Type -> Machine -> Machine-instantiate (TyLambda x e) ty =-  setTerm (substTm "Evaluator.instantiate" subst e)+instantiate :: TyConMap -> Value -> Type -> Machine -> Machine+instantiate _tcm (TyLambda x e) ty m =+  setTerm (substTm "Evaluator.instantiate" subst e) m  where   subst  = extendTvSubst subst0 x ty   subst0 = mkSubst iss0   iss0   = mkInScopeSet (localFVsOfTerms [e] `unionUniqSet` tyFVsOfTypes [ty])+instantiate tcm pVal@(PrimVal (PrimInfo{primType}) tys []) ty m+  | isUndefinedPrimVal pVal+  = setTerm (undefinedTm (piResultTys tcm primType (tys ++ [ty]))) m -instantiate _ _ = error "Evaluator.instantiate: Not a tylambda"+instantiate _ _ _ _ = error "Evaluator.instantiate: Not a tylambda"  -- | Evaluate a case-expression-scrutinise :: Value -> [Alt] -> Machine -> Machine-scrutinise v [] m = setTerm (valToTerm v) m+scrutinise :: Value -> Type -> [Alt] -> Machine -> Machine+scrutinise v _altTy [] m = setTerm (valToTerm v) m -- [Note: empty case expressions] -- -- Clash does not have empty case-expressions; instead, empty case-expressions -- are used to indicate that the `whnf` function was called the context of a -- case-expression, which means certain special primitives must be forced. -- See also [Note: forcing special primitives]-scrutinise (Lit l) alts m = case alts of+scrutinise (Lit l) _altTy alts m = case alts of   (DefaultPat, altE):alts1 -> setTerm (go altE alts1) m   _ -> let term = go (error $ "Evaluator.scrutinise: no match "                     <> showPpr (Case (valToTerm (Lit l)) (ConstTy Arrow) alts)) alts@@ -438,13 +451,16 @@       in  substTm "Evaluator.scrutinise" subst1 altE   go def (_:alts1) = go def alts1 -scrutinise (DC dc xs) alts m+scrutinise (DC dc xs) _altTy alts m   | altE:_ <- [substInAlt altDc tvs pxs xs altE               | (DataPat altDc tvs pxs,altE) <- alts, altDc == dc ] ++               [altE | (DefaultPat,altE) <- alts ]   = setTerm altE m -scrutinise v@(PrimVal p _ vs) alts m+scrutinise v@(PrimVal p _ vs) altTy alts m+  | isUndefinedPrimVal v+  = setTerm (undefinedTm altTy) m+   | any (\case {(LitPat {},_) -> True; _ -> False}) alts   = case alts of       ((DefaultPat,altE):alts1) -> setTerm (go altE alts1) m@@ -467,7 +483,8 @@           | [_,Lit l0] <- vs -> l0         _ -> error ("scrutinise: " ++ showPpr (Case (valToTerm v) (ConstTy Arrow) alts)) -scrutinise v alts _ = error ("scrutinise: " ++ showPpr (Case (valToTerm v) (ConstTy Arrow) alts))+scrutinise v _ alts _ =+  error ("scrutinise: " ++ showPpr (Case (valToTerm v) (ConstTy Arrow) alts))  substInAlt :: DataCon -> [TyVar] -> [Id] -> [Either Term Type] -> Term -> Term substInAlt dc tvs xs args e = substTm "Evaluator.substInAlt" subst e

@@ -61,6 +61,13 @@   | Internal   deriving (Eq,Ord,Show,Generic,NFData,Hashable,Binary) +mkUnsafeName+  :: NameSort+  -> Text+  -> Unique+  -> Name a+mkUnsafeName ns s i = Name ns s i noSrcSpan+ mkUnsafeSystemName   :: Text   -> Unique

@@ -10,6 +10,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-}  {-# OPTIONS_GHC -fno-warn-orphans #-}@@ -34,11 +35,15 @@ import Control.Monad.Identity import Data.List.Extra                  ((<:>)) import qualified Data.Text              as T+import Data.Maybe                       (fromMaybe) import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Internal import GHC.Show                         (showMultiLineString) import Numeric                          (fromRat) import qualified Outputable             as GHC+import System.Environment               (lookupEnv)+import System.IO.Unsafe                 (unsafePerformIO)+import Text.Read                        (readMaybe)  import Clash.Core.DataCon               (DataCon (..)) import Clash.Core.Literal               (Literal (..))@@ -51,8 +56,21 @@ import Clash.Core.Var                   (Id, TyVar, Var (..), IdScope(..)) import Clash.Debug                      (trace) import Clash.Util+import qualified Clash.Util.Interpolate as I import Clash.Pretty +unsafeLookupEnvBool :: HasCallStack =>  String -> Bool -> Bool+unsafeLookupEnvBool key dflt =+  case unsafePerformIO (lookupEnv key) of+    Nothing -> dflt+    Just a -> flip fromMaybe (readMaybe a) $ error [I.i|+      'unsafeLookupEnvBool' tried to lookup #{key} in the environment. It found+      it, but couldn't interpret it to as a Bool. Expected one of: True, False.+      But found:++        #{a}+    |]+ -- | Options for the pretty-printer, controlling which elements to hide. data PrettyOptions = PrettyOptions   { displayUniques    :: Bool@@ -64,9 +82,9 @@   } instance Default PrettyOptions where   def = PrettyOptions-    { displayUniques    = True-    , displayTypes      = True-    , displayQualifiers = True+    { displayUniques    = unsafeLookupEnvBool "CLASH_PPR_UNIQUES" True+    , displayTypes      = unsafeLookupEnvBool "CLASH_PPR_TYPES" True+    , displayQualifiers = unsafeLookupEnvBool "CLASH_PPR_QUALIFIERS" True     }  -- | Annotations carried on pretty-printed code.@@ -133,7 +151,7 @@  -- | Print a PrettyPrec thing to a String showPpr :: PrettyPrec p => p -> String-showPpr = showDoc . ppr+showPpr = showPpr' def  showPpr' :: PrettyPrec p => PrettyOptions -> p -> String showPpr' opts = showDoc . ppr' opts

@@ -42,6 +42,7 @@   , extendGblSubstList     -- ** Applying substitutions   , substTm+  , maybeSubstTm   , substAlt   , substId     -- * Variable renaming@@ -523,7 +524,18 @@          | otherwise    = uniqAway inScope                             (oldVar {varType = substTyUnchecked subst oldKi}) --- | Substitute within a 'Type'+-- | Substitute within a 'Term'. Just return original term if given+-- substitution is "Nothing".+maybeSubstTm+  :: HasCallStack+  => Doc ()+  -> Maybe Subst+  -> Term+  -> Term+maybeSubstTm _doc Nothing = id+maybeSubstTm doc (Just s) = substTm doc s++-- | Substitute within a 'Term' substTm   :: HasCallStack   => Doc ()

@@ -324,11 +324,11 @@     Lam _ t1 -> go t1     TyLam _ t1 -> go t1     App t1 t2 -> go t1 <> go t2-    TyApp t1 _ -> pure (f t1)-    Letrec bndrs t1 -> pure (f t1) <> mconcat (map (go . snd) bndrs)-    Case t1 _ alts -> pure (f t1) <> mconcat (map (go . snd) alts)+    TyApp t1 _ -> go t1+    Letrec bndrs t1 -> go t1 <> mconcat (map (go . snd) bndrs)+    Case t1 _ alts -> go t1 <> mconcat (map (go . snd) alts)     Cast t1 _ _ -> go t1-    Tick _ t1 -> pure (f t1)+    Tick _ t1 -> go t1  -- Collect all term ids mentioned in a term collectTermIds :: Term -> [Id]

@@ -581,3 +581,15 @@  inverseTopSortLetBindings e = e {-# SCC inverseTopSortLetBindings #-}++-- | Group let-bindings into cyclic groups and acyclic individual bindings+sccLetBindings+  :: HasCallStack+  => [LetBinding]+  -> [Graph.SCC LetBinding]+sccLetBindings =+  Graph.stronglyConnComp .+  (map (\(i,e) -> let fvs = fmap varUniq+                            (Set.elems (Lens.setOf freeLocalIds e) )+                  in  ((i,e),varUniq i,fvs)))+{-# SCC sccLetBindings #-}

@@ -71,6 +71,7 @@     -- ** Working with predicates     -- *** Searching   , elemInScopeSet+  , elemUniqInScopeSet   , notElemInScopeSet   , varSetInScope     -- ** Unique generation@@ -400,6 +401,14 @@   -> InScopeSet   -> Bool elemInScopeSet v (InScopeSet s _) = elemVarSet v s++-- | Check whether an element exists in the set based on the `Unique` contained+-- in that element+elemUniqInScopeSet+  :: Unique+  -> InScopeSet+  -> Bool+elemUniqInScopeSet u (InScopeSet s _) = u `elemUniqSetDirectly` s  -- | Is the variable not in scope notElemInScopeSet

@@ -225,14 +225,18 @@   -> (PrimStep, PrimUnwind)   -- ^ Hardcoded evaluator (delta-reduction)   -> [TopEntityT]-  -- ^ Topentities and associated testbench+  -- ^ All topentities and associated testbench+  -> Maybe (TopEntityT, [TopEntityT])+  -- ^ Main top entity to compile. If Nothing, all top entities in previous+  -- argument will be compiled.   -> ClashOpts   -- ^ Debug information level for the normalization process   -> (Clock.UTCTime,Clock.UTCTime)   -> IO () generateHDL reprs bindingsMap hdlState primMap tcm tupTcm typeTrans eval-  topEntities0 opts (startTime,prepTime) =-    go prepTime HashMap.empty (sortTop bindingsMap topEntities2)+  topEntities0 mainTopEntity opts (startTime,prepTime) =+    let todo = maybe topEntities2 (uncurry (:)) mainTopEntity in+    go prepTime HashMap.empty (sortTop bindingsMap todo)  where   topEntities1 = map (splitTopEntityT tcm bindingsMap) topEntities0   -- Remove forall's used in type equality constraints@@ -536,6 +540,7 @@     , ('P.indexToIntegerVerilog, P.indexToIntegerVerilog)     , ('P.indexToIntegerVHDL, P.indexToIntegerVHDL)     , ('P.intTF, P.intTF)+    , ('P.iterateBBF, P.iterateBBF)     , ('P.signedToIntegerVerilog, P.signedToIntegerVerilog)     , ('P.signedToIntegerVHDL, P.signedToIntegerVHDL)     , ('P.unsignedToIntegerVerilog, P.unsignedToIntegerVerilog)

@@ -73,6 +73,13 @@                            , opt_inlineConstantLimit :: Word                            , opt_dbgLevel    :: DebugLevel                            , opt_dbgTransformations :: Set.Set String+                           , opt_dbgTransformationsFrom :: Int+                           -- ^ Only output debug information from (applied)+                           -- transformation n+                           , opt_dbgTransformationsLimit :: Int+                           -- ^ Only output debug information for n (applied)+                           -- transformations. If this limit is exceeded, Clash+                           -- will stop normalizing.                            , opt_cachehdl    :: Bool                            , opt_cleanhdl    :: Bool                            , opt_primWarn    :: Bool@@ -124,6 +131,8 @@     opt_inlineConstantLimit `hashWithSalt`     opt_dbgLevel `hashSet`     opt_dbgTransformations `hashWithSalt`+    opt_dbgTransformationsFrom `hashWithSalt`+    opt_dbgTransformationsLimit `hashWithSalt`     opt_cachehdl `hashWithSalt`     opt_cleanhdl `hashWithSalt`     opt_primWarn `hashWithSalt`@@ -159,6 +168,8 @@   = ClashOpts   { opt_dbgLevel            = DebugNone   , opt_dbgTransformations  = Set.empty+  , opt_dbgTransformationsFrom = 0+  , opt_dbgTransformationsLimit = maxBound   , opt_inlineLimit         = 20   , opt_specLimit           = 20   , opt_inlineFunctionLimit = 15

@@ -20,6 +20,7 @@  module Clash.Netlist.Util where +import           Data.Coerce             (coerce) import           Control.Error           (hush) import           Control.Exception       (throw) import           Control.Lens            ((.=),(%=))@@ -34,11 +35,12 @@ import           Data.Either             (partitionEithers) import           Data.HashMap.Strict     (HashMap) import qualified Data.HashMap.Strict     as HashMap+import qualified Data.IntSet             as IntSet 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.Maybe              (catMaybes,fromMaybe,isNothing,mapMaybe) import           Data.Monoid             (First (..)) import           Text.Printf             (printf) #if !(MIN_VERSION_base(4,11,0))@@ -59,7 +61,8 @@ import           Clash.Annotations.TopEntity (PortName (..), TopEntity (..)) import           Clash.Driver.Types      (Manifest (..), ClashOpts (..)) import           Clash.Core.DataCon      (DataCon (..))-import           Clash.Core.FreeVars     (localIdOccursIn, typeFreeVars)+import           Clash.Core.EqSolver     (typeEq)+import           Clash.Core.FreeVars     (localIdOccursIn, typeFreeVars, typeFreeVars') import qualified Clash.Core.Literal      as C import           Clash.Core.Name   (Name (..), appendToName, nameOcc)@@ -72,7 +75,7 @@    collectArgsTicks, collectTicks, collectBndrs, PrimInfo(primName), mkTicks, stripTicks) import           Clash.Core.TermInfo import           Clash.Core.TyCon-  (TyConName, TyConMap, tyConDataCons)+  (TyCon (FunTyCon), TyConName, TyConMap, tyConDataCons) import           Clash.Core.Type         (Type (..), TypeView (..),                                           coreView1, splitTyConAppM, tyView, TyVar) import           Clash.Core.Util@@ -405,7 +408,7 @@   | isRecursiveTy m tc   = throwE $ $(curLoc) ++ "Can't translate recursive type: " ++ tyString -mkADT builtInTranslation reprs m _tyString tc args = case tyConDataCons (m `lookupUniqMap'` tc) of+mkADT builtInTranslation reprs m tyString tc args = case tyConDataCons (m `lookupUniqMap'` tc) of   []  -> return (FilteredHWType (Void Nothing) [])   dcs -> do     let tcName           = nameOcc tc@@ -417,6 +420,10 @@      -- Every alternative is annotated with some examples. Be sure to read them.     case (dcs, filteredArgHTyss) of+      _ | any (hasUnconstrainedExistential m) dcs ->+        throwE $ $(curLoc) +++                 "Can't translate data types with unconstrained existentials: " +++                 tyString       -- Type has one constructor and that constructor has a single field,       -- modulo empty fields if keepVoid is False. Examples of such fields       -- are:@@ -485,6 +492,96 @@         return $ FilteredHWType (SP tcName $ zipWith           (\dc tys ->  ( nameOcc (dcName dc), tys))           dcs (map stripFiltered <$> elemHTys)) argHTyss1++-- | Determine whether a data constructor has unconstrained existential type+-- variables, i.e. those that cannot be inferred by the (potential) constraints+-- between the existential type variables and universal type variables.+--+-- So here we have an example of a constrained existential:+--+-- data Vec :: Nat -> Type -> Type+--  where+--   Nil  :: Vec 0 a+--   Cons :: forall m . (n ~ m + 1) => a -> Vec m a -> Vec n a+--+-- where we can generate a type for `m` when we know `n` (by doing `n-1`).+--+-- And here is an example of an unconstrained existential:+--+-- data SomeSNat where+--  where+--   SomeSNat :: forall m . SNat m -> SomeSNat+--+-- where there is no way to generate a type for `m` from any context.+--+-- So why do we care? Because terms need to be completely monomorphic in order+-- to be translated to circuits. And having a topEntity lambda-bound variable+-- with an unconstrained existential type prevents us from achieving a fully+-- monomorphic term.+hasUnconstrainedExistential+  :: TyConMap+  -> DataCon+  -> Bool+hasUnconstrainedExistential tcm dc =+  let eTVs        = dcExtTyVars dc+      uTVs        = dcUnivTyVars dc+      constraints = mapMaybe (typeEq tcm) (dcArgTys dc)++      -- Is the existential `eTV` constrained by the constraint `(ty1,ty2)`+      isConstrainedBy eTV (ty1,ty2) =+        let -- Free FVs in the LHS and RHS of the constraint that are not the+            -- in the set of universal type variables of the constructor.+            ty1FEVs = Lens.toListOf (typeFreeVars' ((`notElem` uTVs) . coerce)+                                                   IntSet.empty)+                                    ty1+            ty2FEVs = Lens.toListOf (typeFreeVars' ((`notElem` uTVs) . coerce)+                                                   IntSet.empty)+                                    ty2++            -- Determine whether `eTV` can be generated from one side of a+            -- constraint, under the assumption that the other side of the+            -- constraint mentions no existential type variables.+            isGenerative ::+              -- Side (LHS or RHS) of a constraint+              Type ->+              -- Its free type variables (that are no in the set of universal+              -- type variables)+              [TyVar] ->+              Bool+            isGenerative t efvs = case tyView t of+              TyConApp tcNm _+                | Just (FunTyCon {}) <- lookupUniqMap tcNm tcm+                -- For type families we can only "calculate" the `eTV` if it is+                -- the only free variable. e.g. we can work out from `n + 1 ~ 4`+                -- that `n ~ 3`, but can't do anything for `n + m ~ 4`.+                -> [eTV] == efvs+                | otherwise+                -- Normal type constructors are fully generative, e.g. given:+                -- DomainConfiguration a b ~ DomainConfiguration "System" 10000+                --+                -- we can infer both `a ~ "System"` and `b ~ 10000`+                -> eTV `elem` efvs+              FunTy {}+                -- Functions are also fully generative+                -> eTV `elem` efvs+              OtherType other -> case other of+                VarTy v -> v == eTV+                LitTy _ -> False+                -- Anything else, like some higher-kinded quantified type we+                -- just give up for now. TODO: implement this+                _ -> False++            onlyTy1 = isGenerative ty1 ty1FEVs && null ty2FEVs+            onlyTy2 = isGenerative ty2 ty2FEVs && null ty1FEVs+        in  onlyTy1 || onlyTy2++      -- The existential type variables that are not constrained by any of the+      -- constraints.+      unconstrainedETVs =+        filter (\v -> not (any (isConstrainedBy v) constraints)) eTVs++  in  not (null unconstrainedETVs)+  -- | Simple check if a TyCon is recursively defined. isRecursiveTy :: TyConMap -> TyConName -> Bool

@@ -119,6 +119,8 @@     rwEnv     = RewriteEnv                   (opt_dbgLevel opts)                   (opt_dbgTransformations opts)+                  (opt_dbgTransformationsFrom opts)+                  (opt_dbgTransformationsLimit opts)                   (opt_aggressiveXOpt opts)                   typeTrans                   tcm@@ -134,6 +136,7 @@                   (error $ $(curLoc) ++ "Report as bug: no curFun",noSrcSpan)                   0                   (IntMap.empty, 0)+                  emptyVarEnv                   normState      normState = NormalizeState

@@ -32,6 +32,7 @@  module Clash.Normalize.DEC   (collectGlobals+  ,collectGlobalsArgs   ,isDisjoint   ,mkDisjointGroup   )@@ -44,6 +45,7 @@ import           Data.Coerce                      (coerce) import qualified Data.Either                      as Either import qualified Data.Foldable                    as Foldable+import qualified Data.Graph                       as Graph import qualified Data.IntMap.Strict               as IM import qualified Data.IntSet                      as IntSet import qualified Data.List                        as List@@ -64,9 +66,10 @@ import Clash.Core.TermInfo   (termType) import Clash.Core.TyCon      (tyConDataCons) import Clash.Core.Type       (Type, isPolyFunTy, mkTyConApp, splitFunForallTy)+import Clash.Core.Util       (sccLetBindings) import Clash.Core.Var        (isGlobalId) import Clash.Core.VarEnv-  (InScopeSet, elemInScopeSet, notElemInScopeSet)+  (InScopeSet, elemInScopeSet, extendInScopeSetList, notElemInScopeSet, unionInScope) import Clash.Normalize.Types (NormalizeState) import Clash.Rewrite.Types   (RewriteMonad, bindings, evaluator, globalHeap, tcCache, tupleTcCache, uniqSupply)@@ -128,15 +131,17 @@   -- ^ Whether expression is constant   -> RewriteMonad       NormalizeState-      (Term, [(Term, ([Term], CaseTree [Either Term Type]))])-collectGlobals' inScope substitution seen (Case scrut ty alts) _eIsConstant = do-  rec (alts' ,collected)  <- collectGlobalsAlts inScope substitution seen scrut'-                                                alts-      (scrut',collected') <- collectGlobals inScope substitution-                                            (map fst collected ++ seen) scrut-  return (Case scrut' ty alts',collected ++ collected')+      (Term, InScopeSet, [(Term, ([Term], CaseTree [Either Term Type]))])+collectGlobals' is0 substitution seen (Case scrut ty alts) _eIsConstant = do+  rec (alts1, isAlts, collectedAlts) <-+        collectGlobalsAlts is0 substitution seen scrut1 alts+      (scrut1, isScrut, collectedScrut) <-+        collectGlobals is0 substitution (map fst collectedAlts ++ seen) scrut+  return ( Case scrut1 ty alts1+         , unionInScope isAlts isScrut+         , collectedAlts ++ collectedScrut ) -collectGlobals' inScope substitution seen e@(collectArgsTicks -> (fun, args@(_:_), ticks)) eIsconstant+collectGlobals' is0 substitution seen e@(collectArgsTicks -> (fun, args@(_:_), ticks)) eIsconstant   | not eIsconstant = do     tcm <- Lens.view tcCache     bndrs <- Lens.use bindings@@ -145,47 +150,52 @@     ids <- Lens.use uniqSupply     let (ids1,ids2) = splitSupply ids     uniqSupply Lens..= ids2-    let eval = (Lens.view Lens._3) . whnf' primEval primUnwind bndrs tcm gh ids1 inScope False+    let eval = (Lens.view Lens._3) . whnf' primEval primUnwind bndrs tcm gh ids1 is0 False         eTy  = termType tcm e     untran <- isUntranslatableType False eTy     case untran of       -- Don't lift out non-representable values, because they cannot be let-bound       -- in our desired normal form.       False -> do-        isInteresting <- interestingToLift inScope eval fun args ticks+        -- Look for, and substitute by, disjoint applications of globals in+        -- the arguments first before considering the current term in function+        -- position. Doing it in the other order (this term in function position+        -- first, followed by arguments) resulted in issue #1322+        (args1,isArgs,collectedArgs) <-+          collectGlobalsArgs is0 substitution seen args+        let seenInArgs = map fst collectedArgs ++ seen+        isInteresting <- interestingToLift is0 eval fun args ticks         case isInteresting of-          Just fun' | fun' `notElem` seen -> do-            (args',collected) <- collectGlobalsArgs inScope substitution-                                                    (fun':seen) args-            let e' = Maybe.fromMaybe (mkApps fun' args') (List.lookup fun' substitution)+          Just fun1 | fun1 `notElem` seenInArgs -> do+            let e1 = Maybe.fromMaybe (mkApps fun1 args1) (List.lookup fun1 substitution)             -- This function is lifted out an environment with the currently 'seen'             -- binders. When we later apply substitution, we need to start with this             -- environment, otherwise we perform incorrect substitutions in the             -- arguments.-            return (e',(fun',(seen,Leaf args')):collected)-          _ -> do (args',collected) <- collectGlobalsArgs inScope substitution-                                                          seen args-                  return (mkApps (mkTicks fun ticks) args',collected)-      _ -> return (e,[])+            return (e1,isArgs,(fun1,(seen,Leaf args1)):collectedArgs)+          _ -> return (mkApps (mkTicks fun ticks) args1, isArgs, collectedArgs)+      _ -> return (e,is0,[])  -- FIXME: This duplicates A LOT of let-bindings, where I just pray that after -- the ANF, CSE, and DeadCodeRemoval pass all duplicates are removed. -- -- I think we should be able to do better, but perhaps we cannot fix it here.-collectGlobals' inScope substitution seen (Letrec lbs body) _eIsConstant = do-  (body',collected)   <- collectGlobals    inScope substitution seen body-  (lbs',collected')   <- collectGlobalsLbs inScope substitution-                                           (map fst collected ++ seen)-                                           lbs-  return (Letrec lbs' body'-         ,map (second (second (LB lbs'))) (collected ++ collected')+collectGlobals' is0 substitution seen (Letrec lbs body) _eIsConstant = do+  let is1 = extendInScopeSetList is0 (map fst lbs)+  (body1,isBody,collectedBody) <-+    collectGlobals is1 substitution seen body+  (lbs1,isBndrs,collectedBndrs) <-+    collectGlobalsLbs is1 substitution (map fst collectedBody ++ seen) lbs+  return ( Letrec lbs1 body1+         , unionInScope isBody isBndrs+         , map (second (second (LB lbs1))) (collectedBody ++ collectedBndrs)          ) -collectGlobals' inScope substitution seen (Tick t e) eIsConstant = do-  (e',collected) <- collectGlobals' inScope substitution seen e eIsConstant-  return (Tick t e',collected)+collectGlobals' is0 substitution seen (Tick t e) eIsConstant = do+  (e1,is1,collected) <- collectGlobals' is0 substitution seen e eIsConstant+  return (Tick t e1, is1, collected) -collectGlobals' _ _ _ e _ = return (e,[])+collectGlobals' is0 _ _ e _ = return (e,is0,[])  -- | Collect 'CaseTree's for (potentially) disjoint applications of globals out -- of an expression. Also substitute truly disjoint applications of globals by a@@ -201,7 +211,7 @@   -- ^ The expression   -> RewriteMonad       NormalizeState-      (Term, [(Term, ([Term], CaseTree [Either Term Type]))])+      (Term, InScopeSet, [(Term, ([Term], CaseTree [Either Term Type]))]) collectGlobals inScope substitution seen e =   collectGlobals' inScope substitution seen e (isConstant e) @@ -216,16 +226,17 @@   -> [Either Term Type] -- ^ The list of arguments   -> RewriteMonad NormalizeState                   ([Either Term Type]+                  ,InScopeSet                   ,[(Term,([Term],CaseTree [(Either Term Type)]))]                   )-collectGlobalsArgs inScope substitution seen args = do-    (_,(args',collected)) <- second unzip <$> List.mapAccumLM go seen args-    return (args',concat collected)+collectGlobalsArgs is0 substitution seen args = do+    ((is1,_),(args',collected)) <- second unzip <$> List.mapAccumLM go (is0,seen) args+    return (args',is1,concat collected)   where-    go s (Left tm) = do-      (tm',collected) <- collectGlobals inScope substitution s tm-      return (map fst collected ++ s,(Left tm',collected))-    go s (Right ty) = return (s,(Right ty,[]))+    go (isN0,s) (Left tm) = do+      (tm',isN1,collected) <- collectGlobals isN0 substitution s tm+      return ((isN1,map fst collected ++ s),(Left tm',collected))+    go (isN,s) (Right ty) = return ((isN,s),(Right ty,[]))  -- | Collect 'CaseTree's for (potentially) disjoint applications of globals out -- of a list of alternatives. Also substitute truly disjoint applications of@@ -239,18 +250,20 @@   -> [(Pat,Term)] -- ^ The list of alternatives   -> RewriteMonad NormalizeState                   ([(Pat,Term)]+                  ,InScopeSet                   ,[(Term,([Term],CaseTree [(Either Term Type)]))]                   )-collectGlobalsAlts inScope substitution seen scrut alts = do-    (alts',collected) <- unzip <$> mapM go alts+collectGlobalsAlts is0 substitution seen scrut alts = do+    (is1,(alts',collected)) <- second unzip <$> List.mapAccumLM go is0 alts     let collectedM  = map (Map.fromList . map (second (second (:[])))) collected         collectedUN = Map.unionsWith (\(l1,r1) (l2,r2) -> (List.nub (l1 ++ l2),r1 ++ r2)) collectedM         collected'  = map (second (second (Branch scrut))) (Map.toList collectedUN)-    return (alts',collected')+    return (alts',is1,collected')   where-    go (p,e) = do-      (e',collected) <- collectGlobals inScope substitution seen e-      return ((p,e'),map (second (second (p,))) collected)+    go isN0 (p,e) = do+      let isN1 = extendInScopeSetList isN0 (snd (patIds p))+      (e',isN2,collected) <- collectGlobals isN1 substitution seen e+      return (isN2,((p,e'),map (second (second (p,))) collected))  -- | Collect 'CaseTree's for (potentially) disjoint applications of globals out -- of a list of let-bindings. Also substitute truly disjoint applications of@@ -263,22 +276,40 @@   -> [LetBinding] -- ^ The list let-bindings   -> RewriteMonad NormalizeState                   ([LetBinding]+                  ,InScopeSet                   ,[(Term,([Term],CaseTree [(Either Term Type)]))]                   )-collectGlobalsLbs inScope substitution seen lbs = do-    (_,(lbs',collected)) <- second unzip <$> List.mapAccumLM go seen lbs-    return (lbs',concat collected)+collectGlobalsLbs is0 substitution seen lbs = do+    let lbsSCCs = sccLetBindings lbs+    ((is1,_),(lbsSCCs1,collected)) <-+      second unzip <$> List.mapAccumLM go (is0,seen) lbsSCCs+    return (Graph.flattenSCCs lbsSCCs1,is1,concat collected)   where-    go :: [Term] -> LetBinding+    go :: (InScopeSet,[Term]) -> Graph.SCC LetBinding        -> RewriteMonad NormalizeState-                  ([Term]-                  ,(LetBinding+                  ((InScopeSet, [Term])+                  ,(Graph.SCC LetBinding                    ,[(Term,([Term],CaseTree [(Either Term Type)]))]                    )                   )-    go s (id_, e) = do-      (e',collected) <- collectGlobals inScope substitution s e-      return (map fst collected ++ s,((id_,e'),collected))+    go (isN0,s) (Graph.AcyclicSCC (id_, e)) = do+      (e',isN1,collected) <- collectGlobals isN0 substitution s e+      return ((isN1,map fst collected ++ s),(Graph.AcyclicSCC (id_,e'),collected))+    -- TODO: This completely skips recursive let-bindings in the collection of+    -- potentially disjoint applications of globals; and skips substituting truly+    -- disjoint applications of globals by a reference to a lifted out application.+    --+    -- This is to prevent the creation of combinational loops that have occurred+    -- "in the wild", but for which we have not been able to a create small+    -- unit test that triggers this creation-of-combinational-loops bug.+    -- Completely skipping recursive let-bindings is taking the hammer to+    -- solving this bug, without knowing whether a scalpel even existed and what+    -- it might look like. We should at some point think hard how traversing+    -- recursive let-bindings can introduce combinational loops, and whether+    -- there exists a solution that can traverse recursive let-bindings,+    -- finding more opportunities for DEC, while not introducing combinational+    -- loops.+    go acc scc@(Graph.CyclicSCC {}) = return (acc,(scc,[]))  -- | Given a case-tree corresponding to a disjoint interesting \"term-in-a- -- function-position\", return a let-expression: where the let-binding holds

@@ -33,23 +33,30 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}  module Clash.Normalize.PrimitiveReductions where  import qualified Control.Lens                     as Lens+import           Control.Lens                     ((.=)) import           Data.List                        (mapAccumR) import qualified Data.Maybe                       as Maybe+import           TextShow                         (showt) -import           PrelNames                        (boolTyConKey)+import           PrelNames+  (boolTyConKey, typeNatAddTyFamNameKey, typeNatMulTyFamNameKey,+   typeNatSubTyFamNameKey) import           Unique                           (getKey)+import           SrcLoc                           (wiredInSrcSpan)  import           Clash.Core.DataCon               (DataCon) import           Clash.Core.Literal               (Literal (..))-import           Clash.Core.Name                  (nameOcc)+import           Clash.Core.Name+  (nameOcc, Name(..), NameSort(User), mkUnsafeSystemName) import           Clash.Core.Pretty                (showPpr) import           Clash.Core.Term   (CoreContext (..), PrimInfo (..), Term (..), WorkInfo (..), Pat (..),-   collectTermIds, mkApps, idToVar)+   collectTermIds, mkApps) import           Clash.Core.TermInfo import           Clash.Core.Type                  (LitTy (..), Type (..),                                                    TypeView (..), coreView1,@@ -57,12 +64,13 @@                                                    splitFunForallTy, tyView) import           Clash.Core.TyCon   (TyConMap, TyConName, tyConDataCons, tyConName)-import           Clash.Core.TysPrim               (integerPrimTy, typeNatKind)+import           Clash.Core.TysPrim+  (integerPrimTy, typeNatKind, liftedTypeKind) import           Clash.Core.Util   (appendToVec, extractElems, extractTElems, mkRTree,    mkUniqInternalId, mkUniqSystemTyVar, mkVec, dataConInstArgTys,    primCo, undefinedTm)-import           Clash.Core.Var                   (Var (..))+import           Clash.Core.Var                   (Var (..), mkTyVar, mkLocalId) import           Clash.Core.VarEnv   (InScopeSet, extendInScopeSetList) import {-# SOURCE #-} Clash.Normalize.Strategy@@ -71,7 +79,184 @@ import           Clash.Rewrite.Util import           Clash.Unique import           Clash.Util+import qualified Clash.Util.Interpolate           as I +typeNatAdd :: TyConName+typeNatAdd =+  Name User "GHC.TypeNats.+" (getKey typeNatAddTyFamNameKey) wiredInSrcSpan++typeNatMul :: TyConName+typeNatMul =+  Name User "GHC.TypeNats.*" (getKey typeNatMulTyFamNameKey) wiredInSrcSpan++typeNatSub :: TyConName+typeNatSub =+  Name User "GHC.TypeNats.-" (getKey typeNatSubTyFamNameKey) wiredInSrcSpan++vecHeadPrim+  :: TyConName+  -- ^ Vec TyCon name+  -> Term+vecHeadPrim vecTcNm =+ -- head :: Vec (n+1) a -> a+  Prim (PrimInfo "Clash.Sized.Vector.head" (vecHeadTy vecTcNm) WorkNever)++vecLastPrim+  :: TyConName+  -- ^ Vec TyCon name+  -> Term+vecLastPrim vecTcNm =+  -- last :: Vec (n+1) a -> a+  -- has the same type signature as head, hence we're reusing its type+  -- definition here.+  Prim (PrimInfo "Clash.Sized.Vector.last" (vecHeadTy vecTcNm) WorkNever)++vecHeadTy+  :: TyConName+  -- ^ Vec TyCon name+  -> Type+vecHeadTy vecNm =+  ForAllTy nTV $+  ForAllTy aTV $+  mkFunTy+    (mkTyConApp vecNm [mkTyConApp typeNatAdd [VarTy nTV, LitTy (NumTy 1)], VarTy aTV])+    (VarTy aTV)+ where+  aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 0)+  nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 1)++vecTailPrim+  :: TyConName+  -- ^ Vec TyCon name+  -> Term+vecTailPrim vecTcNm =+  -- tail :: Vec (n + 1) a -> Vec n a+  Prim (PrimInfo "Clash.Sized.Vector.tail" (vecTailTy vecTcNm) WorkNever)++vecInitPrim+  :: TyConName+  -- ^ Vec TyCon name+  -> Term+vecInitPrim vecTcNm =+  -- init :: Vec (n + 1) a -> Vec n a+  -- has the same type signature as tail, hence we're reusing its type+  -- definition here.+  Prim (PrimInfo "Clash.Sized.Vector.init" (vecTailTy vecTcNm) WorkNever)++vecTailTy+  :: TyConName+  -- ^ Vec TyCon name+  -> Type+vecTailTy vecNm =+  ForAllTy nTV $+  ForAllTy aTV $+  mkFunTy+    (mkTyConApp vecNm [mkTyConApp typeNatAdd [VarTy nTV, LitTy (NumTy 1)], VarTy aTV])+    (mkTyConApp vecNm [VarTy nTV, VarTy aTV])+ where+  nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 0)+  aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 1)++-- | Makes two case statements: the first one extract the _head_ from the given+-- vector, the latter the tail.+extractHeadTail+  :: DataCon+  -- ^ The Cons (:>) constructor+  -> Type+  -- ^ Element type+  -> Integer+  -- ^ Length of the vector+  -> Term+  -- ^ Vector to extract head from+  -> (Term, Term)+  -- ^ (head of vector, tail of vector)+extractHeadTail consCon elTy n vec =+  ( Case vec elTy [(pat, Var el)]+  , Case vec restTy [(pat, Var rest)] )+ where+  tys = [(LitTy (NumTy n)), elTy, (LitTy (NumTy (n-1)))]+  Just [coTy, _elTy, restTy] = dataConInstArgTys consCon tys++  mTV = mkTyVar typeNatKind (mkUnsafeSystemName "m" 0)+  co = mkLocalId coTy (mkUnsafeSystemName "_co_" 1)+  el = mkLocalId elTy (mkUnsafeSystemName "el" 2)+  rest = mkLocalId restTy (mkUnsafeSystemName "res" 3)++  pat = DataPat consCon [mTV] [co, el, rest]++-- Make case statement that projects the _head_ from a given vector+extractHead+  :: DataCon+  -- ^ The Cons (:>) constructor+  -> Type+  -- ^ Element type+  -> Integer+  -- ^ Length of the vector+  -> Term+  -- ^ Vector to extract head from+  -> Term+  -- ^ Head of vector+extractHead consCon elTy vLength vec =+  fst (extractHeadTail consCon elTy vLength vec)++-- Make case statement that projects the _tail_ from a given vector+extractTail+  :: DataCon+  -- ^ The Cons (:>) constructor+  -> Type+  -- ^ Element type+  -> Integer+  -- ^ Length of the vector+  -> Term+  -- ^ Vector to extract head from+  -> Term+  -- ^ Tail of vector+extractTail consCon elTy vLength vec =+  snd (extractHeadTail consCon elTy vLength vec)++-- | Create a vector of supplied elements+mkVecCons+  :: HasCallStack+  => DataCon+  -- ^ The Cons (:>) constructor+  -> Type+  -- ^ Element type+  -> Integer+  -- ^ Length of the vector+  -> Term+  -- ^ head of the vector+  -> Term+  -- ^ tail of the vector+  -> Term+mkVecCons consCon resTy n h t+  | n <= 0 = error "mkVecCons: n <= 0"+  | otherwise =+    mkApps (Data consCon) [ Right (LitTy (NumTy n))+                          , Right resTy+                          , Right (LitTy (NumTy (n-1)))+                          , Left (primCo consCoTy)+                          , Left h+                          , Left t ]++ where+  args = dataConInstArgTys consCon [LitTy (NumTy n), resTy, LitTy (NumTy (n-1))]+  Just (consCoTy : _) = args++-- | Create an empty vector+mkVecNil+  :: DataCon+  -- ^ The Nil constructor+  -> Type+  -- ^ The element type+  -> Term+mkVecNil nilCon resTy =+  mkApps (Data nilCon) [ Right (LitTy (NumTy 0))+                       , Right resTy+                       , Left  (primCo nilCoTy) ]+ where+  args = dataConInstArgTys nilCon [LitTy (NumTy 0), resTy]+  Just (nilCoTy : _ ) = args+ -- | Replace an application of the @Clash.Sized.Vector.reverse@ primitive on -- vectors of a known length @n@, by the fully unrolled recursive "definition" -- of @Clash.Sized.Vector.reverse@@@ -109,74 +294,90 @@ -- of @Clash.Sized.Vector.zipWith@ reduceZipWith   :: TransformContext+  -> PrimInfo -- ^ zipWith primitive info   -> Integer  -- ^ Length of the vector(s)-  -> Type -- ^ Type of the lhs of the function-  -> Type -- ^ Type of the rhs of the function-  -> Type -- ^ Type of the result of the function+  -> Type -- ^ Element type of the lhs of the function+  -> Type -- ^ Element type of the rhs of the function+  -> Type -- ^ Element type of the result of the function   -> Term -- ^ The zipWith'd functions   -> Term -- ^ The 1st vector argument   -> Term -- ^ The 2nd vector argument   -> NormalizeSession Term-reduceZipWith (TransformContext is0 ctx) n lhsElTy rhsElTy resElTy fun lhsArg rhsArg = do-    tcm <- Lens.view tcCache-    let ty = termType tcm lhsArg-    go tcm ty-  where-    go tcm (coreView1 tcm -> Just ty') = go tcm ty'-    go tcm (tyView -> TyConApp vecTcNm _)-      | (Just vecTc) <- lookupUniqMap vecTcNm tcm-      , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"-      , [nilCon,consCon] <- tyConDataCons vecTc-      = do-        uniqs0 <- Lens.use uniqSupply-        fun1   <- constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) fun-        let is1 = extendInScopeSetList is0 (collectTermIds fun1)-            (uniqs1,(varsL,elemsL)) = second (second concat . unzip)-                                    $ extractElems uniqs0 is1 consCon lhsElTy 'L' n lhsArg-            is2 = extendInScopeSetList is0 (map fst elemsL)-            (uniqs2,(varsR,elemsR)) = second (second concat . unzip)-                                    $ extractElems uniqs1 is2 consCon rhsElTy 'R' n rhsArg-            funApps          = zipWith (\l r -> mkApps fun1 [Left l,Left r]) varsL varsR-            lbody            = mkVec nilCon consCon resElTy n funApps-            lb               = Letrec (init elemsL ++ init elemsR) lbody-        uniqSupply Lens..= uniqs2-        changed lb-    go _ ty = error $ $(curLoc) ++ "reduceZipWith: argument does not have a vector type: " ++ showPpr ty+reduceZipWith _ctx zipWithPrimInfo n lhsElTy rhsElTy resElTy fun lhsArg rhsArg = do+  tcm <- Lens.view tcCache+  changed (go tcm (termType tcm lhsArg))+ where+  go tcm (coreView1 tcm -> Just ty) = go tcm ty+  go tcm (tyView -> TyConApp vecTcNm _)+    | (Just vecTc) <- lookupUniqMap vecTcNm tcm+    , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+    , [nilCon, consCon] <- tyConDataCons vecTc+    = if n == 0 then+        mkVecNil nilCon resElTy+      else+        let+          (a, as) = extractHeadTail consCon lhsElTy n lhsArg+          (b, bs) = extractHeadTail consCon rhsElTy n rhsArg+          c = mkApps fun [Left a, Left b]+          cs = mkApps (Prim zipWithPrimInfo) [ Right lhsElTy+                                             , Right rhsElTy+                                             , Right resElTy+                                             , Right (LitTy (NumTy (n - 1)))+                                             , Left fun+                                             , Left as+                                             , Left bs ]+        in+          mkVecCons consCon resElTy n c cs+  go _ ty =+    error $ $(curLoc) ++ [I.i|+      reduceZipWith: argument does not have a vector type: +        #{showPpr ty}+    |]+ -- | Replace an application of the @Clash.Sized.Vector.map@ primitive on vectors -- of a known length @n@, by the fully unrolled recursive "definition" of -- @Clash.Sized.Vector.map@ reduceMap   :: TransformContext+  -> PrimInfo -- ^ map primitive info   -> Integer  -- ^ Length of the vector   -> Type -- ^ Argument type of the function   -> Type -- ^ Result type of the function   -> Term -- ^ The map'd function   -> Term -- ^ The map'd over vector   -> NormalizeSession Term-reduceMap (TransformContext is0 ctx) n argElTy resElTy fun arg = do+reduceMap _ctx mapPrimInfo n argElTy resElTy fun arg = do     tcm <- Lens.view tcCache     let ty = termType tcm arg-    go tcm ty+    changed (go tcm ty)   where     go tcm (coreView1 tcm -> Just ty') = go tcm ty'     go tcm (tyView -> TyConApp vecTcNm _)       | (Just vecTc)     <- lookupUniqMap vecTcNm tcm       , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"       , [nilCon,consCon] <- tyConDataCons vecTc-      = do-        uniqs0 <- Lens.use uniqSupply-        fun1 <- constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) fun-        let is1 = extendInScopeSetList is0 (collectTermIds fun1)-            (uniqs1,(vars,elems)) = second (second concat . unzip)-                                  $ extractElems uniqs0 is1 consCon argElTy 'A' n arg-            funApps          = map (fun1 `App`) vars-            lbody            = mkVec nilCon consCon resElTy n funApps-            lb               = Letrec (init elems) lbody-        uniqSupply Lens..= uniqs1-        changed lb-    go _ ty = error $ $(curLoc) ++ "reduceMap: argument does not have a vector type: " ++ showPpr ty+      = if n == 0 then+          mkVecNil nilCon argElTy+        else+          let+            nPredTy = Right (LitTy (NumTy (n - 1)))+            (a, as) = extractHeadTail consCon argElTy n arg+            b = mkApps fun [Left a]+            bs = mkApps (Prim mapPrimInfo) [ Right argElTy+                                           , Right resElTy+                                           , nPredTy+                                           , Left fun+                                           , Left as ]+          in+            mkVecCons consCon resElTy n b bs+    go _ ty =+      error $ $(curLoc) ++ [I.i|+        reduceMap: argument does not have a vector type: +          #{showPpr ty}+      |]+ -- | Replace an application of the @Clash.Sized.Vector.imap@ primitive on vectors -- of a known length @n@, by the fully unrolled recursive "definition" of -- @Clash.Sized.Vector.imap@@@ -224,6 +425,56 @@         changed lb     go _ ty = error $ $(curLoc) ++ "reduceImap: argument does not have a vector type: " ++ showPpr ty +-- | Replace an application of the @Clash.Sized.Vector.iterateI@ primitive on+-- vectors of a known length @n@, by the fully unrolled recursive "definition"+-- of @Clash.Sized.Vector.iterateI@+reduceIterateI+  :: TransformContext+  -> Integer+  -- ^ Length of vector+  -> Type+  -- ^ Vector's element type+  -> Type+  -- ^ Vector's type+  -> Term+  -- ^ iterateI's HO-function argument+  -> Term+  -- ^ iterateI's start value+  -> RewriteMonad NormalizeState Term+  -- ^ Fully unrolled definition+reduceIterateI (TransformContext is0 ctx) n aTy vTy f0 a = do+  tcm <- Lens.view tcCache+  f1 <- constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) f0++  -- Generate uniq ids for element assignments.+  uniqs0 <- Lens.use uniqSupply+  let+    is1 = extendInScopeSetList is0 (collectTermIds f1)+    ((uniqs1, _is2), elementIds) =+      mapAccumR+        mkUniqInternalId+        (uniqs0, is1)+        (zip (map (("el" <>) . showt) [1..n-1]) (repeat aTy))+  uniqSupply .= uniqs1++  let+    TyConApp vecTcNm _ = tyView vTy+    Just vecTc = lookupUniqMap vecTcNm tcm+    [nilCon, consCon] = tyConDataCons vecTc+    elems = map (App f1) (a:map Var elementIds)+    vec = mkVec nilCon consCon aTy n (take (fromInteger n) (a:map Var elementIds))++  -- Result:+  --   let+  --     el1 = f a+  --     el2 = f el1+  --     el3 = f el2+  --     ..+  --   in+  --     (a :> el1 :> el2 :> el3 :> ..)+  --+  pure (Letrec (zip elementIds elems) vec)+ -- | Replace an application of the @Clash.Sized.Vector.traverse#@ primitive on -- vectors of a known length @n@, by the fully unrolled recursive "definition" -- of @Clash.Sized.Vector.traverse#@@@ -360,6 +611,8 @@ -- of @Clash.Sized.Vector.foldr@ reduceFoldr   :: TransformContext+  -> PrimInfo+  -- ^ Primitive info for foldr blackbox   -> Integer   -- ^ Length of the vector   -> Type@@ -371,29 +624,35 @@   -> Term   -- ^ The argument vector   -> NormalizeSession Term-reduceFoldr _ 0 _ _ start _ = changed start-reduceFoldr (TransformContext is0 ctx) n aTy fun start arg = do+reduceFoldr _ _ 0 _ _ start _ = changed start+reduceFoldr _ctx foldrPrimInfo n aTy fun start arg = do     tcm <- Lens.view tcCache     let ty = termType tcm arg-    go tcm ty+    changed (go tcm ty)   where     go tcm (coreView1 tcm -> Just ty') = go tcm ty'     go tcm (tyView -> TyConApp vecTcNm _)-      | (Just vecTc) <- lookupUniqMap vecTcNm tcm-      , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"-      , [_,consCon] <- tyConDataCons vecTc-      = do-        uniqs0 <- Lens.use uniqSupply-        fun1 <- constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) fun-        let is1 = extendInScopeSetList is0 (collectTermIds fun1)-            (uniqs1,(vars,elems)) = second (second concat . unzip)-                                  $ extractElems uniqs0 is1 consCon aTy 'G' n arg-            lbody            = foldr (\l r -> mkApps fun1 [Left l,Left r]) start vars-            lb               = Letrec (init elems) lbody-        uniqSupply Lens..= uniqs1-        changed lb-    go _ ty = error $ $(curLoc) ++ "reduceFoldr: argument does not have a vector type: " ++ showPpr ty+      | nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+      , Just vecTc <- lookupUniqMap vecTcNm tcm+      , [_nilCon, consCon] <- tyConDataCons vecTc+      = let+          (a, as) = extractHeadTail consCon aTy n arg+          b = mkApps (Prim foldrPrimInfo) [ Right aTy+                                          , Right (termType tcm start)+                                          , Right (LitTy (NumTy (n - 1)))+                                          , Left fun+                                          , Left start+                                          , Left as ]+        in+          mkApps fun [Left a, Left b] +    go _ ty =+      error $ $(curLoc) ++ [I.i|+        reduceFoldr: argument does not have a vector type:++          #{showPpr ty}+      |]+ -- | Replace an application of the @Clash.Sized.Vector.fold@ primitive on -- vectors of a known length @n@, by the fully unrolled recursive "definition" -- of @Clash.Sized.Vector.fold@@@ -580,34 +839,37 @@ -- vector. reduceInit   :: InScopeSet+  -> PrimInfo -- ^ Primitive info for 'init'   -> Integer  -- ^ Length of the vector   -> Type -- ^ Element type of the vector   -> Term -- ^ The argument vector   -> NormalizeSession Term-reduceInit inScope n aTy vArg = do-    tcm <- Lens.view tcCache-    let ty = termType tcm vArg-    go tcm ty-  where-    go tcm (coreView1 tcm -> Just ty') = go tcm ty'-    go tcm (tyView -> TyConApp vecTcNm _)-      | (Just vecTc) <- lookupUniqMap vecTcNm tcm-      , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"-      , [nilCon,consCon]  <- tyConDataCons vecTc-      = do-        uniqs0 <- Lens.use uniqSupply-        let (uniqs1,(_,elems)) = second unzip-                               $ extractElems uniqs0 inScope consCon aTy 'L' n vArg-        uniqSupply Lens..= uniqs1-        case n of-         0 -> changed (undefinedTm aTy)-         1 -> changed (mkVec nilCon consCon aTy 0 [])-         _ -> let el = init elems-                  iv = mkVec nilCon consCon aTy (n-1) (map (idToVar . fst . head) el)-                  lb = init (concat el)-              in  changed (Letrec lb iv)+reduceInit _inScope initPrimInfo n aTy vArg = do+  tcm <- Lens.view tcCache+  let ty = termType tcm vArg+  changed (go tcm ty)+ where+  go tcm (coreView1 tcm -> Just ty') = go tcm ty'+  go tcm (tyView -> TyConApp vecTcNm _)+    | (Just vecTc) <- lookupUniqMap vecTcNm tcm+    , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+    , [nilCon, consCon]  <- tyConDataCons vecTc+    = if n == 0 then+        mkVecNil nilCon aTy+      else+        let+          nPredTy = Right (LitTy (NumTy (n - 1)))+          (a, as0) = extractHeadTail consCon aTy (n+1) vArg+          as1 = mkApps (Prim initPrimInfo) [nPredTy, Right aTy, Left as0]+        in+          mkVecCons consCon aTy n a as1 -    go _ ty = error $ $(curLoc) ++ "reduceInit: argument does not have a vector type: " ++ showPpr ty+  go _ ty =+    error $ $(curLoc) ++ [I.i|+      reduceInit: argument does not have a vector type:++        #{showPpr ty}+    |]  -- | Replace an application of the @Clash.Sized.Vector.(++)@ primitive on -- vectors of a known length @n@, by the fully unrolled recursive "definition"

@@ -15,6 +15,7 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-}  module Clash.Normalize.Transformations@@ -45,6 +46,7 @@   , disjointExpressionConsolidation   , removeUnusedExpr   , inlineCleanup+  , inlineBndrsCleanup   , flattenLet   , splitCastWork   , inlineCast@@ -61,9 +63,10 @@ where  import           Control.Exception           (throw)-import           Control.Lens                (_2)+import           Control.Lens                ((^.),_1,_2) import qualified Control.Lens                as Lens import qualified Control.Monad               as Monad+import           Control.Monad.Extra         (orM) import           Control.Monad.State         (StateT (..), modify) import           Control.Monad.State.Strict  (evalState) import           Control.Monad.Writer        (lift, listen)@@ -116,7 +119,7 @@    notElemVarSet, unionVarEnvWith, unionInScope, unitVarEnv,    unitVarSet, mkVarSet, mkInScopeSet, uniqAway, elemInScopeSet, elemVarEnv,    foldlWithUniqueVarEnv', lookupVarEnvDirectly, extendVarEnv, unionVarEnv,-   eltsVarEnv, mkVarEnv, eltsVarSet)+   eltsVarEnv, mkVarEnv, elemUniqInScopeSet) import           Clash.Debug import           Clash.Driver.Types          (Binding(..), DebugLevel (..)) import           Clash.Netlist.BlackBox.Types (Element(Err))@@ -133,8 +136,9 @@ import           Clash.Rewrite.Combinators import           Clash.Rewrite.Types import           Clash.Rewrite.Util-import           Clash.Unique                (Unique, lookupUniqMap)+import           Clash.Unique import           Clash.Util+import qualified Clash.Util.Interpolate as I  inlineOrLiftNonRep :: HasCallStack => NormRewrite inlineOrLiftNonRep ctx eLet@(Letrec _ body) =@@ -494,29 +498,44 @@   -- The subject is an applied data constructor   (Data dc, args, ticks) -> case List.find (equalCon . fst) alts of     Just (DataPat _ tvs xs, altE) -> do-      let is1 = extendInScopeSetList (extendInScopeSetList is0 tvs) xs-      let fvs = Lens.foldMapOf freeLocalIds unitVarSet altE-          (binds,_) = List.partition ((`elemVarSet` fvs) . fst)-                    $ zip xs (Either.lefts args)-          binds1 = map (second (`mkTicks` ticks)) binds-          altE1 = case binds1 of-            [] -> altE-            _  ->-              -- See Note [CaseCon deshadow]-              let-                ((is3,substIds),binds2) = List.mapAccumL newBinder (is1,[]) binds1-                subst = extendIdSubstList (mkSubst is3) substIds-                body  = substTm "caseCon0" subst altE-              in-                case Maybe.catMaybes binds2 of-                  []     -> body-                  binds3 -> Letrec binds3 body-      -- Use the original inScopeSet 'is0' here, not the extended inScopeSet-      -- 'is1', otherwise we'd make the "caseCon1" substitution substitute-      -- free variables that were shadowed by the pattern!-      let subst = extendTvSubstList (mkSubst is0)-                $ zip tvs (drop (length (dcUnivTyVars dc)) (Either.rights args))-      changed (substTm "caseCon1" subst altE1)+     let+      -- Create the substitution environment for all the existential+      -- type variables.+      exTysList = zip tvs (drop (length (dcUnivTyVars dc)) (Either.rights args))+      exTySubst = extendTvSubstList (mkSubst is0) exTysList+      -- Apply the type-substitution in all the pattern variables, we need+      -- to do this because we might use them as let-bindings later on,+      -- and they should have the correct type.+      xs1 = map (substTyInVar exTySubst) xs+      -- Create an initial set of let-binders for all variables used in the+      -- RHS of the alternative. We might later decide to substitute instead+      -- of let-bind in case the RHS of the let-binder is work-free.+      fvs = Lens.foldMapOf freeLocalIds unitVarSet altE+      (binds,_) = List.partition ((`elemVarSet` fvs) . fst)+                $ zip xs1 (Either.lefts args)+      binds1 = map (second (`mkTicks` ticks)) binds+     altE1 <-+       case binds1 of+        [] ->+          -- Apply the type-substitution for the existential type variables+          pure (substTm "caseCon1" exTySubst altE)+        _  -> do+          -- See Note [CaseCon deshadow]+          let+            -- Only let-bind expression that perform work.+            is1 = extendInScopeSetList (extendInScopeSetList is0 tvs) xs1+          ((is3,substIds),binds2) <- List.mapAccumLM newBinder (is1,[]) binds1+          let+            -- Create a substitution for all the existential type variables+            -- and the work-free expressions+            subst = extendIdSubstList+                      (extendTvSubstList (mkSubst is3) exTysList)+                      substIds+            body  = substTm "caseCon1" subst altE+          case Maybe.catMaybes binds2 of+            []     -> pure body+            binds3 -> pure (Letrec binds3 body)+     changed altE1     _ -> case alts of            -- In Core, default patterns always come first, so we match against            -- that if there is one, and we couldn't match with any of the data@@ -532,13 +551,15 @@       -- be let-bound, or substituted into the alternative. We decide this       -- based on the fact on whether the argument has the potential to make       -- the circuit larger than needed if we were to duplicate that argument.-      newBinder (isN0,substN) (x,arg)-        | isWorkFree arg-        = ((isN0,(x,arg):substN),Nothing)-        | otherwise-        = let x'   = uniqAway isN0 x+      newBinder (isN0, substN) (x, arg) = do+        isWorkFree arg >>= \case+          True -> pure ((isN0, (x, arg):substN), Nothing)+          False ->+            let+              x' = uniqAway isN0 x               isN1 = extendInScopeSet isN0 x'-          in  ((isN1,(x,Var x'):substN),Just (x',arg))+            in+              pure ((isN1, (x, Var x'):substN), Just (x', arg))     -- The subject is a literal@@ -819,30 +840,10 @@  -- | Remove unused let-bindings deadCode :: HasCallStack => NormRewrite-deadCode _ e@(Letrec binds body) = do-  let bodyFVs = Lens.foldMapOf freeLocalIds unitVarSet body-      used    = List.foldl' collectUsed emptyVarEnv (eltsVarSet bodyFVs)-  case eltsVarEnv used of-    [] -> changed body-    qqL | not (List.equalLength qqL binds)-        -> changed (Letrec qqL body)-        | otherwise-        -> return e- where-  bindsEnv = mkVarEnv (map (\(x,e0) -> (x,(x,e0))) binds)--  collectUsed env v =-    if v `elemVarEnv` env then-      env-    else-      case lookupVarEnv v bindsEnv of-        Just (x,e0) ->-          let eFVs = Lens.foldMapOf freeLocalIds unitVarSet e0-          in  List.foldl' collectUsed-                          (extendVarEnv x (x,e0) env)-                          (eltsVarSet eFVs)-        Nothing -> env-+deadCode _ e@(Letrec binds body) =+  case removeUnusedBinders binds body of+    Just t -> changed t+    Nothing -> return e deadCode _ e = return e {-# SCC deadCode #-} @@ -976,10 +977,9 @@ -- eliminate them in 'eliminateCastCast'. argCastSpec :: HasCallStack => NormRewrite argCastSpec ctx e@(App _ (stripTicks -> Cast e' _ _)) =-  if isWorkFree e' then-    go-  else-    warn go+  isWorkFree e' >>= \case+    True -> go+    False -> warn go  where   go = specializeNorm ctx e   warn = trace (unwords@@ -1284,12 +1284,12 @@    go is0 (Lam v e) (Left arg:args) ticks = do     setChanged-    if isWorkFree arg || isVar arg-      then do-        let subst = extendIdSubst (mkSubst is0) v arg+    orM [pure (isVar arg), isWorkFree arg] >>= \case+      True ->+        let subst = extendIdSubst (mkSubst is0) v arg in         (`mkTicks` ticks) <$> go is0 (substTm "appPropFast.AppLam" subst e) args []-      else do-        let is1 = extendInScopeSet is0 v+      False ->+        let is1 = extendInScopeSet is0 v in         Letrec [(v, arg)] <$> go is1 (deShadowTerm is1 e) args ticks    go is0 (Letrec vs e) args@(_:_) ticks = do@@ -1339,7 +1339,7 @@     tcm <- Lens.view tcCache     let argTy = termType tcm arg         ty1   = applyFunTy tcm ty0 argTy-    case isWorkFree arg || isVar arg of+    orM [pure (isVar arg), isWorkFree arg] >>= \case       True -> do         (ty2,ls1,args1) <- goCaseArg isA0 ty1 ls0 args0         return (ty2,ls1,Left arg:args1)@@ -2079,7 +2079,7 @@             if shouldReduce1                then let [fun,lhsArg,rhsArg] = Either.lefts args                     in  (`mkTicks` ticks) <$>-                        reduceZipWith c n lhsElTy rhsElty resElTy fun lhsArg rhsArg+                        reduceZipWith c p n lhsElTy rhsElty resElTy fun lhsArg rhsArg                else return e           _ -> return e       "Clash.Sized.Vector.map" | argLen == 5 -> do@@ -2092,7 +2092,7 @@                                         [argElTy,resElTy] ]             if shouldReduce1                then let [fun,arg] = Either.lefts args-                    in  (`mkTicks` ticks) <$> reduceMap c n argElTy resElTy fun arg+                    in  (`mkTicks` ticks) <$> reduceMap c p n argElTy resElTy fun arg                else return e           _ -> return e       "Clash.Sized.Vector.traverse#" | argLen == 7 ->@@ -2123,7 +2123,7 @@                                  , 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+                   in  (`mkTicks` ticks) <$> reduceFoldr c p n aTy fun start arg               else return e           _ -> return e       "Clash.Sized.Vector.dfold" | argLen == 8 ->@@ -2187,7 +2187,7 @@             shouldReduce1 <- List.orM [ shouldReduce ctx                                  , isUntranslatableType_not_poly aTy ]             if shouldReduce1-               then (`mkTicks` ticks) <$> reduceInit is0 (n+1) aTy vArg+               then (`mkTicks` ticks) <$> reduceInit is0 p n aTy vArg                else return e           _ -> return e       "Clash.Sized.Vector.unconcat" | argLen == 6 -> do@@ -2249,6 +2249,19 @@                     in  (`mkTicks` ticks) <$> reduceImap c n argElTy resElTy fun arg                else return e           _ -> return e+      "Clash.Sized.Vector.iterateI" | argLen == 5 -> do+        let ([_kn,f,a],[nTy,aTy]) = Either.partitionEithers args+        case runExcept (tyNatSize tcm nTy) of+          Right n -> do+            shouldReduce1 <- List.orM [+                pure (ultra || n < 2)+              , shouldReduce ctx+              , isUntranslatableType_not_poly aTy ]++            if shouldReduce1+            then (`mkTicks` ticks) <$> reduceIterateI c n aTy eTy f a+            else return e+          _ -> return e       "Clash.Sized.Vector.dtfold" | argLen == 8 ->         let ([_kn,_motive,lrFun,brFun,arg],[_mTy,nTy,aTy]) = Either.partitionEithers args         in  case runExcept (tyNatSize tcm nTy) of@@ -2345,39 +2358,112 @@ --       C -> h x -- @ disjointExpressionConsolidation :: HasCallStack => NormRewrite-disjointExpressionConsolidation ctx@(TransformContext is0 _) e@(Case _scrut _ty _alts@(_:_:_)) = do-    (_,collected) <- collectGlobals is0 [] [] e+disjointExpressionConsolidation ctx@(TransformContext isCtx _) e@(Case _scrut _ty _alts@(_:_:_)) = do+    -- Collect all (the applications of) global binders (and certain primitives)+    -- that would be interesting to share out of the case-alternatives.+    (_,isCollected,collected) <- collectGlobals isCtx [] [] e+    -- Filter those that are used at most once in every (nested) branch.     let disJoint = filter (isDisjoint . snd . snd) collected     if null disJoint        then return e        else do-         exprs <- mapM (mkDisjointGroup is0) disJoint-         tcm   <- Lens.view tcCache-         lids  <- Monad.zipWithM (mkFunOut is0 tcm) disJoint exprs-         let substitution = zip (map fst disJoint) (map Var lids)-             subsMatrix   = l2m substitution-         (exprs',_) <- unzip <$> Monad.zipWithM-                        (\s (e',seen) -> collectGlobals is0 s seen e')-                        subsMatrix-                        exprs-         (e',_) <- collectGlobals is0 substitution [] e-         let lb = Letrec (zip lids exprs') e'-         lb' <- bottomupR deadCode ctx lb-         changed lb'+         -- For every to-lift expression create (the generalization of):+         --+         -- let fargs = case x of {A -> (3,y); B -> (x,x)}+         -- in  f (fst fargs) (snd fargs)+         --+         -- the let-expression is not created when `f` has only one (selectable)+         -- argument+         --+         -- NB: mkDisJointGroup needs the context InScopeSet, isCtx, to determine+         -- whether expressions reference variables from the context, or+         -- variables inside a let-expression inside one of the alternatives.+         lifted <- mapM (mkDisjointGroup isCtx) disJoint+         tcm    <- Lens.view tcCache+         -- Create let-binders for all of the lifted expressions+         --+         -- NB: Because we will be substituting under binders we use the collected+         -- inScopeSet, isCollected, which also contains all the binders+         -- created inside all of the alternatives. With this inScopeSet, we+         -- ensure that the let-bindings we create here won't be accidentally+         -- captured by binders inside the case-alternatives.+         (_,funOutIds) <- List.mapAccumLM (mkFunOut tcm)+                                          isCollected+                                          (zip disJoint lifted)+         -- Create "substitutions" of the form [f X Y := f_out]+         let substitution = zip (map fst disJoint) (map Var funOutIds)+         -- For all of the lifted expression: substitute occurrences of the+         -- disjoint expressions (f X Y) by a variable reference to the lifted+         -- expression (f_out)+         let isCtx1 = extendInScopeSetList isCtx funOutIds+         lifted1 <- substLifted isCtx1 substitution lifted+         -- Do the same for the actual case expression+         (e1,_,_) <- collectGlobals isCtx1 substitution [] e+         -- Let-bind all the lifted function+         let lb = Letrec (zip funOutIds lifted1) e1+         -- Do an initial dead-code elimination pass, as `mkDisJoint` doesn't+         -- clean-up unused let-binders.+         lb1 <- bottomupR deadCode ctx lb+         changed lb1   where-    mkFunOut isN tcm (fun,_) (e',_) = do-      let ty  = termType tcm e'+    -- Make the let-binder for the lifted expressions+    mkFunOut tcm isN ((fun,_),(eLifted,_)) = do+      let ty  = termType tcm eLifted           nm  = case collectArgs fun of-                   (Var v,_)      -> nameOcc (varName v)+                   (Var v,_)  -> nameOcc (varName v)                    (Prim p,_) -> primName p-                   _             -> "complex_expression_"-          nm'' = last (Text.splitOn "." nm) `Text.append` "Out"-      mkInternalVar isN nm'' ty+                   _          -> "complex_expression_"+          nm1 = last (Text.splitOn "." nm) `Text.append` "Out"+      nm2 <- mkInternalVar isN nm1 ty+      return (extendInScopeSet isN nm2,nm2) +    -- Substitute inside the lifted expressions+    --+    -- In case you are wondering why this function isn't simply+    --+    -- > mapM (\s (eL,seen) -> collectGlobal isN s seen eL) substitution lifted+    --+    -- then that's because we have e.g. the list of "substitutions":+    --+    -- [foo _ _ := foo_out; bar _ _ := bar_out]+    --+    -- and if we were to apply that to a lifted expression, which is going+    -- to be of the form `foo (case ...) (case ...)` then we would end up+    -- with let-bindings that are simply:+    --+    -- > let foo_out = foo_out ; bar_out = bar_out+    --+    -- instead of the desired+    --+    -- > let foo_out = foo ((case ...)[foo _ _ := foo_out; bar _ _ := bar_out])+    -- >                   ((case ...)[foo _ _ := foo_out; bar _ _ := bar_out])+    -- >     bar_out = bar ((case ...)[foo _ _ := foo_out; bar _ _ := bar_out])+    -- >                   ((case ...)[foo _ _ := foo_out; bar _ _ := bar_out])+    --+    -- So what we do is that for every lifted-expression we make sure that the+    -- 'substitution' never contains the self-substitution, so we end up with:+    --+    -- > let foo_out = (foo (case ...) (case ...))[bar _ _ := bar_out]+    --       bar_out = (bar (case ...) (case ...))[foo _ _ := foo_out]+    --+    -- We used to have a different approach, see commit+    -- 73d237017c4a5fff0c49bb72c9c4d5f6c68faf69+    --+    -- But that lead to the generation of combinational loops. Now that we no+    -- longer traverse into recursive groups of let-bindings, the issue #1316+    -- that the above commit tried to solve, no longer shows up.+    substLifted isN substitution lifted = do+      -- remove the self-substitutions for the respective lifted expressions+      let subsMatrix = l2m substitution+      lifted1 <- Monad.zipWithM (\s (eL,seen) -> collectGlobals isN s seen eL)+                                 subsMatrix+                                 lifted+      return (map (^. _1) lifted1)+     l2m = go []-      where-        go _  []     = []-        go xs (y:ys) = (xs ++ ys) : go (xs ++ [y]) ys+     where+      go _  []     = []+      go xs (y:ys) = (xs ++ ys) : go (xs ++ [y]) ys  disjointExpressionConsolidation _ e = return e {-# SCC disjointExpressionConsolidation #-}@@ -2419,6 +2505,21 @@       -> (Id,((Id, Term), VarEnv Int))       -> Bool     isInteresting allOccs prims bodyFVs (id_,((_,(fst.collectArgs) -> tm),_))+      -- Try to keep user defined names, but inline names generated by GHC or+      -- Clash. For example, if a user were to write:+      --+      --    x = 2 * y+      --+      -- Even if 'x' is only used once, we'd like to keep it around to produce+      -- more readable HDL. In contrast, if a user were to write:+      --+      --    let x = f (2 * y)+      --+      -- ANF would transform that to:+      --+      --    let x = f f_arg; f_arg = 2 * y+      --+      -- In that case, there's no harm in inlining f_arg.       | nameSort (varName id_) /= User       , id_ `notElemVarSet` bodyFVs       = case tm of@@ -2472,7 +2573,8 @@ -- | Used by 'inlineCleanup' to inline binders that we want to inline into the -- binders that we want to keep. inlineBndrsCleanup-  :: InScopeSet+  :: HasCallStack+  => InScopeSet   -- ^ Current InScopeSet   -> VarEnv ((Id,Term),VarEnv Int)   -- ^ Original let-binders with their free variables (+ #occurrences), that we@@ -2492,23 +2594,29 @@   go doneInl [] =     -- If some of the let-binders that we wanted to inline turn out to be     -- recursive, then we have to keep those around as well, as we weren't able-    -- to inline them.-    [ (v,e) | ((v,e),_,Rec) <- eltsVarEnv doneInl ]-  go !doneInl (((v,e),eFVs):il) =-    let (sM,_,doneInl1) = foldlWithUniqueVarEnv'+    -- to inline them. Furthermore, for every recursive binder there might still+    -- be non-inlined variables left, see #1337.+    flip map [ (ve, eFvs) | (ve,eFvs,Rec) <- eltsVarEnv doneInl ] $ \((v, e), eFvs) ->+      let+        (substM, _, _) = foldlWithUniqueVarEnv'+                           (reduceBindersCleanup isN emptyVarEnv)+                           (Nothing, emptyVarEnv, doneInl)+                           eFvs+      in (v, maybeSubstTm "inlineBndrsCleanup_0" substM e)+  go !doneInl_0 (((v,e),eFVs):il) =+    let (sM,_,doneInl_1) = foldlWithUniqueVarEnv'                             (reduceBindersCleanup isN origInl)-                            (Nothing, emptyVarEnv, doneInl)+                            (Nothing, emptyVarEnv, doneInl_0)                             eFVs-        e1 = case sM of-               Nothing -> e-               Just s  -> substTm "inlineBndrsCleanup" s e-    in  (v,e1):go doneInl1 il+        e1 = maybeSubstTm "inlineBndrsCleanup_1" sM e+    in  (v,e1):go doneInl_1 il {-# SCC inlineBndrsCleanup #-}  -- | Used (transitively) by 'inlineCleanup' inline to-inline let-binders into -- the other to-inline let-binders. reduceBindersCleanup-  :: InScopeSet+  :: HasCallStack+  => InScopeSet   -- ^ Current InScopeSet   -> VarEnv ((Id,Term),VarEnv Int)   -- ^ Original let-binders with their free variables (+ #occurrences)@@ -2528,11 +2636,19 @@   -- ^ Ignore, artifact of 'foldlWithUniqueVarEnv'   -> (Maybe Subst,VarEnv Int,VarEnv ((Id,Term),VarEnv Int,Mark))   -- ^ Same as the third argument-reduceBindersCleanup isN origInl (!substM,!substFVs,!doneInl) u _ = case lookupVarEnvDirectly u doneInl of+reduceBindersCleanup isN origInl (!substM,!substFVs,!doneInl) u _ =+  case lookupVarEnvDirectly u doneInl of     Nothing -> case lookupVarEnvDirectly u origInl of       Nothing ->         -- let-binding not found, cannot extend the substitution-        (substM,substFVs,doneInl)+        if elemUniqInScopeSet u isN then+          (substM,substFVs,doneInl)+        else+          error [I.i|+            Internal error: 'reduceBindersCleanup' encountered a variable+            reference that was neither in 'doneInl', 'origInl', or in the+            transformation's in scope set. Unique was: '#{u}'.+          |]       Just ((v,e),eFVs) ->         -- Simplify the transitive dependencies         let (sM,substFVsE,doneInl1) =@@ -2556,9 +2672,7 @@                 , extendVarEnv v ((v,e),eFVs,Temp) doneInl)                 eFVs -            e1 = case sM of-                   Nothing -> e-                   Just s  -> substTm "reduceBindersCleanup" s e+            e1 = maybeSubstTm "reduceBindersCleanup" sM e         in  if v `elemVarEnv` substFVsE then               -- We cannot inline recursive let-bindings, so we do not extend               -- the substitution environment.@@ -2577,7 +2691,7 @@               -- this process when we encounter it again.               , extendVarEnv v ((v,e1),substFVsE,Done) doneInl1               )-    -- It's already been process, just extend the substitution environment+    -- It's already been processed, just extend the substitution environment     Just ((v,e),eFVs,Done) ->       ( Just (extendIdSubst (Maybe.fromMaybe (mkSubst isN) substM) v e)       , unionVarEnv eFVs substFVs@@ -2609,10 +2723,14 @@                    emptyVarEnv (`unitVarEnv` (1 :: Int))                    body   (is2,binds1) <- second concat <$> List.mapAccumLM go is1 binds+  e1WorkFree <-+    case binds1 of+      [(_,e1)] -> isWorkFree e1+      _ -> pure (error "flattenLet: unreachable")   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-    [(id1,e1)] | Just occ <- lookupVarEnv id1 bodyOccs, isWorkFree e1 || occ < 2 ->+    [(id1,e1)] | Just occ <- lookupVarEnv id1 bodyOccs, e1WorkFree || occ < 2 ->       if id1 `localIdOccursIn` e1          -- Except when the binder is recursive!          then return (Letrec binds1 body)@@ -2642,12 +2760,16 @@                        emptyVarEnv (`unitVarEnv` (1 :: Int))                        body2           (srcTicks,nmTicks) = partitionTicks ticks+      e2WorkFree <-+        case binds2 of+          [(_,e2)] -> isWorkFree e2+          _ -> pure (error "flattenLet: unreachable")       -- Distribute the name ticks of the let-expression over all the bindings       (isN1,) . map (second (`mkTicks` nmTicks)) <$> case binds2 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-        [(id2,e2)] | Just occ <- lookupVarEnv id2 bodyOccs, isWorkFree e2 || occ < 2 ->+        [(id2,e2)] | Just occ <- lookupVarEnv id2 bodyOccs, e2WorkFree || occ < 2 ->           if id2 `localIdOccursIn` e2              -- Except when the binder is recursive!              then changed ([(id2,e2),(id1, body2)])

@@ -20,6 +20,7 @@  , isRecursiveBndr  , isClosed  , callGraph+ , collectCallGraphUniques  , classifyFunction  , isCheapFunction  , isNonRecursiveGlobalVar@@ -41,6 +42,7 @@ import qualified Data.List.Extra         as List import qualified Data.Map                as Map import qualified Data.HashMap.Strict     as HashMapS+import qualified Data.HashSet            as HashSet import           Data.Text               (Text) import qualified Data.Text as Text @@ -343,6 +345,13 @@ -- | A call graph counts the number of occurrences that a functions 'g' is used -- in 'f'. type CallGraph = VarEnv (VarEnv Word)++-- | Collect all binders mentioned in CallGraph into a HashSet+collectCallGraphUniques :: CallGraph -> HashSet.HashSet Unique+collectCallGraphUniques cg = HashSet.fromList (us0 ++ us1)+ where+  us0 = keysUniqMap cg+  us1 = concatMap keysUniqMap (eltsUniqMap cg)  -- | Create a call graph for a set of global binders, given a root callGraph

@@ -1,10 +1,37 @@+{-# LANGUAGE QuasiQuotes #-}+ module Clash.Pretty where  import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Render.String+import Data.Maybe (fromMaybe)+import qualified System.Console.Terminal.Size as Terminal+import System.Environment (lookupEnv)+import System.IO.Unsafe (unsafePerformIO)+import Text.Read (readMaybe)+import qualified Clash.Util.Interpolate as I+import GHC.Stack (HasCallStack) +unsafeLookupEnvWord :: HasCallStack => String -> Word -> Word+unsafeLookupEnvWord key dflt =+  case unsafePerformIO (lookupEnv key) of+    Nothing -> dflt+    Just w -> flip fromMaybe (readMaybe w) $ error [I.i|+      'unsafeLookupEnvWord' tried to lookup #{key} in the environment. It found+      it, but couldn't interpret it to as a Word (positive Int). Found:++        #{w}+    |]++defaultPprWidth :: Int+defaultPprWidth =+  let dflt = max 80 (maybe 80 Terminal.width (unsafePerformIO Terminal.size)) in+  fromIntegral (unsafeLookupEnvWord "CLASH_PPR_WIDTH" dflt)+ showDoc :: Doc ann -> String-showDoc = renderString . layoutPretty (LayoutOptions (AvailablePerLine 80 0.6))+showDoc =+  let layoutOpts = LayoutOptions (AvailablePerLine defaultPprWidth 0.6) in+  renderString . layoutPretty layoutOpts  removeAnnotations :: Doc ann -> Doc () removeAnnotations = reAnnotate $ const ()

@@ -0,0 +1,804 @@+{-|+  Copyright   :  (C) 2019, Myrtle Software Ltd.+                     2020, QBayLogic B.V.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++This module contains a mini dsl for creating haskell blackbox+instantiations.+-}++{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms   #-}+{-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE TypeApplications  #-}+{-# LANGUAGE ViewPatterns      #-}++module Clash.Primitives.DSL+  (+  -- * Annotations+    blackBoxHaskell++  -- * declarations+  , BlockState (..)+  , TExpr+  , declaration+  , declarationReturn+  , instDecl+  , instHO+  , viaAnnotatedSignal++  -- ** Literals+  , bvLit+  , LitHDL (..)+  , pattern High+  , pattern Low+  , tuple+  , vec++  -- ** Extraction+  , tInputs+  , tResult+  , getStr+  , getBool+  , exprToInteger+  , tExprToInteger+  , untuple+  , unvec++  -- ** Conversion+  , toBV+  , fromBV+  , boolToBit+  , boolFromBit+  , boolFromBitVector+  , unsignedFromBitVector+  , boolFromBits++  -- ** Operations+  , andExpr+  , notExpr+  , pureToBV+  , pureToBVResized+  , open++  -- ** Utilities+  , toIdentifier+  , tySize+  , clog2+  ) where++import           Clash.Util                      (HasCallStack, clogBase)+import           Control.Lens                    hiding (Indexed, assign)+import           Control.Monad.State+import           Data.IntMap                     (IntMap)+import qualified Data.IntMap                     as IntMap+import           Data.List                       (intersperse)+import           Data.Maybe                      (fromMaybe)+import           Data.Semigroup                  hiding (Product)+import           Data.Semigroup.Monad+import           Data.String+import           Data.Text                       (Text)+import qualified Data.Text                       as Text+import qualified Data.Text.Lazy                  as LText+import           Data.Text.Prettyprint.Doc.Extra+import           TextShow                        (showt)++import           Clash.Annotations.Primitive     (HDL (..), Primitive (..))+import           Clash.Backend                   hiding (fromBV, toBV)+import           Clash.Backend.VHDL              (VHDLState)+import           Clash.Core.Var                  (Attr')+import           Clash.Netlist.BlackBox.Util     (exprToString, renderElem)+import           Clash.Netlist.BlackBox.Types+  (BlackBoxTemplate, Element(Component, Text), Decl(..))+import           Clash.Netlist.Id+import           Clash.Netlist.Types             hiding (Component, toBit)+import           Clash.Netlist.Util              hiding (mkUniqueIdentifier)+import qualified Data.String.Interpolate         as I+import           Data.String.Interpolate.Util    (unindent)+import           Language.Haskell.TH             (Name)+import           Prelude++-- | Create a blackBoxHaskell primitive. To be used as part of an annotation:+--+-- @+-- {-# ANN myFunction (blackBoxHaskell [1,2,3] VHDL 'myFunction 'myBBF) #-}+-- @+blackBoxHaskell+  :: [Int]+  -- ^ Ignored arguments+  -> HDL+  -- ^ hdl the blackbox is for+  -> Name+  -- ^ blackbox name+  -> Name+  -- ^ template function name+  -> Primitive+blackBoxHaskell (show -> ign) hdl bb tf =+  InlinePrimitive [hdl] $ unindent [I.i|+  [ { "BlackBoxHaskell" :+       { "name" : "#{bb}"+       , "templateFunction" : "#{tf}"+       , "ignoredArguments" : #{ign}+       }+    }+  ]+|]++-- | The state of a block. Contains a list of declarations and a the+--   backend state.+data BlockState backend = BlockState+  { _bsDeclarations :: [Declaration]+    -- ^ Declarations store+  , _bsHigherOrderCalls :: IntMap Int+    -- ^ Tracks how many times a higher order function has been instantiated.+    -- Needed to fill in the second field of "Clash.Netlist.BlackBox.Types.Decl"+  , _bsBackend :: backend+    -- ^ Backend state+  }+makeLenses ''BlockState++-- | A typed expression.+data TExpr = TExpr+  { ety :: HWType+  , eex :: Expr+  } deriving Show+makeLenses ''TExpr++-- | Run a block declaration. Assign the result of the block builder to the+-- result variable in the given blackbox context.+declarationReturn+  :: Backend backend+  => BlackBoxContext+  -> Text.Text+  -- ^ block name+  -> State (BlockState backend) TExpr+  -- ^ block builder yielding an expression that should be assigned to the+  -- result variable in the blackbox context+  -> State backend Doc+  -- ^ pretty printed block+declarationReturn bbCtx blockName blockBuilder =+  declaration blockName $ do+    res <- blockBuilder+    let (Identifier resultNm Nothing, _) = bbResult bbCtx+    addDeclaration (Assignment resultNm (eex res))+    pure ()++-- | Run a block declaration.+declaration+  :: Backend backend+  => Text.Text+  -- ^ block name+  -> State (BlockState backend) ()+  -- ^ block builder+  -> State backend Doc+  -- ^ pretty printed block+declaration blockName s = do+  backend0 <- get+  let initState = BlockState [] IntMap.empty backend0+      BlockState decs _hoCalls backend1 = execState s initState+  put backend1+  blockNameUnique <- mkUniqueIdentifier Basic blockName+  getMon $ blockDecl blockNameUnique (reverse decs)++-- | Add a declaration to the state.+addDeclaration :: Declaration -> State (BlockState backend) ()+addDeclaration dec = bsDeclarations %= cons dec++-- | Create a new basic unique name using the given Text as a template.+newName :: Backend backend => Text -> State (BlockState backend) Identifier+newName nm = zoom bsBackend $ mkUniqueIdentifier Basic nm++-- | Declare a new signal with the given name and type.+declare'+  :: Backend backend+  => Identifier+  -- ^ Name hint+  -> WireOrReg+  -- ^ Should signal be declared as a wire or a reg+  -> HWType+  -- ^ Type of new signal+  -> State (BlockState backend) Identifier+  -- ^ Expression pointing the the new signal+declare' decName wireOrReg ty = do+  uniqueName <- newName decName+  addDeclaration (NetDecl' Nothing wireOrReg uniqueName (Right ty) Nothing)+  pure uniqueName++-- | Declare a new signal with the given name and type.+declare+  :: Backend backend+  => Identifier+  -- ^ Name hint+  -> WireOrReg+  -- ^ Should signal be declared as a wire or a reg+  -> HWType+  -- ^ Type of new signal+  -> State (BlockState backend) TExpr+  -- ^ Expression pointing the the new signal+declare decName wireOrReg ty = do+  uniqueName <- declare' decName wireOrReg ty+  pure (TExpr ty (Identifier uniqueName Nothing))++-- | Assign an expression to an identifier, returns the new typed+--   identifier expression.+assign+  :: Backend backend+  => Text+  -- ^ Name hint for assignment+  -> TExpr+  -- ^ expression to be assigned to+  -> State (BlockState backend) TExpr+  -- ^ the identifier of the expression that actually got assigned+assign aName (TExpr ty aExpr) = do+  texp@(~(TExpr _ (Identifier uniqueName Nothing))) <- declare aName Wire ty+  addDeclaration (Assignment uniqueName aExpr)+  pure texp++-- | Extract the elements of a vector expression and return expressions+-- to them. If given expression is not an identifier, an intermediate variable+-- will be used to assign the given expression to which is subsequently indexed.+unvec+  :: Backend backend+  => Identifier+  -- ^ Name hint for intermediate signal+  -> TExpr+  -- ^ Vector expression+  -> State (BlockState backend) [TExpr]+  -- ^ Vector elements+unvec vName v@(ety -> Vector vSize eType) = do+  ~(TExpr _ (Identifier vUniqueName Nothing)) <- toIdentifier vName v+  let vIndex i = Identifier vUniqueName (Just (Indexed (ety v, 10, i)))+  pure (map (TExpr eType . vIndex) [0..vSize-1])+unvec _ e = error $ "unvec: cannot be called on non-vector: " <> show (ety e)++-- | Extract the elements of a tuple expression and return expressions+--   to them. These new expressions are given unique names and get+--   declared the block scope.+untuple+  :: (HasCallStack, Backend backend)+  => TExpr+  -- ^ Tuple expression+  -> [Identifier]+  -- ^ Name hints for element assignments+  -> State (BlockState backend) [TExpr]+untuple (TExpr ty@(Product _ _ tys) (Identifier resName _)) vals = do+  newNames <- zipWithM (flip declare Wire) vals tys+  addDeclaration $ Assignment resName $ DataCon ty (DC (ty, 0)) (fmap eex newNames)+  pure newNames+untuple e i = error $ "untuple: " <> show e <> " " <> show i++-- | The high literal bit.+pattern High :: TExpr+pattern High <- TExpr Bit (Literal _ (BitLit H))+  where High = TExpr Bit (Literal (Just (Bit,1)) (BitLit H))++-- | The low literal bit.+pattern Low :: TExpr+pattern Low <- TExpr Bit (Literal _ (BitLit L))+  where Low = TExpr Bit (Literal (Just (Bit,1)) (BitLit L))++-- | The true literal bool.+pattern T :: TExpr+pattern T <- TExpr Bool (Literal _ (BoolLit True))+  where T = TExpr Bool (Literal (Just (Bool,1)) (BoolLit True))++-- | The false literal bool.+pattern F :: TExpr+pattern F <- TExpr Bool (Literal _ (BoolLit False))+  where F = TExpr Bool (Literal (Just (Bool,1)) (BoolLit False))++-- | Construct a fully defined BitVector literal+bvLit+  :: Int+  -- ^ BitVector size+  -> Integer+  -- ^ Literal+  -> TExpr+bvLit sz n =+  TExpr+    (BitVector sz)+    (Literal (Just (BitVector sz, sz)) (BitVecLit 0 n))++-- | Convert a bool to a bit.+boolToBit+  :: (HasCallStack, Backend backend)+  => Identifier+  -- ^ Name hint for intermediate signal+  -> TExpr+  -> State (BlockState backend) TExpr+boolToBit bitName = \case+  T -> pure High+  F -> pure Low+  TExpr Bool boolExpr -> do+    texp@(~(TExpr _ (Identifier uniqueBitName Nothing))) <- declare bitName Wire Bit+    addDeclaration $+      CondAssignment uniqueBitName Bit boolExpr Bool+        [ (Just (BoolLit True), Literal Nothing (BitLit H))+        , (Nothing            , Literal Nothing (BitLit L))+        ]+    pure texp+  tExpr -> error $ "boolToBit: Got \"" <> show tExpr <> "\" expected Bool"++-- | Use to create an output `Bool` from a `Bit`. The expression given+--   must be the identifier of the bool you wish to get assigned.+--   Returns a reference to a declared `Bit` that should get assigned+--   by something (usually the output port of an entity).+boolFromBit+  :: Backend backend+  => Identifier+  -- ^ Name hint for intermediate signal+  -> TExpr+  -> State (BlockState backend) TExpr+boolFromBit = outputCoerce Bit Bool (<> " = '1'")++-- | Used to create an output `Bool` from a `BitVector` of given size.+-- Works in a similar way to `boolFromBit` above.+boolFromBitVector+  :: Backend backend+  => Size+  -> Identifier+  -- ^ Name hint for intermediate signal+  -> TExpr+  -> State (BlockState backend) TExpr+boolFromBitVector n =+  outputCoerce (BitVector n) Bool (\i -> "unsigned(" <> i <> ") > 0")++-- | Used to create an output `Unsigned` from a `BitVector` of given+-- size. Works in a similar way to `boolFromBit` above.+--+-- TODO: Implement for (System)Verilog+unsignedFromBitVector+  :: Size+  -> Identifier+  -- ^ Name hint for intermediate signal+  -> TExpr+  -> State (BlockState VHDLState) TExpr+unsignedFromBitVector n =+  outputCoerce (BitVector n) (Unsigned n) (\i -> "unsigned(" <> i <> ")")++-- | Used to create an output `Bool` from a number of `Bit`s, using+-- conjunction. Similarly to `untuple`, it returns a list of+-- references to declared values (the inputs to the function) which+-- should get assigned by something---usually output ports of an+-- entity.+--+-- TODO: Implement for (System)Verilog+boolFromBits+  :: [Identifier]+  -> TExpr+  -> State (BlockState VHDLState) [TExpr]+boolFromBits inNames = outputFn (map (const Bit) inNames) Bool+  (foldl (<>) "" . intersperse " and " . map (\i -> "(" <> i <> " = '1')")) inNames++-- | Used to create an output value with an arbitrary VHDL coercion.+-- The expression given should be the identifier of the output value+-- you wish to get assigned. Returns a reference to a declared value+-- of the input type that should get assigned by something (usually+-- the output port of an entity).+outputCoerce+  :: (HasCallStack, Backend backend)+  => HWType+  -> HWType+  -> (Identifier -> Identifier)+  -> Identifier+  -> TExpr+  -> State (BlockState backend) TExpr+outputCoerce fromType toType exprStringFn inName expr_+  | TExpr outType (Identifier outName Nothing) <- expr_+  , outType == toType = do+      inName' <- newName inName+      let exprIdent = Identifier (exprStringFn inName') Nothing+      addDeclaration (NetDecl Nothing inName' fromType)+      addDeclaration (Assignment outName exprIdent)+      pure (TExpr fromType (Identifier inName' Nothing))+outputCoerce _ toType _ _ texpr = error $ "outputCoerce: the expression " <> show texpr+                                  <> " must be an Identifier with type " <> show toType++-- | Used to create an output value that is an arbitrary function (as+-- VHDL) of existing values. The expression given should be the+-- identifier of the output value you wish to get assigned. Similarly+-- to `untuple`, it returns a list of references to declared values+-- (the inputs to the function) which should get assigned by+-- something---usually output ports of an entity.+outputFn+  :: (HasCallStack, Backend backend)+  => [HWType]+  -> HWType+  -> ([Identifier] -> Identifier)+  -> [Identifier]+  -> TExpr+  -> State (BlockState backend) [TExpr]+outputFn fromTypes toType exprFn inNames (TExpr outType (Identifier outName Nothing))+  | outType == toType = do+      inNames' <- mapM newName inNames+      let exprIdent = Identifier (exprFn inNames') Nothing+      sequenceOf_ each [ addDeclaration (NetDecl Nothing nm t)+                       | (nm,t) <- zip inNames' fromTypes ]+      addDeclaration (Assignment outName exprIdent)+      pure [ TExpr t (Identifier nm Nothing)+           | (nm,t) <- zip inNames' fromTypes ]+outputFn _ outType _ _ texpr =+  error $ "outputFn: the expression " <> show texpr+  <> " must be an Identifier with type " <> show outType++-- | Create a vector of 'TExpr's+vec+  :: (HasCallStack, Backend backend)+  => [TExpr]+  -- ^ Elements of vector+  -> State (BlockState backend) TExpr+  -- ^ Vector elements+vec els@(el:_)+  | all (\e -> ety e == ety el) els+  = pure (TExpr (Vector (length els) (ety el)) theVec)+  | otherwise+  = error $ "vec: elements not of same type: " ++ show els+ where+  theVec = mkVectorChain (length els) (ety el) (map eex els)+vec [] = error "vec: can't be used on empty lists"++-- | Create an n-tuple of 'TExpr'+tuple :: [TExpr] -> TExpr+tuple [] = error $ "nTuple: Cannot create empty tuple"+tuple [_] =+  -- If we don't put this in: tuple . untuple /= id+  error $ "nTuple: Cannot create 1-tuple"+tuple els =+  TExpr tupTy (DataCon tupTy (DC (tupTy,0)) (map eex els))+ where+  commas = Text.replicate (length els - 1) ","+  tupTy = Product ("GHC.Tuple.(" <> commas <> ")") Nothing (map ety els)++-- | Try to get the literal string value of an expression.+getStr :: TExpr -> Maybe String+getStr (TExpr _ e) = exprToString e++-- | Try to get the literal bool value of an expression.+getBool :: TExpr -> Maybe Bool+getBool (TExpr _ (Literal _ (BoolLit b))) = Just b+getBool _ = Nothing++-- | Try to get the literal nat value of an expression.+tExprToInteger :: TExpr -> Maybe Integer+tExprToInteger (TExpr _ e) = exprToInteger e++exprToInteger :: Expr -> Maybe Integer+exprToInteger (DataCon _ _ [n]) = exprToInteger n+exprToInteger (Literal _ (NumLit n)) = Just n+exprToInteger _ = Nothing++-- | Assign an input bitvector to an expression. Declares a new+--   bitvector if the expression is not already a bitvector.+toBV+  :: Backend backend+  => Identifier+  -- ^ BitVector name+  -> TExpr+  -- ^ expression+  -> State (BlockState backend) TExpr+  -- ^ BitVector expression+toBV bvName a = case a of+  TExpr BitVector{} _ -> pure a+  TExpr aTy aExpr     -> assign bvName $+    TExpr (BitVector (typeSize aTy)) (ConvBV Nothing aTy True aExpr)++-- | Assign an output bitvector to an expression. Declares a new+--   bitvector if the expression is not already a bitvector.+fromBV+  :: (HasCallStack, Backend backend)+  => Identifier+  -- ^ BitVector name+  -> TExpr+  -- ^ expression+  -> State (BlockState backend) TExpr+  -- ^ bv expression+fromBV _ a@(TExpr BitVector{} _) = pure a+fromBV bvName (TExpr aTy (Identifier aName Nothing)) = do+  bvName' <- newName bvName+  let bvExpr = ConvBV Nothing aTy False (Identifier bvName' Nothing)+      bvTy   = BitVector (typeSize aTy)+  addDeclaration (NetDecl Nothing bvName' bvTy)+  addDeclaration (Assignment aName bvExpr)+  pure (TExpr bvTy (Identifier bvName' Nothing))+fromBV _ texpr = error $+  "fromBV: the expression " <> show texpr <> "must be an Indentifier"++clog2 :: Num i => Integer -> i+clog2 = fromIntegral . fromMaybe 0 . clogBase 2++tySize :: Num i => HWType -> i+tySize = fromIntegral . typeSize++-- | A literal that can be used for hdl attributes. It has a `Num` and+--   `IsString` instances for convenience.+data LitHDL+  = B Bool+  | S String+  | I Integer+  deriving Show++instance Num LitHDL where+  (+) = undefined+  (*) = undefined+  abs = undefined+  signum = undefined+  negate = undefined+  fromInteger = I++instance IsString LitHDL where+  fromString = S++-- | Instantiate/call a higher-order function.+instHO+  :: Backend backend+  => BlackBoxContext+  -- ^ BlackBoxContext, used for rendering higher-order function and error+  -- reporting+  -> Int+  -- ^ Position of HO-argument. For example:+  --+  --   fold :: forall n a . (a -> a -> a) -> Vec (n + 1) a -> a+  --+  -- would have its HO-argument at position 0, while+  --+  --  iterateI :: forall n a. KnownNat n => (a -> a) -> a -> Vec n a+  --+  -- would have it at position 1.+  -> (HWType, BlackBoxTemplate)+  -- ^ Result type of HO function+  -> [(TExpr, BlackBoxTemplate)]+  -- ^ Arguments and their types+  -> State (BlockState backend) TExpr+  -- ^ Result of the function+instHO bbCtx fPos (resTy, bbResTy) argsWithTypes = do+  let (args0, argTypes) = unzip argsWithTypes+  fSubPos <- fromMaybe 0 . IntMap.lookup fPos <$> use bsHigherOrderCalls+  bsHigherOrderCalls %= IntMap.insert fPos (succ fSubPos)++  -- Create argument identifiers, example: fold_ho3_0_arg0+  let+    ctxName = last (Text.split (=='.') (bbName bbCtx))+    baseArgName = ctxName <> "_" <> "ho" <> showt fPos <> "_" <> showt fSubPos+    argName n = baseArgName <> "_arg" <> showt n+  args1 <- zipWithM (\argN -> toIdentifier' (argName argN)) [(0 :: Int)..] args0+  let+    args2 = map (pure . Text . LText.fromStrict) args1+    args3 = zip args2 argTypes++  -- Create result identifier+  -- See https://github.com/clash-lang/clash-compiler/issues/919 for info on+  -- logic of 'resWireOrReg'+    resWireOrReg =+      case IntMap.lookup fPos (bbFunctions bbCtx) of+        Just ((_,rw,_,_,_,_):_) -> rw+        _ -> error "internal error"+  resName <- declare' (ctxName <> "_" <> "ho" <> showt fPos <> "_"+                               <> showt fSubPos <> "_res") resWireOrReg resTy+  let res = ([Text (LText.fromStrict resName)], bbResTy)++  -- Render HO argument to plain text+  let component = Component (Decl fPos fSubPos (res:args3))+  rendered0 <-+    zoom bsBackend (string =<< (renderElem bbCtx component <*> pure 0))++  let+    layout = LayoutOptions (AvailablePerLine 120 0.4)+    rendered1 = renderLazy (layoutPretty layout rendered0)++  addDeclaration $+    BlackBoxD+      ("__INST_" <> bbName bbCtx <> "_BB_INTERNAL__") [] [] []+      (BBTemplate [Text rendered1])+      (emptyBBContext ("__INST_" <> bbName bbCtx <> "_BB_INTERNAL__"))++  pure (TExpr resTy (Identifier resName Nothing))++-- | Instantiate a component/entity in a block state.+instDecl+  :: Backend backend+  => EntityOrComponent+  -- ^ Type of instantiation+  -> Identifier+  -- ^ component/entity name+  -> Identifier+  -- ^ instantiation label+  -> [(Text, LitHDL)]+  -- ^ attributes+  -> [(Text, TExpr)]+  -- ^ in ports+  -> [(Text, TExpr)]+  -- ^ out ports+  -> State (BlockState backend) ()+instDecl entOrComp compName instLbl attrs inPorts outPorts = do++  inPorts' <- mapM (mkPort In) inPorts+  outPorts' <- mapM (mkPort Out) outPorts++  addDeclaration $ InstDecl entOrComp Nothing compName instLbl (mkAttrs attrs) (inPorts' ++ outPorts')+    where+    mkPort inOrOut (nm, pExpr) = do+      TExpr ty pExpr' <- toIdentifier (nm <> "_port")  pExpr+      pure (Identifier nm Nothing, inOrOut, ty, pExpr')++    -- Convert a list of name attributes to the form clash wants+    mkAttrs :: [(Text.Text, LitHDL)] -> [(Expr, HWType, Expr)]+    mkAttrs = map (\(s, ty) -> (Identifier s Nothing, hdlTy ty, litExpr ty))++    litExpr :: LitHDL -> Expr+    litExpr (B b) = Literal Nothing (BoolLit b)+    litExpr (S s) = Literal Nothing (StringLit s)+    litExpr (I i) = Literal Nothing (NumLit i)++    hdlTy :: LitHDL -> HWType+    hdlTy = \case+      B{} -> Bool+      S{} -> String+      I{} -> Integer++-- | Wires the two given `TExpr`s together using a newly declared+-- signal with (exactly) the given name `sigNm`. The new signal has an+-- annotated type, using the given attributes.+viaAnnotatedSignal+  :: (HasCallStack, Backend backend)+  => Text+  -- ^ Name given to signal+  -> TExpr+  -- ^ expression the signal is assigned to+  -> TExpr+  -- ^ expression (must be identifier) to which the signal is assigned+  -> [Attr']+  -- ^ the attributes to annotate the signal with+  -> State (BlockState backend) ()+viaAnnotatedSignal sigNm (TExpr fromTy fromExpr) (TExpr toTy (Identifier outNm Nothing)) attrs+  | fromTy == toTy = do+      addDeclaration (NetDecl Nothing sigNm (Annotated attrs fromTy))+      addDeclaration (Assignment sigNm fromExpr)+      addDeclaration (Assignment outNm (Identifier sigNm Nothing))+viaAnnotatedSignal _ inTExpr outTExpr@(TExpr _ (Identifier _ _)) _ =+  error $ "viaAnnotatedSignal: The in and out expressions \"" <> show inTExpr <>+  "\" and \"" <> show outTExpr <> "\" have non-matching types."+viaAnnotatedSignal _ _ outTExpr _ =+  error $ "viaAnnotatedSignal: The out expression \"" <> show outTExpr <>+  "\" must be an Identifier."++-- | The TExp inputs from a blackbox context.+tInputs :: BlackBoxContext -> [(TExpr, HWType)]+tInputs = map (\(x, t, _) -> (TExpr t x, t)) . bbInputs++-- | The TExp result of a blackbox context.+tResult :: BlackBoxContext -> TExpr+tResult = (\(x,t) -> TExpr t x) . bbResult++-- | Get an identifier to an expression, creating a new assignment if+--   necessary.+toIdentifier'+  :: Backend backend+  => Identifier+  -- ^ desired new identifier name, will be made unique+  -> TExpr+  -- ^ expression to get identifier of+  -> State (BlockState backend) Identifier+  -- ^ identifier to expression+toIdentifier' _ (TExpr _ (Identifier aExpr Nothing)) = pure aExpr+toIdentifier' nm texp = do+  ~(TExpr _ (Identifier nm' Nothing)) <- assign nm texp+  pure nm'++-- | Get an identifier to an expression, creating a new assignment if+--   necessary.+toIdentifier+  :: Backend backend+  => Identifier+  -- ^ desired new identifier name, will be made unique+  -> TExpr+  -- ^ expression to get identifier of+  -> State (BlockState backend) TExpr+  -- ^ identifier to expression+toIdentifier nm texp = do+  id' <- toIdentifier' nm texp+  pure (TExpr (ety texp) (Identifier id' Nothing))++-- | And together @(&&)@ two expressions, assigning it to a new identifier.+andExpr+  :: Backend backend+  => Identifier+  -- ^ name hint+  -> TExpr+  -- ^ a+  -> TExpr+  -- ^ a+  -> State (BlockState backend) TExpr+  -- ^ a && b+andExpr _ T bExpr = pure bExpr+andExpr _ F _     = pure F+andExpr _ aExpr T = pure aExpr+andExpr _ _ F     = pure F+andExpr nm a b = do+  aIdent <- toIdentifier' (nm <> "_a") a+  bIdent <- toIdentifier' (nm <> "_b") b+  -- This is somewhat hacky and relies on the fact that clash doesn't+  -- postprocess the text in Identifier. The alternative is to run+  -- this as a fully fledged @BlackBoxE@ but that involves a lot of+  -- faffing. It should be reasonably safe because we assign each side+  -- to an identifier if it isn't already.+  andTxt <-+    uses bsBackend hdlKind <&> \case+      VHDL          -> aIdent <> " and " <> bIdent+      Verilog       -> aIdent <> " && " <> bIdent+      SystemVerilog -> aIdent <> " && " <> bIdent+  assign nm $ TExpr Bool (Identifier andTxt Nothing)++-- | Negate @(not)@ an expression, assigning it to a new identifier.+notExpr+  :: Backend backend+  => Identifier+  -- ^ name hint+  -> TExpr+  -- ^ a+  -> State (BlockState backend) TExpr+  -- ^ not a+notExpr _ T = pure F+notExpr _ F = pure T+notExpr nm aExpr = do+  aIdent <- toIdentifier' (nm <> "_a") aExpr+  -- See disclaimer in `andExpr` above.+  notTxt <- uses bsBackend hdlKind <&> \case+    VHDL          -> "not " <> aIdent+    Verilog       -> "! " <> aIdent+    SystemVerilog -> "! " <> aIdent+  assign nm $ TExpr Bit (Identifier notTxt Nothing)++-- | Creates a BV that produces the following vhdl:+--+-- @+--    (0 to n => ARG)+-- @+--+-- TODO: Implement for (System)Verilog+pureToBV+  :: Identifier+  -- ^ name hint+  -> Int+  -- ^ Size (n)+  -> TExpr+  -- ^ ARG+  -> State (BlockState VHDLState) TExpr+  -- ^ (0 to n => ARG)+pureToBV nm n arg = do+  arg' <- toIdentifier' nm arg+  -- This is very hard coded and hacky+  let text = "(0 to " <> showt n <> " => " <> arg' <> ")"+  assign nm $ TExpr (BitVector (n+1)) (Identifier text Nothing)++-- | Creates a BV that produces the following vhdl:+--+-- @+--    std_logic_vector(resize(ARG, Size))+-- @+--+-- TODO: Implement for (System)Verilog+pureToBVResized+  :: Identifier+  -- ^ name hint+  -> Int+  -- ^ Size (n)+  -> TExpr+  -- ^ ARG+  -> State (BlockState VHDLState) TExpr+  -- ^ std_logic_vector(resize(ARG, Size))+pureToBVResized nm n arg = do+  arg' <- toIdentifier' nm arg+  -- This is very hard coded and hacky+  let text = "std_logic_vector(resize(" <> arg' <> ", " <> showt n <> "))"+  assign nm $ TExpr (BitVector n) (Identifier text Nothing)++-- | Allows assignment of a port to be "open"+open+  :: Backend backend+  => HWType+  -> State (BlockState backend) TExpr+open hwType = pure $ TExpr hwType (Identifier "open" Nothing)

@@ -1,3 +1,10 @@+{-|+  Copyright   :  (C) 2020 QBayLogic+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++  Blackbox implementations for functions in "Clash.Sized.Vector".+-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}@@ -9,6 +16,8 @@ import qualified Control.Lens                       as Lens import           Data.Either                        (rights) import qualified Data.IntMap                        as IntMap+import           Data.List.Extra                    (iterateNM)+import           Data.Maybe                         (fromMaybe) import           Data.Semigroup.Monad               (getMon) import qualified Data.Text                          as Text import qualified Data.Text.Lazy                     as LText@@ -38,9 +47,52 @@    bbFunctions) import           Clash.Netlist.Id                   (IdType(Basic)) import           Clash.Netlist.Util                 (typeSize)+import qualified Clash.Primitives.DSL               as Prim+import           Clash.Primitives.DSL+  (declarationReturn, instHO, tInputs, tExprToInteger)  import           Clash.Util                         (HasCallStack, curLoc) +-- | Blackbox function for 'Clash.Sized.Vector.iterateI'+iterateBBF :: HasCallStack => BlackBoxFunction+iterateBBF _isD _primName args _resTy = do+  tcm <- Lens.use tcCache+  pure (Right (meta tcm, bb))+ where+  bb = BBFunction "Clash.Primitives.Sized.Vector.iterateBBF" 0 iterateTF+  vecLength tcm =+    case coreView tcm (head (rights args)) of+      (LitTy (NumTy 0)) -> error "Unexpected empty vector in 'iterateBBF'"+      (LitTy (NumTy n)) -> fromInteger (n - 1)+      vl -> error $ "Unexpected vector length: " ++ show vl+  meta tcm = emptyBlackBoxMeta {+      bbKind=TDecl+    , bbFunctionPlurality=[(1, vecLength tcm)]+    }++-- | Type signature of function we're generating netlist for:+--+--   iterateI :: KnownNat n => (a -> a) -> a -> Vec n a+--+iterateTF :: TemplateFunction+iterateTF = TemplateFunction [] (const True) iterateTF'++iterateTF'+  :: forall s+   . (HasCallStack, Backend s)+  => BlackBoxContext+  -> State s Doc+iterateTF' bbCtx+  | [ (fromMaybe (error "n") . tExprToInteger -> n, _)+    , _hoFunction+    , (a, aType)+    ] <- tInputs bbCtx+  , let aTemplateType = [TypElem (Typ (Just 2))]+  , let inst arg = instHO bbCtx 1 (aType, aTemplateType) [(arg, aTemplateType)]+  = declarationReturn bbCtx "iterateI" (Prim.vec =<< iterateNM (fromInteger n) inst a)+  | otherwise+  =  error $ "Unexpected number of arguments: " ++ show (length (bbInputs bbCtx))+ data FCall =   FCall     Identifier -- left@@ -58,6 +110,7 @@       let (d, r) = n `divMod` 2 in       1 + foldFunctionPlurality d + foldFunctionPlurality (d+r) +-- | Blackbox function for 'Clash.Sized.Vector.fold' foldBBF :: HasCallStack => BlackBoxFunction foldBBF _isD _primName args _resTy = do   tcm <- Lens.use tcCache

@@ -40,7 +40,7 @@ import Clash.Core.Type           (Type) import Clash.Core.TyCon          (TyConName, TyConMap) import Clash.Core.Var            (Id)-import Clash.Core.VarEnv         (InScopeSet, VarSet)+import Clash.Core.VarEnv         (InScopeSet, VarSet, VarEnv) import Clash.Driver.Types        (BindingMap, DebugLevel) import Clash.Netlist.Types       (FilteredHWType, HWMap) import Clash.Util@@ -77,6 +77,8 @@   -- ^ Used for 'Fresh'   , _globalHeap       :: PrimHeap   -- ^ Used as a heap for compile-time evaluation of primitives that live in I/O+  , _workFreeBinders  :: VarEnv Bool+  -- ^ Map telling whether a binder's definition is work-free   , _extra            :: !extra   -- ^ Additional state   }@@ -89,6 +91,11 @@   { _dbgLevel       :: DebugLevel   -- ^ Level at which we print debugging messages   , _dbgTransformations :: Set.Set String+  -- ^ See ClashOpts.dbgTransformations+  , _dbgTransformationsFrom :: Int+  -- ^ See ClashOpts.opt_dbgTransformationsFrom+  , _dbgTransformationsLimit :: Int+  -- ^ See ClashOpts.opt_dbgTransformationsLimit   , _aggressiveXOpt :: Bool   -- ^ Transformations to print debugging info for   , _typeTranslator :: CustomReprs

@@ -11,6 +11,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-}@@ -19,6 +20,7 @@  module Clash.Rewrite.Util where +import           Control.Monad.Extra         (andM, eitherM) import           Control.Concurrent.Supply   (splitSupply) import           Control.DeepSeq import           Control.Exception           (throw)@@ -36,9 +38,12 @@ import           Data.Coerce                 (coerce) import           Data.Functor.Const          (Const (..)) import           Data.List                   (group, partition, sort)+import qualified Data.List                   as List+import qualified Data.List.Extra             as List import           Data.List.Extra             (allM, partitionM) import qualified Data.Map                    as Map-import           Data.Maybe                  (catMaybes,isJust,mapMaybe)+import           Data.Maybe+  (catMaybes, isJust, mapMaybe, fromMaybe) import qualified Data.Monoid                 as Monoid import qualified Data.Set                    as Set import qualified Data.Set.Lens               as Lens@@ -61,7 +66,7 @@ import           Clash.Core.Evaluator.Types  (PureHeap) import           Clash.Core.FreeVars   (freeLocalVars, hasLocalFreeVars, localIdDoesNotOccurIn, localIdOccursIn,-   typeFreeVars, termFreeVars')+   typeFreeVars, termFreeVars', freeLocalIds, globalIdOccursIn) import           Clash.Core.Name import           Clash.Core.Pretty           (showPpr) import           Clash.Core.Subst@@ -80,8 +85,9 @@   (Id, IdScope (..), TyVar, Var (..), isLocalId, mkGlobalId, mkLocalId, mkTyVar) import           Clash.Core.VarEnv   (InScopeSet, VarEnv, elemVarSet, extendInScopeSetList, mkInScopeSet,-   uniqAway, uniqAway', mapVarEnv)-import           Clash.Debug (traceIf)+   uniqAway, uniqAway', mapVarEnv, eltsVarEnv, unitVarSet, emptyVarEnv,+   mkVarEnv, eltsVarSet, elemVarEnv, lookupVarEnv, extendVarEnv)+import           Clash.Debug import           Clash.Driver.Types   (DebugLevel (..), BindingMap, Binding(..)) import           Clash.Netlist.Util          (representableType)@@ -171,9 +177,16 @@     return () #endif +  dbgFrom <- Lens.view dbgTransformationsFrom+  dbgLimit <- Lens.view dbgTransformationsLimit+  let fromLimit =+        if (dbgFrom, dbgLimit) == (0, maxBound)+        then Nothing+        else Just (dbgFrom, dbgLimit)+   if lvl == DebugNone     then return expr2-    else applyDebug lvl dbgTranss s expr0 hasChanged expr2+    else applyDebug lvl dbgTranss fromLimit s expr0 hasChanged expr2 {-# INLINE apply #-}  applyDebug@@ -181,6 +194,10 @@   -- ^ The current debugging level   -> Set.Set String   -- ^ Transformations to debug+  -> Maybe (Int, Int)+  -- ^ Only print debug information for transformations [n, n+limit]. See flag+  -- documentation of "-fclash-debug-transformations-from" and+  -- "-fclash-debug-transformations-limit"   -> String   -- ^ Name of the transformation   -> Term@@ -190,13 +207,24 @@   -> Term   -- ^ New expression   -> RewriteMonad extra Term-applyDebug lvl transformations name exprOld hasChanged exprNew+applyDebug lvl transformations fromLimit name exprOld hasChanged exprNew+  | Just (from, limit) <- fromLimit = do+    nTrans <- Lens.use transformCounter+    if | nTrans - from > limit ->+          error "-fclash-debug-transformations-limit exceeded"+       | nTrans > from ->+          applyDebug lvl transformations Nothing name exprOld hasChanged exprNew+       | otherwise ->+          pure exprNew++applyDebug lvl transformations fromLimit name exprOld hasChanged exprNew   | not (Set.null transformations) =     let newLvl = bool DebugNone lvl (name `Set.member` transformations) in-    applyDebug newLvl Set.empty name exprOld hasChanged exprNew+    applyDebug newLvl Set.empty fromLimit name exprOld hasChanged exprNew -applyDebug lvl _transformations name exprOld hasChanged exprNew =+applyDebug lvl _transformations _fromLimit name exprOld hasChanged exprNew =  traceIf (lvl >= DebugAll) ("Tried: " ++ name ++ " on:\n" ++ before) $ do+  nTrans <- pred <$> Lens.use transformCounter   Monad.when (lvl > DebugNone && hasChanged) $ do     tcm                  <- Lens.view tcCache     let beforeTy          = termType tcm exprOld@@ -242,7 +270,7 @@     error $ $(curLoc) ++ "Expression changed without notice(" ++ name ++  "): before"                       ++ before ++ "\nafter:\n" ++ after -  traceIf (lvl >= DebugName && hasChanged) name $+  traceIf (lvl >= DebugName && hasChanged) (name <> " {" <> show nTrans <> "}") $     traceIf (lvl >= DebugApplied && hasChanged) ("Changes when applying rewrite to:\n"                       ++ before ++ "\nResult:\n" ++ after ++ "\n") $       traceIf (lvl >= DebugAll && not hasChanged) ("No changes when applying rewrite "@@ -494,31 +522,50 @@     else       go subst2 inl +-- | Determines whether a global binder is work free. Errors if binder does+-- not exist.+isWorkFreeBinder :: HasCallStack => Id -> RewriteMonad extra Bool+isWorkFreeBinder bndr =+  makeCachedU bndr workFreeBinders $ do+    bExprM <- lookupVarEnv bndr <$> Lens.use bindings+    case bExprM of+      Nothing -> error ("isWorkFreeBinder: couldn't find binder: " ++ showPpr bndr)+      Just (bindingTerm -> t) ->+        if bndr `globalIdOccursIn` t+        then pure False+        else isWorkFree t+ -- | Determine whether a term does any work, i.e. adds to the size of the circuit isWorkFree   :: Term-  -> Bool+  -> RewriteMonad extra Bool isWorkFree (collectArgs -> (fun,args)) = case fun of-  Var i            -> isLocalId i && not (isPolyFunTy (varType i))-  Data {}          -> all isWorkFreeArg args-  Literal {}       -> True+  Var i ->+    if | isPolyFunTy (varType i) -> pure False+       | isLocalId i -> pure True+       | otherwise -> andM [isWorkFreeBinder i, allM isWorkFreeArg args]+  Data {} -> allM isWorkFreeArg args+  Literal {} -> pure True   Prim pInfo -> case primWorkInfo pInfo of-    WorkConstant   -> True -- We can ignore the arguments, because this-                           -- primitive outputs a constant regardless of its-                           -- arguments-    WorkNever      -> all isWorkFreeArg args-    WorkVariable   -> all isConstantArg args-    WorkAlways     -> False -- Things like clock or reset generator always-                            -- perform work-  Lam _ e          -> isWorkFree e && all isWorkFreeArg args-  TyLam _ e        -> isWorkFree e && all isWorkFreeArg args+    -- We can ignore the arguments, because this primitive outputs a constant+    -- regardless of its arguments+    WorkConstant -> pure True+    WorkNever -> allM isWorkFreeArg args+    WorkVariable -> pure (all isConstantArg args)+    -- Things like clock or reset generator always perform work+    WorkAlways -> pure False+  Lam _ e -> andM [isWorkFree e, allM isWorkFreeArg args]+  TyLam _ e -> andM [isWorkFree e, allM isWorkFreeArg args]   Letrec bs e ->-    isWorkFree e && all (isWorkFree . snd) bs && all isWorkFreeArg args-  Case s _ [(_,a)] -> isWorkFree s && isWorkFree a && all isWorkFreeArg args-  Cast e _ _       -> isWorkFree e && all isWorkFreeArg args-  _                -> False+    andM [isWorkFree e, allM (isWorkFree . snd) bs, allM isWorkFreeArg args]+  Case s _ [(_,a)] ->+    andM [isWorkFree s, isWorkFree a, allM isWorkFreeArg args]+  Cast e _ _ ->+    andM [isWorkFree e, allM isWorkFreeArg args]+  _ ->+    pure False  where-  isWorkFreeArg = either isWorkFree (const True)+  isWorkFreeArg e = eitherM isWorkFree (pure . const True) (pure e)   isConstantArg = either isConstant (const True)  isFromInt :: Text -> Bool@@ -1093,11 +1140,40 @@   -> PureHeap   -> Rewrite extra   -> Rewrite extra-bindPureHeap tcm heap rw (TransformContext is0 hist) e = do+bindPureHeap tcm heap rw ctx0@(TransformContext is0 hist) e = do   (e1, Monoid.getAny -> hasChanged) <- Writer.listen $ rw ctx e-  if hasChanged && not (null bndrs)-    then return $ Letrec bndrs e1-    else return e1+  if hasChanged && not (null bndrs) then do+    -- The evaluator results are post-processed with two operations:+    --+    --   1. Inline work free binders. We've seen cases in the wild† where the+    --      evaluator (or rather, 'bindPureHeap') would let-bind work-free+    --      binders that were crucial for eliminating case constructs. If these+    --      case constructs were used in a self-referential (but terminating)+    --      manner, Clash would get stuck in an infinite loop. The proper+    --      solution would be to use 'isWorkFree', instead of 'isWorkFreeIsh',+    --      in 'bindConstantVar' such that these work free constructs would get+    --      inlined again. However, this incurs a great performance penalty so+    --      we opt to prevent the evaluator from introducing this situation in+    --      the first place.+    --+    --      I'd like to stress that this is not a proper solution though, as GHC+    --      might produce a similar situation. We plan on properly solving this+    --      by eliminating the current lift/bind/eval strategy, instead replacing+    --      it by a partial evaluator‡.+    --+    --   2. Remove any unused let-bindings. Similar to (1), we risk Clash getting+    --      stuck in an infinite loop if we don't remove unused (eliminated by+    --      evaluation!) binders.+    --+    -- † https://github.com/clash-lang/clash-compiler/pull/1354#issuecomment-635430374+    -- ‡ https://www.microsoft.com/en-us/research/wp-content/uploads/2016/07/supercomp-by-eval.pdf+    inlineBinders inlineTest ctx0 (Letrec bndrs e1) >>= \case+      e2@(Letrec bnders1 e3) ->+        pure (fromMaybe e2 (removeUnusedBinders bnders1 e3))+      e2 ->+        pure e2+  else+    return e1   where     bndrs = map toLetBinding $ toListUniqMap heap     heapIds = map fst bndrs@@ -1109,3 +1185,35 @@       where         ty = termType tcm term         nm = mkLocalId ty (mkUnsafeSystemName "x" uniq) -- See [Note: Name re-creation]++    inlineTest _ (_, stripTicks -> e_) = isWorkFree e_++-- | Remove unused binders in given let-binding. Returns /Nothing/ if no unused+-- binders were found.+removeUnusedBinders+  :: [LetBinding]+  -> Term+  -> Maybe Term+removeUnusedBinders binds body =+  case eltsVarEnv used of+    [] -> Just body+    qqL | not (List.equalLength qqL binds)+        -> Just (Letrec qqL body)+        | otherwise+        -> Nothing+ where+  bodyFVs = Lens.foldMapOf freeLocalIds unitVarSet body+  used = List.foldl' collectUsed emptyVarEnv (eltsVarSet bodyFVs)+  bindsEnv = mkVarEnv (map (\(x,e0) -> (x,(x,e0))) binds)++  collectUsed env v =+    if v `elemVarEnv` env then+      env+    else+      case lookupVarEnv v bindsEnv of+        Just (x,e0) ->+          let eFVs = Lens.foldMapOf freeLocalIds unitVarSet e0+          in  List.foldl' collectUsed+                          (extendVarEnv x (x,e0) env)+                          (eltsVarSet eFVs)+        Nothing -> env

@@ -25,6 +25,26 @@   (acc'',ys) <- mapAccumLM f acc' xs   return (acc'',y:ys) +-- | Monadic version of 'iterate'. A carbon copy ('iterateM') would not+-- terminate, hence the first argument.+iterateNM+  :: Monad m+  => Word+  -- ^ Only iterate /n/ times. Note that /n/ is the length of the resulting+  -- list, _not_ the number of times the iteration function has been invoked+  -> (a -> m a)+  -- ^ Iteration function+  -> a+  -- ^ Start value+  -> m [a]+iterateNM 0 _f _a = pure []+iterateNM limit f a = fmap (a:) (go (limit - 1) a)+ where+  go 0 _a0 = pure []+  go n a0 = do+    a1 <- f a0+    fmap (a1:) (go (n - 1) a1)+ infixr 5 <:> -- | Applicative version of 'GHC.Types.(:)' (<:>) :: Applicative f => f a -> f [a] -> f [a]

@@ -34,13 +34,6 @@   , idScope = LocalId   } -typeVar :: Var Type-typeVar = TyVar {-    varName = fakeName {nameUniq=unique, nameOcc="type"}-  , varUniq = unique-  , varType = ConstTy (TyCon fakeName)-  }- term1 :: Term term1 = Var termVar @@ -49,5 +42,5 @@   testGroup     "Clash.Tests.Core.Subst"     [ testCase "deShadow type/term" $-        term1 @=? deShadowTerm (extendInScopeSet emptyInScopeSet typeVar) term1+        term1 @=? deShadowTerm (extendInScopeSet emptyInScopeSet termVar) term1     ]

@@ -0,0 +1,133 @@+{-|+Copyright  :  (C) 2020, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-# LANGUAGE QuasiQuotes #-}++module Clash.Tests.Normalize.Transformations where++import Clash.Normalize.Transformations (inlineBndrsCleanup)+import Clash.Core.VarEnv+  (mkInScopeSet, mkVarSet, mkVarEnv, emptyVarEnv, extendInScopeSetList)+import Clash.Core.FreeVars (countFreeOccurances)+import Clash.Core.Term+import Clash.Unique (UniqSet, extendUniqSet, unitUniqSet)++import Test.Tasty+import Test.Tasty.HUnit++import Test.Clash.Rewrite (parseToTermQQ, parseToTerm)++import Debug.Trace+import Clash.Core.Pretty (showPpr)++t1337a :: Term+t1337a = Letrec keep1 result+ where+  (keep0:inlines)= map (\(v,e) -> (v,((v,e),countFreeOccurances e))) binds+  is = mkInScopeSet (mkVarSet (map fst binds))++  keep1 = inlineBndrsCleanup is (mkVarEnv inlines) emptyVarEnv [snd keep0]++  Letrec binds result =+    [parseToTermQQ|+      let+        -- Types don't mean anything for this example+        result_1, a_2, b_3, c_4 :: Int++        result_1 = a_2++        a_2 = b_3+        b_3 = c_4+        c_4 = a_2 b_3+      in+        result_1+    |]++t1337a_result :: Term+t1337a_result = [parseToTermQQ|+  let+    result_1, b_3 :: Int+    result_1 = b_3+    b_3 = b_3 b_3+  in+    result_1+|]++t1337b :: Term+t1337b = Letrec keep1 result+ where+  (keep0:inlines)= map (\(v,e) -> (v,((v,e),countFreeOccurances e))) binds+  is = mkInScopeSet (mkVarSet (map fst binds))++  keep1 = inlineBndrsCleanup is (mkVarEnv inlines) emptyVarEnv [snd keep0]++  Letrec binds result =+    [parseToTermQQ|+      let+        -- Types don't mean anything for this example+        result_1, a_2, b_3, c_4, d_5 :: Int++        result_1 = a_2++        a_2 = b_3+        b_3 = c_4+        c_4 = d_5+        d_5 = a_2 b_3 c_4+      in+        result_1+    |]++t1337b_result :: Term+t1337b_result = [parseToTermQQ|+  let+    result_1, c_4 :: Int+    result_1 = c_4+    c_4 = c_4 c_4 c_4+  in+    result_1+|]++t1337c :: Term+t1337c = Letrec keep1 result+ where+  (keep0:inlines)= map (\(v,e) -> (v,((v,e),countFreeOccurances e))) binds+  Var fv = parseToTerm "freevar_5 :: Int"+  is = mkInScopeSet (mkVarSet (fv : map fst binds))++  keep1 = inlineBndrsCleanup is (mkVarEnv inlines) emptyVarEnv [snd keep0]++  Letrec binds result =+    [parseToTermQQ|+      let+        result_1, a_2, b_3, c_4 :: Int++        result_1 = a_2++        a_2 = b_3+        b_3 = c_4+        c_4 = a_2 b_3 (freevar_5 :: Int)+      in+        result_1+    |]++t1337c_result :: Term+t1337c_result = [parseToTermQQ|+  let+    result_1, b_3 :: Int+    result_1 = b_3+    b_3 = b_3 b_3 (freevar_5 :: Int)+  in+    result_1+|]++tests :: TestTree+tests =+  testGroup+    "Clash.Tests.Core.Util.Interpolation"+    [ testCase "T1337a" $ t1337a_result @=? t1337a+    , testCase "T1337b" $ t1337b_result @=? t1337b+    , testCase "T1337c" $ t1337c_result @=? t1337c+    ]

@@ -0,0 +1,307 @@+{-|+  Copyright  :  (C) 2020 QBayLogic B.V.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++  Utilities to write unit tests on transformations+-}++{-# OPTIONS_GHC -Wno-orphans #-}++{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE QuasiQuotes #-}++module Test.Clash.Rewrite where++import Clash.Annotations.BitRepresentation.Internal (buildCustomReprs)+import qualified Clash.Core.Name as C+import qualified Clash.Core.Term as C+import qualified Clash.Core.Literal as C+import qualified Clash.Core.Type as C+import qualified Clash.Core.Var as C+import Clash.Core.VarEnv (InScopeSet, emptyVarSet, emptyVarEnv, emptyInScopeSet)+import Clash.Driver.Types (DebugLevel(DebugSilent))+import Clash.Rewrite.Types+import Clash.Rewrite.Util (runRewrite)+import Clash.Normalize.Types+import Clash.Unique (emptyUniqMap)+import qualified Clash.Util.Interpolate as I++import Control.Applicative ((<|>))+import Control.Concurrent.Supply (newSupply)+import Data.Default+import Language.Haskell.Exts.Syntax+import Language.Haskell.Exts.Parser (parseExp, fromParseResult)+import System.IO.Unsafe (unsafePerformIO)+import Text.Read (readMaybe)+import GHC.Stack (HasCallStack)++import qualified Language.Haskell.TH.Syntax as TH+import qualified Language.Haskell.TH.Quote as TH++import qualified Data.List as List+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.IntMap as IntMap+import qualified Data.Text as Text++type TypeMap = HashMap.HashMap Int C.Type++lookupTM :: Int -> TypeMap -> C.Type+lookupTM u tm = case HashMap.lookup u tm of+  Just t -> t+  Nothing ->+    error [I.i|+      Tried to lookup unique '#{u}' in typemap, but couldn't find it. This+      usually means you forgot to (explicitely) declare a variable's type.+    |]++instance Default RewriteEnv where+  def = RewriteEnv+    { _dbgLevel=DebugSilent+    , _dbgTransformations=Set.empty+    , _dbgTransformationsFrom=0+    , _dbgTransformationsLimit=maxBound+    , _aggressiveXOpt=False+    , _typeTranslator=error "_typeTranslator: NYI"+    , _tcCache=emptyUniqMap+    , _tupleTcCache=IntMap.empty+    , _evaluator=error "_evaluator: NYI"+    , _topEntities=emptyVarSet+    , _customReprs=buildCustomReprs []+    }++instance Default extra => Default (RewriteState extra) where+  def = RewriteState+    { _transformCounter=0+    , _bindings=emptyVarEnv+    , _uniqSupply=unsafePerformIO newSupply+    , _curFun=error "_curFun: NYI"+    , _nameCounter=2+    , _workFreeBinders=emptyVarEnv+    , _globalHeap=error "_globalHeap: NYI"+    , _extra=def+    }++instance Default NormalizeState where+  def = NormalizeState+    { _normalized=emptyVarEnv+    , _specialisationCache=Map.empty+    , _specialisationHistory=emptyVarEnv+    , _specialisationLimit=20+    , _inlineHistory=emptyVarEnv+    , _inlineLimit=20+    , _inlineFunctionLimit=15+    , _inlineConstantLimit=0+    , _primitives=HashMap.empty+    , _primitiveArgs=Map.empty+    , _recursiveComponents=emptyVarEnv+    , _newInlineStrategy=True+    , _normalizeUltra=False+    , _inlineWFCacheLimit=10+    }++instance Default InScopeSet where+  def = emptyInScopeSet++-- | Run a single transformation given a certain context+runSingleTransformation+  :: RewriteEnv+  -- ^ Rewrite environment+  -> RewriteState extra+  -- ^ Rewrite state+  -> InScopeSet+  -- ^ Variables in scope in transformation+  -> Rewrite extra+  -- ^ Transformation to perform+  -> C.Term+  -- ^ Term to transform+  -> C.Term+runSingleTransformation rwEnv rwState is trans term = t+ where (t, _, _) = runR (runRewrite "" is trans term) rwEnv rwState++-- | Run a single transformation with an empty environment and empty+-- InScopeSet. See Default instances ^ to inspect the precise definition of+-- "empty".+--+-- Note that at the time of writing (May 2020) the default environment does not+-- include a type translator, evaluator, current function, or global heap. Maps,+-- like the primitive and tycon map, are also empty. If the transformation under+-- test needs these definitions, you should add them manually.+runSingleTransformationDef :: Default extra => Rewrite extra -> C.Term -> C.Term+runSingleTransformationDef = runSingleTransformation def def def+++parseType :: Show l => Type l -> C.Type+parseType = \case+  -- Type constructor: T+  TyCon _ (UnQual _ (Ident _ typNm)) ->+    -- TODO: We could/should build a TyConMap here+    C.ConstTy (C.TyCon (C.Name C.User (Text.pack typNm) 0 C.noSrcSpan))++  -- Unsupported type:+  t ->+    error ("parseType: " <> show t)++-- | Parse an identifier into a Clash Name. Identifiers must include a unique+-- and might include a modifier indicating whether its NameSort. Examples:+--+--   * x_3:  User identifier with human readable name "x", unique "3"+--   * x_I3: Internal identifier with human readable name "x", unique "3"+--   * x_S3: System identifier with human readable name "x", unique "3"+--+parseName :: Show l => Name l -> C.Name a+parseName = \case+  Ident _ s -> failOnNothing s (go "" s)+  Symbol _ s -> failOnNothing s (go "" s)+ where+  failOnNothing _ (Just (nmSort, nm, uniq)) =+    C.mkUnsafeName nmSort (Text.pack nm) uniq+  failOnNothing s Nothing = error [I.i|+    Not a valid id: #{s}. Identifiers must be of form 'foobar_123', where+    'foobar' is a human-readable (but ultimately unused) name and '123' is the+    unique. Additionally, 'I', 'U', or 'S' might be prefixed to create an+    Internal, User, or System name respectively. For example, 'foobar_S123'.+  |]++  go _seen "" = Nothing+  go seen0 ('_':s:ss)+    | 'U' <- s = fmap (C.User,seen1,) (readMaybe ss) <|> cont+    | 'S' <- s = fmap (C.System,seen1,) (readMaybe ss) <|> cont+    | 'I' <- s = fmap (C.Internal,seen1,) (readMaybe ss) <|> cont+    | otherwise = fmap (C.User,seen1,) (readMaybe (s:ss)) <|> cont+   where+    seen1 = reverse seen0+    cont = go ('_':seen0) (s:ss)+  go seen (s:ss) = go (s:seen) ss++-- | Parse declarations (as, amongst others, used in let expressions). Note that+-- every binder needs an explicit type annotation, as we don't do any type+-- inference. Type annotations may occur anywhere though. Example, this is OK:+--+--    let+--      x_0 :: Int+--      x_0 = 2+--+--      x_1 :: Int+--      x_1 = x_0+--    in+--      x_1+--+-- But this is not:+--+--    let+--      x_0 :: Int+--      x_0 = 2+--+--      x_1 = x_0+--    in+--      x_1+--+parseDecls+  :: forall l+   . (HasCallStack, Show l)+  => TypeMap+  -> [Decl l]+  -> (TypeMap, [C.LetBinding])+parseDecls typs0 decls = (typs1, map parseOtherDecl otherDecls)+ where+  (typDecls, otherDecls) = List.partition isTypeDecl decls+  insertTyp (nm, t) = HashMap.insert nm t+  typs1 = foldr insertTyp typs0 (concatMap parseTypeDecl typDecls)++  parseOtherDecl :: HasCallStack => Decl l -> C.LetBinding+  parseOtherDecl = \case+    PatBind _ (PVar _ (parseName -> nm)) (UnGuardedRhs _ e) Nothing ->+      let+        uniq = C.nameUniq nm+        typ = lookupTM (C.nameUniq nm) typs1+      in+        (C.Id nm uniq typ C.LocalId, expToTerm typs1 e)+    e ->+      error ("parseOtherDecl: " <> show e)++  parseTypeDecl :: Decl l -> [(Int, C.Type)]+  parseTypeDecl (TypeSig _ nms t) =+    map (\nm -> (C.nameUniq (parseName nm), parseType t)) nms+  parseTypeDecl _ = error "impossible"++  isTypeDecl :: Decl l -> Bool+  isTypeDecl (TypeSig {}) = True+  isTypeDecl _ = False++-- | Parse a haskell-src-exts expression into Clash Core.+expToTerm+  :: forall l+   . (HasCallStack, Show l)+  => TypeMap+  -> Exp l+  -> C.Term+expToTerm typs0 = \case+  -- Parentheses: (...)+  Paren _ e ->+    expToTerm typs0 e++  -- Local variable reference with type signature: x :: t+  ExpTypeSig _ (Var _ (UnQual _ (parseName -> nm))) (parseType -> t) ->+    C.Var (C.Id nm (C.nameUniq nm) t C.LocalId)++  -- Term application: e1 e2+  App _ e1 e2 ->+    C.App (expToTerm typs0 e1) (expToTerm typs0 e2)++  -- Variable reference: e+  Var _ (UnQual _ (parseName -> nm)) ->+    let+     uniq = C.nameUniq nm+     typ = lookupTM (C.nameUniq nm) typs0+    in+      C.Var (C.Id nm uniq typ C.LocalId)++  -- Literal: 3+  Lit _ (Int _ i _) -> C.Literal (C.IntLiteral i)++  -- Let expression: let {e1 = .., e2 = ..} in r+  Let _ (BDecls _ decls0) body0 ->+    let+      (typs1, decls1) = parseDecls typs0 decls0+      body1 = expToTerm typs1 body0+    in+      C.Letrec decls1 body1++ -- Unsupported expression+  e -> error ("expToTerm: " <> show e)++-- | Parse a string representing a Haskell expression into Clash Core. This can+-- only parse very simple expressions. In the future we should make an effort to+-- build a proper TyConMap (using LoadModules) to faithfully reproduce more+-- complex expressions.+parseToTerm :: String -> C.Term+parseToTerm = expToTerm HashMap.empty . fromParseResult . parseExp++-- | See documentation of 'parseToTerm'. Example usage:+--+--     letrec = [parseToTermQQ|+--        let+--          x_0, x_1 :: Int+--          x_0 = 5+--          x_1 = 6+--        in+--          x_0+--     |]+--+-- Note that this is parsed at runtime, not at compile time. There's no good+-- technical reason for this though. We'd just need to implement a Template+-- Haskell Lift instance for Term.+--+-- For more information on the format of identifiers, see 'parseName'.+parseToTermQQ :: TH.QuasiQuoter+parseToTermQQ = TH.QuasiQuoter{+    TH.quoteExp = fmap (TH.AppE (TH.VarE 'parseToTerm)) . TH.lift+  , TH.quotePat = error "parseToTerm.quotePat: NYI"+  , TH.quoteType = error "parseToTerm.quoteType: NYI"+  , TH.quoteDec = error "parseToTerm.quoteDec: NYI"+  }+

@@ -5,12 +5,14 @@ import qualified Clash.Tests.Core.FreeVars import qualified Clash.Tests.Core.Subst import qualified Clash.Tests.Util.Interpolate+import qualified Clash.Tests.Normalize.Transformations  tests :: TestTree tests = testGroup "Unittests"   [ Clash.Tests.Core.FreeVars.tests   , Clash.Tests.Core.Subst.tests   , Clash.Tests.Util.Interpolate.tests+  , Clash.Tests.Normalize.Transformations.tests   ]  main :: IO ()