clash-lib 1.2.4 → 1.2.5

raw patch · 16 files changed

+142/−81 lines, 16 filesdep ~ansi-terminaldep ~attoparsecdep ~bytestringPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: ansi-terminal, attoparsec, bytestring, clash-prelude, tasty, text-show, time

API changes (from Hackage documentation)

Files

• CHANGELOG.md +15/−3
• clash-lib.cabal +7/−7
• prims/common/GHC_Natural.json +8/−0
• src/Clash/Backend/SystemVerilog.hs +3/−3
• src/Clash/Backend/VHDL.hs +3/−3
• src/Clash/Core/EqSolver.hs +25/−18
• src/Clash/Core/Type.hs +10/−6
• src/Clash/Core/Util.hs +7/−6
• src/Clash/Driver.hs +10/−6
• src/Clash/Netlist.hs +4/−4
• src/Clash/Netlist/BlackBox.hs +4/−1
• src/Clash/Netlist/BlackBox/Types.hs +1/−1
• src/Clash/Normalize/PrimitiveReductions.hs +4/−3
• src/Clash/Normalize/Transformations.hs +23/−14
• src/Clash/Primitives/DSL.hs +3/−2
• src/Data/List/Extra.hs +15/−4

@@ -1,5 +1,19 @@ # Changelog for the Clash project +## 1.2.5 *November 9th 2020*+Fixed:+  * The normalizeType function now fully normalizes types which require calls to+reduceTypeFamily [#1469](https://github.com/clash-lang/clash-compiler/issues/1469)+  * `flogBaseSNat`, `clogBaseSNat` and `logBaseSNat` primitives are now implemented correctly.Previously these primitives would be left unevaluated causing issues as demonstrated in [#1479](https://github.com/clash-lang/clash-compiler/issues/1469)+  * Specializing on functions with type family arguments no longer fails [#1477](https://github.com/clash-lang/clash-compiler/issues/1477)+  * `satSucc`, `satPred` correctly handle "small types" such as `Index 1`.+  * `msb` no longer fails on values larger than 64 bits+  * `undefined` can now be used as a reset value of `autoReg@Maybe` [#1507](https://github.com/clash-lang/clash-compiler/issues/1507)+  * Signal's `fmap` is now less strict, preventing infinite loops in very specific situations. See [#1521](https://github.com/clash-lang/clash-compiler/issues/1521)+  * Clash now uses correct function names in manifest and sdc files [#1533](https://github.com/clash-lang/clash-compiler/issues/1533)+  * Clash no longer produces erroneous HDL in very specific cases [#1536](https://github.com/clash-lang/clash-compiler/issues/1536)+  * Usage of `fold` inside other HO primitives (e.g., `map`) no longer fails [#1524](https://github.com/clash-lang/clash-compiler/issues/1524)+ ## 1.2.4 *July 28th 2020* * Changed:   * Relaxed upper bound versions of `aeson` and `dlist`, in preparation for the new Stack LTS.@@ -16,7 +30,7 @@   * `instance Text.Printf(Unsigned)`  * Fixed:-  * Clash renders incorrect VHDL when GHCs Worker/Wrapper transformation is enabled [#1402](https://github.com/clash-lang/clash-compiler/issues/14020)+  * Clash renders incorrect VHDL when GHCs Worker/Wrapper transformation is enabled [#1402](https://github.com/clash-lang/clash-compiler/issues/1402)   * Minor faults in generated HDL when using annotations from `Clash.Annotations.SynthesisAttributes`   * Cabal installed through Snap (`clash.cabal`) can now access the internet to fetch pacakges. [#1411]https://github.com/clash-lang/clash-compiler/issues/1411   * Generated QSys file for `altpll` incompatible with Quartus CLI (did work in Quartus GUI)@@ -387,5 +401,3 @@  * https://github.com/clash-lang/clash-compiler/blob/3649a2962415ea8ca2d6f7f5e673b4c14de26b4f/clash-prelude/CHANGELOG.md  * https://github.com/clash-lang/clash-compiler/blob/3649a2962415ea8ca2d6f7f5e673b4c14de26b4f/clash-lib/CHANGELOG.md  * https://github.com/clash-lang/clash-compiler/blob/3649a2962415ea8ca2d6f7f5e673b4c14de26b4f/clash-ghc/CHANGELOG.md--

@@ -1,6 +1,6 @@ Cabal-version:        2.2 Name:                 clash-lib-Version:              1.2.4+Version:              1.2.5 Synopsis:             CAES Language for Synchronous Hardware - As a Library Description:   Clash is a functional hardware description language that borrows both its@@ -136,12 +136,12 @@                       TemplateHaskell    Build-depends:      aeson                   >= 0.6.2.0  && < 1.6,-                      ansi-terminal           >= 0.8.0.0  && < 0.11,+                      ansi-terminal           >= 0.8.0.0  && < 0.12,                       attoparsec              >= 0.10.4.0 && < 0.14,                       base                    >= 4.11     && < 5,                       binary                  >= 0.8.5    && < 0.11,-                      bytestring              >= 0.10.0.2 && < 0.11,-                      clash-prelude           == 1.2.4,+                      bytestring              >= 0.10.0.2 && < 0.12,+                      clash-prelude           == 1.2.5,                       concurrent-supply       >= 0.1.7    && < 0.2,                       containers              >= 0.5.0.0  && < 0.7,                       data-binary-ieee754     >= 0.4.4    && < 0.6,@@ -172,8 +172,8 @@                       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,+                      text-show               >= 3.7      && < 3.10,+                      time                    >= 1.4.0.1  && < 1.12,                       transformers            >= 0.5.2.0  && < 0.6,                       trifecta                >= 1.7.1.1  && < 2.2,                       utf8-string             >= 1.0.1    && < 1.1,@@ -296,7 +296,7 @@       haskell-src-exts,       ghc,       lens,-      tasty         >= 1.2      && < 1.4,+      tasty         >= 1.2      && < 1.5,       tasty-hunit,       template-haskell,       text,

@@ -7,6 +7,14 @@     }   },   {+    "Primitive": {+      "name": "GHC.Natural.naturalToInteger",+      "workInfo": "Never",+      "primType": "Function",+      "warning": "GHC.Natural.naturalToInteger: No blackbox available without size inference for Natural and Integer"+    }+  },+  {     "BlackBox": {       "name": "GHC.Natural.underflowError",       "workInfo" : "Constant",

@@ -27,7 +27,7 @@ import           Data.HashSet                         (HashSet) import qualified Data.HashSet                         as HashSet import           Data.List                            (nub, nubBy)-import           Data.List.Extra                      ((<:>))+import           Data.List.Extra                      ((<:>), zipEqual) import           Data.Maybe                           (catMaybes,fromMaybe,mapMaybe) #if !MIN_VERSION_base(4,11,0) import           Data.Monoid                          hiding (Sum, Product)@@ -1195,10 +1195,10 @@   int (typeSize ty) <> squote <> "d" <> int (fromIntegral value) expr_ _ (DataCon (CustomSP _ dataRepr _size args) (DC (_,i)) es) =   let (cRepr, _, argTys) = args !! i in-  customReprDataCon dataRepr cRepr (zip argTys es)+  customReprDataCon dataRepr cRepr (zipEqual argTys es) expr_ _ (DataCon (CustomProduct _ dataRepr _size _labels tys) _ es) |   DataRepr' _typ _size [cRepr] <- dataRepr =-  customReprDataCon dataRepr cRepr (zip (map snd tys) es)+  customReprDataCon dataRepr cRepr (zipEqual (map snd tys) es)  expr_ _ (DataCon (Product _ _ tys) _ es) = listBraces (zipWithM toSLV tys es) 

@@ -31,7 +31,7 @@ import qualified Data.HashSet                         as HashSet import           Data.List   (mapAccumL, nub, nubBy, intersperse, group, sort)-import           Data.List.Extra                      ((<:>), equalLength)+import           Data.List.Extra                      ((<:>), equalLength, zipEqual) import           Data.Maybe                           (catMaybes,fromMaybe,mapMaybe) #if !MIN_VERSION_base(4,11,0) import           Data.Monoid                          hiding (Sum, Product)@@ -1581,10 +1581,10 @@   "std_logic_vector" <> parens ("to_unsigned" <> parens (int (fromIntegral value) <> comma <> int (typeSize ty))) expr_ _ (DataCon (CustomSP _ dataRepr _size args) (DC (_,i)) es) =   let (cRepr, _, argTys) = args !! i in-  customReprDataCon dataRepr cRepr (zip argTys es)+  customReprDataCon dataRepr cRepr (zipEqual argTys es) expr_ _ (DataCon (CustomProduct _ dataRepr _size _labels tys) _ es) |   DataRepr' _typ _size [cRepr] <- dataRepr =-  customReprDataCon dataRepr cRepr (zip (map snd tys) es)+  customReprDataCon dataRepr cRepr (zipEqual (map snd tys) es)  expr_ _ (DataCon ty@(Product _ labels tys) _ es) =     tupled $ zipWithM (\i e' -> tyName ty <> selectProductField labels tys i <+> rarrow <+> expr_ False e') [0..] es

@@ -2,6 +2,7 @@  module Clash.Core.EqSolver where +import Data.List.Extra (zipEqual) import Data.Maybe (catMaybes, mapMaybe)  import Clash.Core.Name (Name(nameOcc))@@ -9,6 +10,7 @@ import Clash.Core.TyCon import Clash.Core.Type import Clash.Core.Var+import Clash.Core.VarEnv (VarSet, elemVarSet, emptyVarSet, mkVarSet)  -- | Data type that indicates what kind of solution (if any) was found data TypeEqSolution@@ -27,12 +29,12 @@   getSol _ = Nothing  -- | Solve given equations and return all non-absurd solutions-solveNonAbsurds :: TyConMap -> [(Type, Type)] -> [(TyVar, Type)]-solveNonAbsurds _tcm [] = []-solveNonAbsurds tcm (eq:eqs) =-  solved ++ solveNonAbsurds tcm eqs+solveNonAbsurds :: TyConMap -> VarSet -> [(Type, Type)] -> [(TyVar, Type)]+solveNonAbsurds _tcm _ [] = []+solveNonAbsurds tcm solveSet (eq:eqs) =+  solved ++ solveNonAbsurds tcm solveSet eqs  where-  solvers = [pure . solveAdd, solveEq tcm]+  solvers = [pure . solveAdd solveSet, solveEq tcm solveSet]   solved = catSolutions (concat [s eq | s <- solvers])  -- | Solve simple equalities such as:@@ -43,13 +45,13 @@ --   * SomeType 3 5 ~ SomeType a b --   * SomeType a 5 ~ SomeType 3 b ---solveEq :: TyConMap -> (Type, Type) -> [TypeEqSolution]-solveEq tcm (coreView tcm -> left, coreView tcm -> right) =+solveEq :: TyConMap -> VarSet -> (Type, Type) -> [TypeEqSolution]+solveEq tcm solveSet (coreView tcm -> left, coreView tcm -> right) =   case (left, right) of-    (VarTy tyVar, ConstTy {}) ->+    (VarTy tyVar, ConstTy {}) | elemVarSet tyVar solveSet ->       -- a ~ 3       [Solution (tyVar, right)]-    (ConstTy {}, VarTy tyVar) ->+    (ConstTy {}, VarTy tyVar) | elemVarSet tyVar solveSet ->       -- 3 ~ a       [Solution (tyVar, left)]     (ConstTy {}, ConstTy {}) ->@@ -69,7 +71,7 @@           (TyConApp leftNm leftTys, TyConApp rightNm rightTys) ->             -- SomeType a b ~ SomeType 3 5 (or other way around)             if leftNm == rightNm then-              concat (map (solveEq tcm) (zip leftTys rightTys))+              concat (map (solveEq tcm solveSet) (zipEqual leftTys rightTys))             else               [AbsurdSolution]           _ ->@@ -78,11 +80,12 @@ -- | Solve equations supported by @normalizeAdd@. See documentation of -- @TypeEqSolution@ to understand the return value. solveAdd-  :: (Type, Type)+  :: VarSet+  -> (Type, Type)   -> TypeEqSolution-solveAdd ab =+solveAdd solveSet ab =   case normalizeAdd ab of-    Just (n, m, VarTy tyVar) ->+    Just (n, m, VarTy tyVar) | elemVarSet tyVar solveSet ->       if n >= 0 && m >= 0 && n - m >= 0 then         Solution (tyVar, (LitTy (NumTy (n - m))))       else@@ -122,7 +125,11 @@   -> Alt   -> Bool isAbsurdAlt tcm alt =-  any (isAbsurdEq tcm) (altEqs tcm alt)+  any (isAbsurdEq tcm exts) (altEqs tcm alt)+ where+  exts = case alt of+    (DataPat _dc extNms _ids,_) -> mkVarSet extNms+    _ -> emptyVarSet  -- | Determines if an "equation" obtained through @altEqs@ or @typeEq@ is -- absurd. That is, it tests if two types that are definitely not equal are@@ -130,12 +137,13 @@ -- (intermediate) result such as -1. isAbsurdEq   :: TyConMap+  -> VarSet -- ^ existential tvs   -> (Type, Type)   -> Bool-isAbsurdEq tcm ((left0, right0)) =+isAbsurdEq tcm exts ((left0, right0)) =   case (coreView tcm left0, coreView tcm right0) of-    (solveAdd -> AbsurdSolution) -> True-    lr -> any (==AbsurdSolution) (solveEq tcm lr)+    (solveAdd exts -> AbsurdSolution) -> True+    lr -> any (==AbsurdSolution) (solveEq tcm exts lr)  -- | Get constraint equations altEqs@@ -156,4 +164,3 @@     Just (coreView tcm left, coreView tcm right)   _ ->     Nothing-

@@ -63,7 +63,7 @@ import           Data.Coerce            (coerce) import           Data.Hashable          (Hashable) import           Data.List              (foldl')-import           Data.List.Extra        (splitAtList)+import           Data.List.Extra        (splitAtList, zipEqual) import           Data.Maybe             (isJust, mapMaybe) import           GHC.Base               (isTrue#,(==#)) import           GHC.Generics           (Generic(..))@@ -413,7 +413,7 @@ -- a substituted RHS funSubsts :: TyConMap -> ([Type],Type) -> [Type] -> Maybe Type funSubsts tcm (tcSubstLhs,tcSubstRhs) args = do-  tySubts <- foldl' (funSubst tcm) (Just []) (zip tcSubstLhs args)+  tySubts <- foldl' (funSubst tcm) (Just []) (zipEqual tcSubstLhs args)   let tyRhs = uncurry substTyWith (unzip tySubts) tcSubstRhs   -- Type functions can return higher-kinded types   case drop (length tcSubstLhs) args of@@ -625,9 +625,6 @@   where   go ty = case tyView ty of     TyConApp tcNm args-      | nameOcc tcNm == "Clash.Signal.Internal.Signal"-      , [_,elTy] <- args-      -> go elTy       -- These Clash types are implemented with newtypes.       -- We need to keep these newtypes because they define the width of the numbers.       | nameOcc tcNm == "Clash.Sized.Internal.BitVector.Bit" ||@@ -646,7 +643,14 @@              let args' = map go args                  ty' = mkTyConApp tcNm args'              in case reduceTypeFamily tcMap ty' of-               Just ty'' -> ty''+               -- TODO Instead of recursing here, reduceTypeFamily should+               -- ensure that if the result is a reducible type family it is+               -- also reduced. This would reduce traversals over a type.+               --+               -- It may be a good idea to keep reduceTypeFamily only reducing+               -- one family, and definiing reduceTypeFamilies to reduce all+               -- it encounters in one traversal.+               Just ty'' -> go ty''                Nothing  -> ty'     FunTy ty1 ty2 -> mkFunTy (go ty1) (go ty2)     OtherType (ForAllTy tyvar ty')

@@ -134,7 +134,7 @@      (uniqs1,mTV) = mkUniqSystemTyVar uniqs0 ("m",typeNatKind)     (uniqs2,[elNId,restNId,co,el,rest]) =-      mapAccumR mkUniqSystemId uniqs1 $ zip+      mapAccumR mkUniqSystemId uniqs1 $ zipEqual         ["el" `T.append` (s `T.cons` T.pack (show (maxN-n)))         ,"rest" `T.append` (s `T.cons` T.pack (show (maxN-n)))         ,"_co_"@@ -186,7 +186,7 @@     (Just idTys) = dataConInstArgTys lrCon tys      (uniqs1,[elNId,co,el]) =-      mapAccumR mkUniqSystemId uniqs0 $ zip+      mapAccumR mkUniqSystemId uniqs0 $ zipEqual         [ "el" `T.append` (s `T.cons` T.pack (show (head ks)))         , "_co_"         , "el"@@ -209,7 +209,7 @@     (b0:bL,b1:bR) = splitAt (length bs `div` 2) bs     brTy = last idTys     (uniqs2,[ltNId,rtNId,co,lt,rt]) =-      mapAccumR mkUniqSystemId uniqs1 $ zip+      mapAccumR mkUniqSystemId uniqs1 $ zipEqual         ["lt" `T.append` (s `T.cons` T.pack (show b0))         ,"rt" `T.append` (s `T.cons` T.pack (show b1))         ,"_co_"@@ -371,12 +371,13 @@   -- TODO: been solved in the caseElemExistentials transformation)   let is1   = extendInScopeSetList is0 dcExtTyVars       is2   = unionInScope is1 (mkInScopeSet (tyFVsOfTypes inst_tys))-      subst = extendTvSubstList (mkSubst is2) (zip dcUnivTyVars inst_tys)+      subst = extendTvSubstList (mkSubst is2) (zipEqual dcUnivTyVars inst_tys)   go-    (substGlobalsInExistentials is0 dcExtTyVars (zip dcUnivTyVars inst_tys))+    (substGlobalsInExistentials is0 dcExtTyVars (zipEqual dcUnivTyVars inst_tys))     (map (substTy subst) dcArgTys)   where+  exts = mkVarSet dcExtTyVars   go     :: [TyVar]     -- ^ Existentials@@ -386,7 +387,7 @@     -- ^ Maybe ([type of non-existential])   go exts0 args0 =     let eqs = catMaybes (map (typeEq tcm) args0) in-    case solveNonAbsurds tcm eqs of+    case solveNonAbsurds tcm exts eqs of       [] ->         Just args0       sols ->

@@ -84,7 +84,7 @@ import           Clash.Core.Var   (Id, varName, varUniq, varType) import           Clash.Core.VarEnv-  (elemVarEnv, emptyVarEnv, lookupVarEnv)+  (VarEnv, elemVarEnv, eltsVarEnv, emptyVarEnv, lookupVarEnv, lookupVarEnv') import           Clash.Debug                      (debugIsOn) import           Clash.Driver.Types import           Clash.Netlist                    (genNetlist)@@ -413,8 +413,8 @@       putStrLn $ "Clash: Netlist generation took " ++ normNetDiff        -- 3. Generate topEntity wrapper-      let topComponent = view _4 . head $ filter (Data.Text.isSuffixOf topNm . componentName . view _4) netlist-          (hdlDocs,manifest',dfiles,mfiles)  = createHDL hdlState' (Data.Text.pack modName) seen' netlist topComponent+      let topComponent = view _4 (lookupVarEnv' netlist topEntity)+          (hdlDocs,manifest',dfiles,mfiles) = createHDL hdlState' (Data.Text.pack modName) seen' netlist topComponent                                    (topNm, Right manifest)       mapM_ (writeHDL dir) hdlDocs       copyDataFiles (opt_importPaths opts) dir dfiles@@ -710,7 +710,7 @@   -- ^ Module hierarchy root   -> HashMap Identifier Word   -- ^ Component names-  -> [([Bool],SrcSpan,HashMap Identifier Word,Component)]+  -> VarEnv ([Bool],SrcSpan,HashMap Identifier Word,Component)   -- ^ List of components   -> Component   -- ^ Top component@@ -724,7 +724,11 @@   -- + The update manifest file   -- + The data files that need to be copied createHDL backend modName seen components top (topName,manifestE) = flip evalState backend $ getMon $ do-  (hdlNmDocs,incs) <- unzip <$> mapM (\(_wereVoids,sp,ids,comp) -> genHDL modName sp (HashMap.unionWith max seen ids) comp) components+  let componentsL = eltsVarEnv components+  (hdlNmDocs,incs) <-+    unzip <$> mapM (\(_wereVoids,sp,ids,comp) ->+                      genHDL modName sp (HashMap.unionWith max seen ids) comp)+              componentsL   hwtys <- HashSet.toList <$> extractTypes <$> Mon get   typesPkg <- mkTyPackage modName hwtys   dataFiles <- Mon getDataFiles@@ -739,7 +743,7 @@       let topOutNames = map (fst . (\(_,x,_) -> x)) (outputs top)       topOutTypes <- mapM (fmap (Text.toStrict . renderOneLine) .                            hdlType (External topName) . snd . (\(_,x,_) -> x)) (outputs top)-      let compNames = map (componentName . view _4) components+      let compNames = map (componentName . view _4) componentsL       return (m { portInNames    = topInNames                 , portInTypes    = topInTypes                 , portOutNames   = topOutNames

@@ -68,7 +68,7 @@ import           Clash.Core.Util                  (splitShouldSplit) import           Clash.Core.Var                   (Id, Var (..), isGlobalId) import           Clash.Core.VarEnv-  (VarEnv, eltsVarEnv, emptyInScopeSet, emptyVarEnv, extendVarEnv, lookupVarEnv,+  (VarEnv, emptyInScopeSet, emptyVarEnv, extendVarEnv, lookupVarEnv,    lookupVarEnv', mkVarEnv) import           Clash.Driver.Types               (BindingMap, Binding(..), ClashOpts (..)) import           Clash.Netlist.BlackBox@@ -117,12 +117,12 @@   -- ^ Component name prefix   -> Id   -- ^ Name of the @topEntity@-  -> IO ([([Bool],SrcSpan,HashMap Identifier Word,Component)],HashMap Identifier Word)+  -> IO (VarEnv ([Bool],SrcSpan,HashMap Identifier Word,Component),HashMap Identifier Word) genNetlist isTb opts reprs globals tops primMap tcm typeTrans iw mkId extId ite be seen env prefixM topEntity = do   (_,s) <- runNetlistMonad isTb opts reprs globals topEntityMap              primMap tcm typeTrans iw mkId extId ite be seen env prefixM $              genComponent topEntity-  return ( eltsVarEnv $ _components s+  return ( _components s          , _seenComps s          )   where@@ -1013,7 +1013,7 @@                                             Identifier nm0 Nothing                                               | nm == nm0 -> Nothing                                             _ -> Just (Assignment nm e))-                  (zip (map CoreId argNms) argExprs)+                  (zipEqual (map CoreId argNms) argExprs)     return (Noop,argDecls ++ assns)   else     error "internal error"

@@ -864,7 +864,6 @@   tcm <- Lens.use tcCache   -- TODO: Rewrite this function to use blackbox functions. Right now it   -- TODO: generates strings that are later parsed/interpreted again. Silly!-  (bbCtx,dcls) <- mkBlackBoxContext "__INTERNAL__" resId args   templ <- case appE of             Prim p -> do               bb  <- extractPrimWarnOrFail (primName p)@@ -1000,6 +999,10 @@               let is0 = mkInScopeSet (Lens.foldMapOf freeIds unitVarSet appE)               either Left (Right . first (second (tickDecls ++))) <$> go is0 0 appE             _ -> error $ $(curLoc) ++ "Cannot make function input for: " ++ showPpr e+  let pNm = case appE of+              Prim p -> primName p+              _ -> "__INTERNAL__"+  (bbCtx,dcls) <- mkBlackBoxContext pNm resId args   case templ of     Left (TDecl,oreg,libs,imps,inc,_,templ') -> do       (l',templDecl)

@@ -197,7 +197,7 @@   deriving (Show, Generic, NFData, Binary, Hashable)  -- | Component instantiation hole. First argument indicates which function argument--- to instantiate. Second argument corresponds to output and input assignments,+-- to instantiate. Third argument corresponds to output and input assignments, -- where the first element is the output assignment, and the subsequent elements -- are the consecutive input assignments. --

@@ -38,6 +38,7 @@  import qualified Control.Lens                     as Lens import           Data.List                        (mapAccumR)+import           Data.List.Extra                  (zipEqual) import qualified Data.Maybe                       as Maybe  import           PrelNames                        (boolTyConKey)@@ -255,9 +256,9 @@             (Just apDictTc)    = lookupUniqMap apDictTcNm tcm             [apDictCon]        = tyConDataCons apDictTc             (Just apDictIdTys) = dataConInstArgTys apDictCon [fTy]-            (uniqs1,apDictIds@[functorDictId,pureId,apId,_,_]) =+            (uniqs1,apDictIds@[functorDictId,pureId,apId,_,_,_]) =               mapAccumR mkUniqInternalId (uniqs0,is1)-                (zip ["functorDict","pure","ap","apConstL","apConstR"]+                (zipEqual ["functorDict","pure","ap","liftA2","apConstL","apConstR"]                      apDictIdTys)              (TyConApp funcDictTcNm _) = tyView (head apDictIdTys)@@ -266,7 +267,7 @@             (Just funcDictIdTys) = dataConInstArgTys funcDictCon [fTy]             (uniqs2,funcDicIds@[fmapId,_]) =               mapAccumR mkUniqInternalId uniqs1-                (zip ["fmap","fmapConst"] funcDictIdTys)+                (zipEqual ["fmap","fmapConst"] funcDictIdTys)              apPat    = DataPat apDictCon   [] apDictIds             fnPat    = DataPat funcDictCon [] funcDicIds

@@ -352,7 +352,7 @@     -- Eliminate free type variables if possible     go :: InScopeSet -> TyConMap -> (Pat, Term) -> NormalizeSession (Pat, Term)     go is2 tcm alt@(DataPat dc exts0 xs0, term0) =-      case solveNonAbsurds tcm (altEqs tcm alt) of+      case solveNonAbsurds tcm (mkVarSet exts0) (altEqs tcm alt) of         -- No equations solved:         [] -> return alt         -- One or more equations solved:@@ -462,6 +462,10 @@ inlineNonRep _ e = return e {-# SCC inlineNonRep #-} ++caseCon :: HasCallStack => NormRewrite+caseCon = apply "caseOneAlt" (const caseOneAlt) >-! caseCon'+ -- | Specialize a Case-decomposition (replace by the RHS of an alternative) if -- the subject is (an application of) a DataCon; or if there is only a single -- alternative that doesn't reference variables bound by the pattern.@@ -491,8 +495,8 @@ -- let a1 = f a b -- in  h a1 -- @-caseCon :: HasCallStack => NormRewrite-caseCon ctx@(TransformContext is0 _) e@(Case subj ty alts) = do+caseCon' :: HasCallStack => NormRewrite+caseCon' ctx@(TransformContext is0 _) e@(Case subj ty alts) = do  tcm <- Lens.view tcCache  case collectArgsTicks subj of   -- The subject is an applied data constructor@@ -501,7 +505,7 @@      let       -- Create the substitution environment for all the existential       -- type variables.-      exTysList = zip tvs (drop (length (dcUnivTyVars dc)) (Either.rights args))+      exTysList = List.zipEqual 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,@@ -512,7 +516,7 @@       -- 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)+                $ List.zipEqual xs1 (Either.lefts args)       binds1 = map (second (`mkTicks` ticks)) binds      altE1 <-        case binds1 of@@ -607,6 +611,10 @@                                 , "EmptyCase"] ->         let e1 = mkApps (mkTicks (Prim pInfo) ticks) [Right ty]         in changed e1+      (Prim pInfo,_:callStack:msg:_,_)+        | primName pInfo == "Clash.XException.errorX"+        -> let e1 = mkApps (Prim pInfo) [Right ty,callStack,msg]+            in changed e1       -- WHNF of subject is non of the above, so either a variable reference,       -- or a primitive for which the evaluator doesn't have any evaluation       -- rules.@@ -667,8 +675,8 @@   -- alternative, and pick that one.   _ -> caseOneAlt e -caseCon _ e = return e-{-# SCC caseCon #-}+caseCon' _ e = return e+{-# SCC caseCon' #-}  {- [Note: Name re-creation] The names of heap bound variables are safely generate with mkUniqSystemId in Clash.Core.Evaluator.newLetBinding.@@ -689,7 +697,7 @@     , l >= ((-2)^(63::Int)) &&  l < 2^(63::Int)     = let fvs       = Lens.foldMapOf freeLocalIds unitVarSet e           (binds,_) = List.partition ((`elemVarSet` fvs) . fst)-                    $ zip xs [Literal (IntLiteral l)]+                    $ List.zipEqual xs [Literal (IntLiteral l)]           e' = case binds of                  [] -> e                  _  -> Letrec binds e@@ -701,7 +709,7 @@           bv        = PV.Vector 0 (BA.sizeofByteArray ba') ba'           fvs       = Lens.foldMapOf freeLocalIds unitVarSet e           (binds,_) = List.partition ((`elemVarSet` fvs) . fst)-                    $ zip xs [Literal (ByteArrayLiteral bv)]+                    $ List.zipEqual xs [Literal (ByteArrayLiteral bv)]           e' = case binds of                  [] -> e                  _  -> Letrec binds e@@ -713,7 +721,7 @@           bv        = PV.Vector 0 (BA.sizeofByteArray ba') ba'           fvs       = Lens.foldMapOf freeLocalIds unitVarSet e           (binds,_) = List.partition ((`elemVarSet` fvs) . fst)-                    $ zip xs [Literal (ByteArrayLiteral bv)]+                    $ List.zipEqual xs [Literal (ByteArrayLiteral bv)]           e' = case binds of                  [] -> e                  _  -> Letrec binds e@@ -735,7 +743,7 @@     , l >= 0 && l < 2^(64::Int)     = let fvs       = Lens.foldMapOf freeLocalIds unitVarSet e           (binds,_) = List.partition ((`elemVarSet` fvs) . fst)-                    $ zip xs [Literal (WordLiteral l)]+                    $ List.zipEqual xs [Literal (WordLiteral l)]           e' = case binds of                  [] -> e                  _  -> Letrec binds e@@ -747,7 +755,7 @@           bv        = PV.Vector 0 (BA.sizeofByteArray ba') ba'           fvs       = Lens.foldMapOf freeLocalIds unitVarSet e           (binds,_) = List.partition ((`elemVarSet` fvs) . fst)-                    $ zip xs [Literal (ByteArrayLiteral bv)]+                    $ List.zipEqual xs [Literal (ByteArrayLiteral bv)]           e' = case binds of                  [] -> e                  _  -> Letrec binds e@@ -776,8 +784,10 @@     | otherwise     -> return e -caseOneAlt (Case _ _ alts@((_,alt):_:_))+caseOneAlt (Case _ _ alts@((pat,alt):_:_))   | all ((== alt) . snd) (tail alts)+  , (tvs,xs) <- patIds pat+  , (coerce tvs ++ coerce xs) `localVarsDoNotOccurIn` alt   = changed alt  caseOneAlt e = return e@@ -2971,4 +2981,3 @@   isErr _ = False  isPrimError _ = return False-

@@ -73,6 +73,7 @@ import           Control.Lens                    hiding (Indexed, assign) import           Control.Monad.State import           Data.List                       (intersperse)+import           Data.List.Extra                 (zipEqual) import           Data.Maybe                      (fromMaybe) import           Data.Semigroup                  hiding (Product) import           Data.Semigroup.Monad@@ -363,10 +364,10 @@       inNames' <- mapM newName inNames       let exprIdent = Identifier (exprFn inNames') Nothing       sequenceOf_ each [ addDeclaration (NetDecl Nothing nm t)-                       | (nm,t) <- zip inNames' fromTypes ]+                       | (nm,t) <- zipEqual inNames' fromTypes ]       addDeclaration (Assignment outName exprIdent)       pure [ TExpr t (Identifier nm Nothing)-           | (nm,t) <- zip inNames' fromTypes ]+           | (nm,t) <- zipEqual inNames' fromTypes ] outputFn _ outType _ _ texpr =   error $ "outputFn: the expression " <> show texpr   <> " must be an Identifier with type " <> show outType

@@ -25,6 +25,10 @@  import Control.Applicative (liftA2) +#if defined(DEBUG)+import GHC.Stack (HasCallStack)+#endif+ -- | Monadic version of 'Data.List.mapAccumL' mapAccumLM   :: (Monad m)@@ -75,12 +79,19 @@ -- | Zip two lists of equal length -- -- NB Errors out for a DEBUG compiler when the two lists are not of equal length+#if !defined(DEBUG) zipEqual   :: [a] -> [b] -> [(a,b)]-#if !defined(DEBUG) zipEqual = zip+{-# INLINE zipEqual #-} #else-zipEqual [] [] = []-zipEqual (a:as) (b:bs) = (a,b) : zipEqual as bs-zipEqual _ _ = error "zipEqual"+zipEqual ::+  HasCallStack =>+  [a] -> [b] -> [(a,b)]+zipEqual = go+  where+    go [] [] = []+    go (a:as) (b:bs) = (a,b) : go as bs+    go (_:_) [] = error "zipEqual: left list is longer"+    go [] (_:_) = error "zipEqual: right list is longer" #endif