clash-lib 1.4.0 → 1.4.1

raw patch · 10 files changed

+326/−136 lines, 10 filesdep ~clash-preludePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: clash-prelude

API changes (from Hackage documentation)

Files

• CHANGELOG.md +17/−1
• clash-lib.cabal +3/−3
• prims/vhdl/Clash_Sized_Internal_BitVector.primitives +4/−4
• src/Clash/Core/Type.hs +4/−1
• src/Clash/Core/Util.hs +116/−10
• src/Clash/Driver.hs +1/−1
• src/Clash/Normalize/DEC.hs +91/−24
• src/Clash/Normalize/Strategy.hs +1/−1
• src/Clash/Normalize/Transformations.hs +87/−25
• src/Clash/Rewrite/Util.hs +2/−66

@@ -1,5 +1,21 @@ # Changelog for the Clash project-## 1.4.0 *March 12th 2020*++## 1.4.1 *April 6th 2021*+Fixed:++ * Broken VHDL primitive template for setSlice# [#1715](https://github.com/clash-lang/clash-compiler/issues/1715)+ * Unable to reduce nested type families [#1721](https://github.com/clash-lang/clash-compiler/issues/1721)+ * DEC transformation fails for functions applied to more than 62 arguments [#1669](https://github.com/clash-lang/clash-compiler/issues/1669)+ * Erroneous examples in BlockRam.File and ROM.File documentation [#1608](https://github.com/clash-lang/clash-compiler/issues/1608)+ * Blackboxes of `Clash.Sized.Vector` functions error on vectors containing `Clocks`, `Reset`, or `Enable` [#1606](https://github.com/clash-lang/clash-compiler/issues/1606)+ * `Clash.Signal.Delayed.delayI` cannot be reset, the `HiddenReset` constraint was unintentional. Asserting its reset has never worked. Removed the constraint [#1739](https://github.com/clash-lang/clash-compiler/pull/1739).+ * Annotate attributes cannot use type families [#1742](https://github.com/clash-lang/clash-compiler/issues/1742)++Changed:++ * `Clash.Prelude.ROM.File.romFile` now takes an `Enum addr => addr` as address argument, making it actually useful. [#407](https://github.com/clash-lang/clash-compiler/issues/407)++## 1.4.0 *March 12th 2021* Highlighted changes (repeated in other categories):    * Clash no longer disables the monomorphism restriction. See [#1270](https://github.com/clash-lang/clash-compiler/issues/1270), and mentioned issues, as to why. This can cause, among other things, certain eta-reduced descriptions of sequential circuits to no longer type-check. See [#1349](https://github.com/clash-lang/clash-compiler/pull/1349) for code hints on what kind of changes to make to your own code in case it no longer type-checks due to this change.

@@ -1,6 +1,6 @@ Cabal-version:        2.2 Name:                 clash-lib-Version:              1.4.0+Version:              1.4.1 Synopsis:             Clash: a functional hardware description language - As a library Description:   Clash is a functional hardware description language that borrows both its@@ -139,12 +139,12 @@                       aeson-pretty            >= 0.8      && < 0.9,                       ansi-terminal           >= 0.8.0.0  && < 0.12,                       array,-                      attoparsec              >= 0.10.4.0 && < 0.14,+                      attoparsec              >= 0.10.4.0 && < 0.15,                       base                    >= 4.11     && < 5,                       base16-bytestring       >= 0.1.1    && < 1.1,                       binary                  >= 0.8.5    && < 0.11,                       bytestring              >= 0.10.0.2 && < 0.12,-                      clash-prelude           == 1.4.0,+                      clash-prelude           == 1.4.1,                       concurrent-supply       >= 0.1.7    && < 0.2,                       containers              >= 0.5.0.0  && < 0.7,                       cryptohash-sha256       >= 0.11     && < 0.12,

@@ -309,11 +309,11 @@            -> BitVector (m + 1 + i)"     , "template" : "-- setSlice begin-~GENSYM[setSlice][0] : process(~VAR[bv][0]~VARS[4])-  variable ~GENSYM[ivec][1] : ~TYP[0];+~GENSYM[setSlice][0] : process(~VAR[bv][1]~VARS[4])+  variable ~GENSYM[ivec][1] : ~TYP[1]; begin-  ~SYM[1] := ~ARG[1];-  ~SYM[1](~LIT[2] downto ~LIT[3]) := ~VAR[bv][4];+  ~SYM[1] := ~VAR[bv][1];+  ~SYM[1](~LIT[2] downto ~LIT[3]) := ~ARG[4];   ~RESULT <= ~SYM[1]; end process; -- setSlice end"

@@ -490,7 +490,10 @@     -- to different types, so this is OK for our purposes.     go (AppTy a1 r1) (AppTy a2 r2) = do       s1 <- funSubst tcm (Just s) (a1, a2)-      funSubst tcm (Just s1) (r1, r2)+      funSubst tcm (Just s1)+                   ( r1+                   , argView tcm r2 -- See [Note: Eager type families]+                   )      go ty1@(ConstTy _) ty2 =       -- Looks through AnnType

@@ -7,16 +7,18 @@ -}  {-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-}  module Clash.Core.Util where  import           Control.Concurrent.Supply     (Supply, freshId) import qualified Control.Lens                  as Lens-import Control.Monad.Trans.Except              (Except, throwE)+import Control.Monad.Trans.Except              (Except, throwE, runExcept) import qualified Data.HashSet                  as HashSet import qualified Data.Graph                    as Graph import Data.List                               (foldl', mapAccumR)@@ -46,6 +48,7 @@ import Clash.Core.Pretty                 (showPpr) import Clash.Core.Subst import Clash.Core.Term+import Clash.Core.TermInfo               (termType) import Clash.Core.TyCon                  (TyConMap, tyConDataCons) import Clash.Core.Type import Clash.Core.TysPrim                (typeNatKind)@@ -458,24 +461,37 @@ tyLitShow _ (LitTy (NumTy s))        = return (show s) tyLitShow _ ty = throwE $ $(curLoc) ++ "Cannot reduce to a string:\n" ++ showPpr ty +-- | Helper existential for 'shouldSplit', contains a function that:+--+-- 1. given a term of a type that should be split,+-- 2. creates projections of that term for all the constructor arguments+data Projections where+  Projections :: (forall m . MonadUnique m => InScopeSet -> Term -> m [Term])+              -> Projections+ -- | Determine whether we should split away types from a product type, i.e. -- clocks should always be separate arguments, and not part of a product. shouldSplit   :: TyConMap   -> Type   -- ^ Type to examine-  -> Maybe (Term,[Type])+  -> Maybe ([Term] -> Term, Projections, [Type])   -- ^ If we want to split values of the given type then we have /Just/:   --   -- 1. The (type-applied) data-constructor which, when applied to values of-  --    the types in 2., creates a value of the examined type+  --    the types in 3., creates a value of the examined type   ---  -- 2. The arguments types of the product we are trying to split.+  -- 2. Function that give a term of the type we need to split, creates projections+  --    of that term for all the types in 3.   --+  -- 3. The arguments types of the product we are trying to split.+  --   -- Note that we only split one level at a time (although we check all the way   -- down), e.g. given /(Int, (Clock, Bool))/ we return:   ---  -- > Just ((,) @Int @(Clock, Bool), [Int, (Clock, Bool)])+  -- > Just ( (,) @Int @(Clock, Bool)+  -- >      , \s -> [case s of (a,b) -> a, case s of (a,b) -> b]+  -- >      , [Int, (Clock, Bool)])   --   -- An outer loop is required to subsequently split the /(Clock, Bool)/ tuple. shouldSplit tcm (tyView ->  TyConApp (nameOcc -> "Clash.Explicit.SimIO.SimIO") [tyArg]) =@@ -487,17 +503,51 @@ shouldSplit0   :: TyConMap   -> TypeView-  -> Maybe (Term,[Type])+  -> Maybe ([Term] -> Term, Projections, [Type]) shouldSplit0 tcm (TyConApp tcNm tyArgs)   | Just tc <- lookupUniqMap tcNm tcm   , [dc] <- tyConDataCons tc-  , let dcArgs  = substArgTys dc tyArgs+  , let dcArgs = substArgTys dc tyArgs+  , let dcArgsLen = length dcArgs+  , dcArgsLen > 1   , let dcArgVs = map (tyView . coreView tcm) dcArgs   = if any shouldSplitTy dcArgVs && not (isHidden tcNm tyArgs) then-      Just (mkApps (Data dc) (map Right tyArgs), dcArgs)+      Just ( mkApps (Data dc) . (map Right tyArgs ++) . map Left+           , Projections+             (\is0 subj -> mapM (mkSelectorCase ($(curLoc) ++ "splitArg") is0 tcm subj 1)+                                [0..dcArgsLen - 1])+           , dcArgs+           )     else       Nothing+  | "Clash.Sized.Vector.Vec" <- nameOcc tcNm+  , [nTy,argTy] <- tyArgs+  , Right n <- runExcept (tyNatSize tcm nTy)+  , n > 1+  , Just tc <- lookupUniqMap tcNm tcm+  , [nil,cons] <- tyConDataCons tc+  = if shouldSplitTy (tyView (coreView tcm argTy)) then+      Just ( mkVec nil cons argTy n+           , Projections (\is0 subj -> mapM (mkVecSelector is0 subj) [0..n-1])+           , replicate (fromInteger n) argTy)+    else+      Nothing  where+  -- Project the n'th value out of a vector+  --+  -- >>> mkVecSelector subj 0+  -- case subj of Cons x xs -> x+  --+  -- >>> mkVecSelector subj 2+  -- case (case (case subj of Cons x xs -> xs) of Cons x xs -> xs) of Cons x xs -> x+  mkVecSelector :: forall m . MonadUnique m => InScopeSet -> Term -> Integer -> m Term+  mkVecSelector is0 subj 0 =+    mkSelectorCase ($(curLoc) ++ "mkVecSelector") is0 tcm subj 2 1++  mkVecSelector is0 subj !n = do+    subj1 <- mkSelectorCase ($(curLoc) ++ "mkVecSelector") is0 tcm subj 2 2+    mkVecSelector is0 subj1 (n-1)+   shouldSplitTy :: TypeView -> Bool   shouldSplitTy ty = isJust (shouldSplit0 tcm ty) || splitTy ty @@ -554,8 +604,8 @@ splitShouldSplit tcm = foldr go []  where   go ty rest = case shouldSplit tcm ty of-    Just (_,tys) -> splitShouldSplit tcm tys ++ rest-    Nothing      -> ty : rest+    Just (_,_,tys) -> splitShouldSplit tcm tys ++ rest+    Nothing        -> ty : rest  -- | Strip implicit parameter wrappers (IP) stripIP :: Type -> Type@@ -601,3 +651,59 @@                             (Set.elems (Lens.setOf freeLocalIds e) )                   in  ((i,e),varUniq i,fvs))) {-# SCC sccLetBindings #-}++-- | Make a case-decomposition that extracts a field out of a (Sum-of-)Product type+mkSelectorCase+  :: HasCallStack+  => MonadUnique m+  => String -- ^ Name of the caller of this function+  -> InScopeSet+  -> TyConMap -- ^ TyCon cache+  -> Term -- ^ Subject of the case-composition+  -> Int -- ^ n'th DataCon+  -> Int -- ^ n'th field+  -> m Term+mkSelectorCase caller inScope tcm scrut dcI fieldI = go (termType tcm scrut)+  where+    go (coreView1 tcm -> Just ty') = go ty'+    go scrutTy@(tyView -> TyConApp tc args) =+      case tyConDataCons (lookupUniqMap' tcm tc) of+        [] -> cantCreate $(curLoc) ("TyCon has no DataCons: " ++ show tc ++ " " ++ showPpr tc) scrutTy+        dcs | dcI > length dcs -> cantCreate $(curLoc) "DC index exceeds max" scrutTy+            | otherwise -> do+          let dc = indexNote ($(curLoc) ++ "No DC with tag: " ++ show (dcI-1)) dcs (dcI-1)+          let (Just fieldTys) = dataConInstArgTysE inScope tcm dc args+          if fieldI >= length fieldTys+            then cantCreate $(curLoc) "Field index exceed max" scrutTy+            else do+              wildBndrs <- mapM (mkWildValBinder inScope) fieldTys+              let ty = indexNote ($(curLoc) ++ "No DC field#: " ++ show fieldI) fieldTys fieldI+              selBndr <- mkInternalVar inScope "sel" ty+              let bndrs  = take fieldI wildBndrs ++ [selBndr] ++ drop (fieldI+1) wildBndrs+                  pat    = DataPat dc (dcExtTyVars dc) bndrs+                  retVal = Case scrut ty [ (pat, Var selBndr) ]+              return retVal+    go scrutTy = cantCreate $(curLoc) ("Type of subject is not a datatype: " ++ showPpr scrutTy) scrutTy++    cantCreate loc info scrutTy = error $ loc ++ "Can't create selector " ++ show (caller,dcI,fieldI) ++ " for: (" ++ showPpr scrut ++ " :: " ++ showPpr scrutTy ++ ")\nAdditional info: " ++ info++-- | Make a binder that should not be referenced+mkWildValBinder+  :: (MonadUnique m)+  => InScopeSet+  -> Type+  -> m Id+mkWildValBinder is = mkInternalVar is "wild"++-- | Make a new, unique, identifier+mkInternalVar+  :: (MonadUnique m)+  => InScopeSet+  -> OccName+  -- ^ Name of the identifier+  -> KindOrType+  -> m Id+mkInternalVar inScope name ty = do+  i <- getUniqueM+  let nm = mkUnsafeInternalName name i+  return (uniqAway inScope (mkLocalId ty nm))

@@ -168,7 +168,7 @@      = PortName "" : go res (p:ps)    | otherwise =     case shouldSplit tcm a of-      Just (_,argTys@(_:_:_)) ->+      Just (_,_,argTys@(_:_:_)) ->         -- Port must be split up into 'n' pieces.. can it?         case p of           PortProduct nm portNames0 ->

@@ -55,12 +55,24 @@ import qualified Data.Maybe                       as Maybe import           Data.Monoid                      (All (..)) +#if MIN_VERSION_ghc(8,10,0)+import           GHC.Hs.Utils                     (chunkify,mkChunkified)+#else+import           HsUtils                          (chunkify,mkChunkified)+#endif++#if MIN_VERSION_ghc(9,0,0)+import           GHC.Settings.Constants           (mAX_TUPLE_SIZE)+#else+import           Constants                        (mAX_TUPLE_SIZE)+#endif+ #if EXPERIMENTAL_EVALUATOR import           System.IO.Unsafe #endif  -- internal-import Clash.Core.DataCon    (DataCon, dcTag)+import Clash.Core.DataCon    (DataCon)  #if EXPERIMENTAL_EVALUATOR import Clash.Core.PartialEval@@ -75,16 +87,15 @@   (LetBinding, Pat (..), PrimInfo (..), Term (..), TickInfo (..), collectArgs,    collectArgsTicks, mkApps, mkTicks, patIds) import Clash.Core.TermInfo   (termType)-import Clash.Core.TyCon      (tyConDataCons)+import Clash.Core.TyCon      (TyConMap, TyConName, tyConDataCons) import Clash.Core.Type       (Type, isPolyFunTy, mkTyConApp, splitFunForallTy)-import Clash.Core.Util       (sccLetBindings)-import Clash.Core.Var        (isGlobalId)+import Clash.Core.Util       (mkInternalVar, mkSelectorCase, sccLetBindings)+import Clash.Core.Var        (isGlobalId, isLocalId) import Clash.Core.VarEnv   (InScopeSet, elemInScopeSet, extendInScopeSetList, notElemInScopeSet, unionInScope) import Clash.Normalize.Types (NormalizeState) import Clash.Rewrite.Types-import Clash.Rewrite.Util    (mkInternalVar, mkSelectorCase,-                              isUntranslatableType)+import Clash.Rewrite.Util    (isUntranslatableType) import Clash.Rewrite.WorkFree (isConstant) import Clash.Unique          (lookupUniqMap) import Clash.Util@@ -389,29 +400,25 @@   -> RewriteMonad NormalizeState (Maybe LetBinding,[Term]) disJointSelProj _ _ (Leaf []) = return (Nothing,[]) disJointSelProj inScope argTys cs = do+    tcm    <- Lens.view tcCache+    tupTcm <- Lens.view tupleTcCache     let maxIndex = length argTys - 1         css = map (\i -> fmap ((:[]) . (!!i)) cs) [0..maxIndex]     (untran,tran) <- List.partitionM (isUntranslatableType False . snd) (zip [0..] argTys)     let untranCs   = map (css!!) (map fst untran)-        untranSels = zipWith (\(_,ty) cs' -> genCase ty Nothing []  cs')+        untranSels = zipWith (\(_,ty) cs' -> genCase tcm tupTcm ty [ty]  cs')                              untran untranCs     (lbM,projs) <- case tran of       []       -> return (Nothing,[])-      [(i,ty)] -> return (Nothing,[genCase ty Nothing [] (css!!i)])+      [(i,ty)] -> return (Nothing,[genCase tcm tupTcm ty [ty] (css!!i)])       tys      -> do-        tcm    <- Lens.view tcCache-        tupTcm <- Lens.view tupleTcCache         let m            = length tys-            Just tupTcNm = IM.lookup m tupTcm-            Just tupTc   = lookupUniqMap tupTcNm tcm-            [tupDc]      = tyConDataCons tupTc             (tyIxs,tys') = unzip tys-            tupTy        = mkTyConApp tupTcNm tys'+            tupTy        = mkBigTupTy tcm tupTcm tys'             cs'          = fmap (\es -> map (es !!) tyIxs) cs-            djCase       = genCase tupTy (Just tupDc) tys' cs'+            djCase       = genCase tcm tupTcm tupTy tys' cs'         scrutId <- mkInternalVar inScope "tupIn" tupTy-        projections <- mapM (mkSelectorCase ($(curLoc) ++ "disJointSelProj")-                                            inScope tcm (Var scrutId) (dcTag tupDc)) [0..m-1]+        projections <- mapM (mkBigTupSelector inScope tcm tupTcm (Var scrutId) tys') [0..m-1]         return (Just (scrutId,djCase),projections)     let selProjs = tranOrUnTran 0 (zip (map fst untran) untranSels) projs @@ -437,7 +444,7 @@     Left tm  -> getAll (Lens.foldMapOf (termFreeVars' isLocallyBound)                                        (const (All False)) tm) -  isLocallyBound v = v `notElemInScopeSet` inScope+  isLocallyBound v = isLocalId v && v `notElemInScopeSet` inScope  -- | Create a list of arguments given a map of positions to common arguments, -- and a list of arguments@@ -453,17 +460,16 @@  -- | Create a case-expression that selects between the distinct arguments given -- a case-tree-genCase :: Type -- ^ Type of the alternatives-        -> Maybe DataCon -- ^ DataCon to pack multiple arguments+genCase :: TyConMap+        -> IM.IntMap TyConName+        -> Type -- ^ Type of the alternatives         -> [Type] -- ^ Types of the arguments         -> CaseTree [Term] -- ^ CaseTree of arguments         -> Term-genCase ty dcM argTys = go+genCase tcm tupTcm ty argTys = go   where     go (Leaf tms) =-      case dcM of-        Just dc -> mkApps (Data dc) (map Right argTys ++ map Left tms)-        _ -> head tms+      mkBigTupTm tcm tupTcm (List.zipEqual argTys tms)      go (LB lb ct) =       Letrec lb (go ct)@@ -477,6 +483,67 @@      go (Branch scrut pats) =       Case scrut ty (map (second go) pats)++-- | Lookup the TyConName and DataCon for a tuple of size n+findTup :: TyConMap -> IM.IntMap TyConName -> Int -> (TyConName,DataCon)+findTup tcm tupTcm n = (tupTcNm,tupDc)+  where+    tupTcNm      = Maybe.fromMaybe (error $ $curLoc ++ "Can't find " ++ show n ++ "-tuple") $ IM.lookup n tupTcm+    Just tupTc   = lookupUniqMap tupTcNm tcm+    [tupDc]      = tyConDataCons tupTc++mkBigTupTm :: TyConMap -> IM.IntMap TyConName -> [(Type,Term)] -> Term+mkBigTupTm tcm tupTcm args = snd $ mkBigTup tcm tupTcm args++mkSmallTup,mkBigTup :: TyConMap -> IM.IntMap TyConName -> [(Type,Term)] -> (Type,Term)+mkSmallTup _ _ [] = error $ $curLoc ++ "mkSmallTup: Can't create 0-tuple"+mkSmallTup _ _ [(ty,tm)] = (ty,tm)+mkSmallTup tcm tupTcm args = (ty,tm)+  where+    (argTys,tms) = unzip args+    (tupTcNm,tupDc) = findTup tcm tupTcm (length args)+    tm = mkApps (Data tupDc) (map Right argTys ++ map Left tms)+    ty = mkTyConApp tupTcNm argTys++mkBigTup tcm tupTcm = mkChunkified (mkSmallTup tcm tupTcm)++mkSmallTupTy,mkBigTupTy+  :: TyConMap+  -> IM.IntMap TyConName+  -> [Type]+  -> Type+mkSmallTupTy _ _ [] = error $ $curLoc ++ "mkSmallTupTy: Can't create 0-tuple"+mkSmallTupTy _ _ [ty] = ty+mkSmallTupTy tcm tupTcm tys = mkTyConApp tupTcNm tys+  where+    m = length tys+    (tupTcNm,_) = findTup tcm tupTcm m++mkBigTupTy tcm tupTcm = mkChunkified (mkSmallTupTy tcm tupTcm)++mkSmallTupSelector,mkBigTupSelector+  :: MonadUnique m+  => InScopeSet+  -> TyConMap+  -> IM.IntMap TyConName+  -> Term+  -> [Type]+  -> Int+  -> m Term+mkSmallTupSelector _ _ _ scrut [_] 0 = return scrut+mkSmallTupSelector _ _ _ _     [_] n = error $ $curLoc ++ "mkSmallTupSelector called with one type, but to select " ++ show n+mkSmallTupSelector inScope tcm _ scrut _ n = mkSelectorCase ($curLoc ++ "mkSmallTupSelector") inScope tcm scrut 1 n++mkBigTupSelector inScope tcm tupTcm scrut tys n = go (chunkify tys)+  where+    go [_] = mkSmallTupSelector inScope tcm tupTcm scrut tys n+    go tyss = do+      let (nOuter,nInner) = divMod n mAX_TUPLE_SIZE+          tyss' = map (mkSmallTupTy tcm tupTcm) tyss+      outer <- mkSmallTupSelector inScope tcm tupTcm scrut tyss' nOuter+      inner <- mkSmallTupSelector inScope tcm tupTcm outer (tyss List.!! nOuter) nInner+      return inner+  -- | Determine if a term in a function position is interesting to lift out of -- of a case-expression.

@@ -60,7 +60,7 @@                                       ,("letFlat"        , flattenLet)])                  >-> rmDeadcode >-> letTL     splitArgs  = topdownR (apply "separateArguments" separateArguments) !->-                 topdownR (apply "caseCon" caseCon)+                 bottomupR (apply "caseCon" caseCon)     bindSimIO  = topdownR (apply "bindSimIO" inlineSimIO)  

@@ -117,11 +117,11 @@                                               normalizeType, splitFunForallTy,                                               splitFunTy,                                               tyView, mkPolyFunTy, coreView,-                                              LitTy (..), coreView1)+                                              LitTy (..), coreView1, mkTyConApp) import           Clash.Core.TyCon            (TyConMap, tyConDataCons) import           Clash.Core.Util-  ( isSignalType, mkVec, tyNatSize, undefinedTm,-   shouldSplit, inverseTopSortLetBindings)+  (Projections (..), isSignalType, mkVec, tyNatSize, undefinedTm,+   shouldSplit, inverseTopSortLetBindings, mkInternalVar, mkSelectorCase) import           Clash.Core.Var   (Id, TyVar, Var (..), isGlobalId, isLocalId, mkLocalId) import           Clash.Core.VarEnv@@ -2142,6 +2142,26 @@ -- * Clash.Sized.RTree.treplicate -- * Clash.Sized.Internal.BitVector.split# -- * Clash.Sized.Internal.BitVector.eq#+--+-- Note [Unroll shouldSplit types]+-- 1. Certain higher-order functions over Vec, such as map, have specialized+-- code-paths to turn them into generate-for loops in HDL, instead of having to+-- having to unroll/inline their recursive definitions, e.g. Clash.Sized.Vector.map+--+-- 2. Clash, in general, translates Haskell product types to VHDL records. This+-- mostly works out fine, there is however one exception: certain synthesis+-- tools, and some HDL simulation tools (like verilator), do not like it when+-- the clock (and certain other global control signals) is contained in a+-- record type; they want them to be separate inputs to the entity/module.+-- And Clash actually does some transformations to try to ensure that values of+-- type Clock do not end up in a VHDL record type.+--+-- The problem is that the transformations in 2. never took into account the+-- specialized code-paths in 1. Making the code-paths in 1. aware of the+-- transformations in 2. is really not worth the effort for such a niche case.+-- It's easier to just unroll the recursive definitions.+--+-- See https://github.com/clash-lang/clash-compiler/issues/1606 reduceNonRepPrim :: HasCallStack => NormRewrite reduceNonRepPrim c@(TransformContext is0 ctx) e@(App _ _) | (Prim p, args, ticks) <- collectArgsTicks e = do   tcm <- Lens.view tcCache@@ -2157,12 +2177,18 @@     tv -> let argLen = length args in case primName p of       "Clash.Sized.Vector.zipWith" | argLen == 7 -> do         let [lhsElTy,rhsElty,resElTy,nTy] = Either.rights args+            TyConApp vecTcNm _ = tv+            lhsTy = mkTyConApp vecTcNm [nTy,lhsElTy]+            rhsTy = mkTyConApp vecTcNm [nTy,rhsElty]         case runExcept (tyNatSize tcm nTy) of           Right n -> do             shouldReduce1 <- List.orM [ pure (ultra || n < 2)                                  , shouldReduce ctx                                  , List.anyM isUntranslatableType_not_poly-                                        [lhsElTy,rhsElty,resElTy] ]+                                        [lhsElTy,rhsElty,resElTy]+                                 -- Note [Unroll shouldSplit types]+                                 , pure (any (Maybe.isJust . shouldSplit tcm)+                                             [lhsTy,rhsTy,eTy]) ]             if shouldReduce1                then let [fun,lhsArg,rhsArg] = Either.lefts args                     in  (`mkTicks` ticks) <$>@@ -2171,12 +2197,17 @@           _ -> return e       "Clash.Sized.Vector.map" | argLen == 5 -> do         let [argElTy,resElTy,nTy] = Either.rights args+            TyConApp vecTcNm _ = tv+            argTy = mkTyConApp vecTcNm [nTy,argElTy]         case runExcept (tyNatSize tcm nTy) of           Right n -> do             shouldReduce1 <- List.orM [ pure (ultra || n < 2 )                                  , shouldReduce ctx                                  , List.anyM isUntranslatableType_not_poly-                                        [argElTy,resElTy] ]+                                        [argElTy,resElTy]+                                 -- Note [Unroll shouldSplit types]+                                 , pure (any (Maybe.isJust . shouldSplit tcm)+                                             [argTy,eTy]) ]             if shouldReduce1                then let [fun,arg] = Either.lefts args                     in  (`mkTicks` ticks) <$> reduceMap c p n argElTy resElTy fun arg@@ -2190,27 +2221,31 @@             in  (`mkTicks` ticks) <$> reduceTraverse c n aTy fTy bTy dict fun arg           _ -> return e       "Clash.Sized.Vector.fold" | argLen == 4 -> do-        let [nTy,aTy] = Either.rights args+        let ([fun,arg],[nTy,aTy]) = Either.partitionEithers args+            argTy = termType tcm arg         case runExcept (tyNatSize tcm nTy) of           Right n -> do             shouldReduce1 <- List.orM [ pure (ultra || n == 0)                                  , shouldReduce ctx-                                 , isUntranslatableType_not_poly aTy ]+                                 , isUntranslatableType_not_poly aTy+                                 -- Note [Unroll shouldSplit types]+                                 , pure (Maybe.isJust (shouldSplit tcm argTy))]             if shouldReduce1 then-              let [fun,arg] = Either.lefts args-              in  (`mkTicks` ticks) <$> reduceFold c (n + 1) aTy fun arg+              (`mkTicks` ticks) <$> reduceFold c (n + 1) aTy fun arg             else return e           _ -> return e       "Clash.Sized.Vector.foldr" | argLen == 6 ->-        let [aTy,bTy,nTy] = Either.rights args+        let ([fun,start,arg],[aTy,bTy,nTy]) = Either.partitionEithers args+            argTy = termType tcm arg         in  case runExcept (tyNatSize tcm nTy) of           Right n -> do             shouldReduce1 <- List.orM [ pure ultra                                  , shouldReduce ctx-                                 , List.anyM isUntranslatableType_not_poly [aTy,bTy] ]+                                 , List.anyM isUntranslatableType_not_poly [aTy,bTy]+                                 -- Note [Unroll shouldSplit types]+                                 , pure (Maybe.isJust (shouldSplit tcm argTy)) ]             if shouldReduce1-              then let [fun,start,arg] = Either.lefts args-                   in  (`mkTicks` ticks) <$> reduceFoldr c p n aTy fun start arg+              then (`mkTicks` ticks) <$> reduceFoldr c p n aTy fun start arg               else return e           _ -> return e       "Clash.Sized.Vector.dfold" | argLen == 8 ->@@ -2227,7 +2262,9 @@                 | m == 0 -> changed lArg                 | otherwise -> do                     shouldReduce1 <- List.orM [ shouldReduce ctx-                                         , isUntranslatableType_not_poly aTy ]+                                         , isUntranslatableType_not_poly aTy+                                         -- Note [Unroll shouldSplit types]+                                         , pure (Maybe.isJust (shouldSplit tcm eTy)) ]                     if shouldReduce1                        then (`mkTicks` ticks) <$> reduceAppend is0 n m aTy lArg rArg                        else return e@@ -2235,10 +2272,13 @@       "Clash.Sized.Vector.head" | argLen == 3 -> do         let [nTy,aTy] = Either.rights args             [vArg]    = Either.lefts args+            argTy     = termType tcm vArg         case runExcept (tyNatSize tcm nTy) of           Right n -> do             shouldReduce1 <- List.orM [ shouldReduce ctx-                                 , isUntranslatableType_not_poly aTy ]+                                 , isUntranslatableType_not_poly aTy+                                 -- Note [Unroll shouldSplit types]+                                 , pure (Maybe.isJust (shouldSplit tcm argTy)) ]             if shouldReduce1                then (`mkTicks` ticks) <$> reduceHead is0 (n+1) aTy vArg                else return e@@ -2246,10 +2286,13 @@       "Clash.Sized.Vector.tail" | argLen == 3 -> do         let [nTy,aTy] = Either.rights args             [vArg]    = Either.lefts args+            argTy     = termType tcm vArg         case runExcept (tyNatSize tcm nTy) of           Right n -> do             shouldReduce1 <- List.orM [ shouldReduce ctx-                                 , isUntranslatableType_not_poly aTy ]+                                 , isUntranslatableType_not_poly aTy+                                 -- Note [Unroll shouldSplit types]+                                 , pure (Maybe.isJust (shouldSplit tcm argTy)) ]             if shouldReduce1                then (`mkTicks` ticks) <$> reduceTail is0 (n+1) aTy vArg                else return e@@ -2257,10 +2300,13 @@       "Clash.Sized.Vector.last" | argLen == 3 -> do         let [nTy,aTy] = Either.rights args             [vArg]    = Either.lefts args+            argTy     = termType tcm vArg         case runExcept (tyNatSize tcm nTy) of           Right n -> do             shouldReduce1 <- List.orM [ shouldReduce ctx                                  , isUntranslatableType_not_poly aTy+                                 -- Note [Unroll shouldSplit types]+                                 , pure (Maybe.isJust (shouldSplit tcm argTy))                                  ]             if shouldReduce1                then (`mkTicks` ticks) <$> reduceLast is0 (n+1) aTy vArg@@ -2269,10 +2315,13 @@       "Clash.Sized.Vector.init" | argLen == 3 -> do         let [nTy,aTy] = Either.rights args             [vArg]    = Either.lefts args+            argTy     = termType tcm vArg         case runExcept (tyNatSize tcm nTy) of           Right n -> do             shouldReduce1 <- List.orM [ shouldReduce ctx-                                 , isUntranslatableType_not_poly aTy ]+                                 , isUntranslatableType_not_poly aTy+                                 -- Note [Unroll shouldSplit types]+                                 , pure (Maybe.isJust (shouldSplit tcm argTy)) ]             if shouldReduce1                then (`mkTicks` ticks) <$> reduceInit is0 p n aTy vArg                else return e@@ -2293,6 +2342,8 @@           Right n -> do             shouldReduce1 <- List.orM [ shouldReduce ctx                                  , isUntranslatableType_not_poly aTy+                                 -- Note [Unroll shouldSplit types]+                                 , pure (Maybe.isJust (shouldSplit tcm eTy))                                  ]             if shouldReduce1                then (`mkTicks` ticks) <$> reduceReplicate n aTy eTy vArg@@ -2306,6 +2357,8 @@             shouldReduce1 <- List.orM [ pure ultra                                  , shouldReduce ctx                                  , isUntranslatableType_not_poly aTy+                                 -- Note [Unroll shouldSplit types]+                                 , pure (Maybe.isJust (shouldSplit tcm eTy))                                  ]             if shouldReduce1                then (`mkTicks` ticks) <$> reduceReplace_int is0 n aTy eTy vArg iArg aArg@@ -2314,11 +2367,14 @@        "Clash.Sized.Vector.index_int" | argLen == 5 -> do         let ([_knArg,vArg,iArg],[nTy,aTy]) = Either.partitionEithers args+            argTy = termType tcm vArg         case runExcept (tyNatSize tcm nTy) of           Right n -> do             shouldReduce1 <- List.orM [ pure ultra                                  , shouldReduce ctx-                                 , isUntranslatableType_not_poly aTy ]+                                 , isUntranslatableType_not_poly aTy+                                 -- Note [Unroll shouldSplit types]+                                 , pure (Maybe.isJust (shouldSplit tcm argTy)) ]             if shouldReduce1                then (`mkTicks` ticks) <$> reduceIndex_int is0 n aTy vArg iArg                else return e@@ -2326,11 +2382,16 @@        "Clash.Sized.Vector.imap" | argLen == 6 -> do         let [nTy,argElTy,resElTy] = Either.rights args+            TyConApp vecTcNm _ = tv+            argTy = mkTyConApp vecTcNm [nTy,argElTy]         case runExcept (tyNatSize tcm nTy) of           Right n -> do             shouldReduce1 <- List.orM [ pure (ultra || n < 2)                                  , shouldReduce ctx-                                 , List.anyM isUntranslatableType_not_poly [argElTy,resElTy] ]+                                 , List.anyM isUntranslatableType_not_poly [argElTy,resElTy]+                                 -- Note [Unroll shouldSplit types]+                                 , pure (any (Maybe.isJust . shouldSplit tcm)+                                             [argTy,eTy]) ]             if shouldReduce1                then let [_,fun,arg] = Either.lefts args                     in  (`mkTicks` ticks) <$> reduceImap c n argElTy resElTy fun arg@@ -2343,7 +2404,9 @@             shouldReduce1 <- List.orM               [ pure (ultra || n < 2)               , shouldReduce ctx-              , isUntranslatableType_not_poly aTy ]+              , isUntranslatableType_not_poly aTy+              -- Note [Unroll shouldSplit types]+              , pure (Maybe.isJust (shouldSplit tcm eTy)) ]              if shouldReduce1 then               (`mkTicks` ticks) <$> reduceIterateI c n aTy eTy f a@@ -2888,12 +2951,12 @@   -- ^ If lambda is split up, this function returns a Just containing the new term separateLambda tcm ctx@(TransformContext is0 _) b eb0 =   case shouldSplit tcm (varType b) of-    Just (dc,argTys@(_:_:_)) ->+    Just (dc, _, argTys) ->       let         nm = mkDerivedName ctx (nameOcc (varName b))         bs0 = map (`mkLocalId` nm) argTys         (is1, bs1) = List.mapAccumL newBinder is0 bs0-        subst = extendIdSubst (mkSubst is1) b (mkApps dc (map (Left . Var) bs1))+        subst = extendIdSubst (mkSubst is1) b (dc (map Var bs1))         eb1 = substTm "separateArguments" subst eb0       in         Just (mkLams eb1 bs1)@@ -2953,9 +3016,8 @@     tcm <- Lens.view tcCache     let argTy = termType tcm tmArg     case shouldSplit tcm argTy of-      Just (_,argTys@(_:_:_)) -> do-        tmArgs <- mapM (mkSelectorCase ($(curLoc) ++ "splitArg") is0 tcm tmArg 1)-                       [0..length argTys - 1]+      Just (_,Projections projections,_) -> do+        tmArgs <- projections is0 tmArg         changed (map ((ty,) . Left) tmArgs)       _ ->         return [(ty,arg)]

@@ -65,8 +65,6 @@ import           BasicTypes                  (InlineSpec (..)) #endif -import           Clash.Core.DataCon          (dcExtTyVars)- #if EXPERIMENTAL_EVALUATOR import           Clash.Core.PartialEval import           Clash.Core.PartialEval.NormalForm@@ -83,14 +81,8 @@   (substTmEnv, aeqTerm, aeqType, extendIdSubst, mkSubst, substTm) import           Clash.Core.Term import           Clash.Core.TermInfo-import           Clash.Core.TyCon-  (TyConMap, tyConDataCons)-import           Clash.Core.Type             (KindOrType, Type (..),-                                              TypeView (..), coreView1,-                                              normalizeType,-                                              typeKind, tyView)-import           Clash.Core.Util-  (dataConInstArgTysE)+import           Clash.Core.TyCon            (TyConMap)+import           Clash.Core.Type             (Type (..), normalizeType, typeKind) import           Clash.Core.Var   (Id, IdScope (..), TyVar, Var (..), mkGlobalId, mkLocalId, mkTyVar) import           Clash.Core.VarEnv@@ -366,19 +358,6 @@   let ki = typeKind tcm ty   return (Right (mkTyVar ki (coerce name'))) --- | Make a new, unique, identifier-mkInternalVar-  :: (MonadUnique m)-  => InScopeSet-  -> OccName-  -- ^ Name of the identifier-  -> KindOrType-  -> m Id-mkInternalVar inScope name ty = do-  i <- getUniqueM-  let nm = mkUnsafeInternalName name i-  return (uniqAway inScope (mkLocalId ty nm))- -- | Inline the binders in a let-binding that have a certain property inlineBinders   :: (Term -> LetBinding -> RewriteMonad extra Bool)@@ -741,49 +720,6 @@                              <*> pure stringRepresentable                              <*> Lens.view tcCache                              <*> pure ty)---- | Make a binder that should not be referenced-mkWildValBinder-  :: (MonadUnique m)-  => InScopeSet-  -> Type-  -> m Id-mkWildValBinder is = mkInternalVar is "wild"---- | Make a case-decomposition that extracts a field out of a (Sum-of-)Product type-mkSelectorCase-  :: HasCallStack-  => (Functor m, MonadUnique m)-  => String -- ^ Name of the caller of this function-  -> InScopeSet-  -> TyConMap -- ^ TyCon cache-  -> Term -- ^ Subject of the case-composition-  -> Int -- n'th DataCon-  -> Int -- n'th field-  -> m Term-mkSelectorCase caller inScope tcm scrut dcI fieldI = go (termType tcm scrut)-  where-    go (coreView1 tcm -> Just ty') = go ty'-    go scrutTy@(tyView -> TyConApp tc args) =-      case tyConDataCons (lookupUniqMap' tcm tc) of-        [] -> cantCreate $(curLoc) ("TyCon has no DataCons: " ++ show tc ++ " " ++ showPpr tc) scrutTy-        dcs | dcI > length dcs -> cantCreate $(curLoc) "DC index exceeds max" scrutTy-            | otherwise -> do-          let dc = indexNote ($(curLoc) ++ "No DC with tag: " ++ show (dcI-1)) dcs (dcI-1)-          let (Just fieldTys) = dataConInstArgTysE inScope tcm dc args-          if fieldI >= length fieldTys-            then cantCreate $(curLoc) "Field index exceed max" scrutTy-            else do-              wildBndrs <- mapM (mkWildValBinder inScope) fieldTys-              let ty = indexNote ($(curLoc) ++ "No DC field#: " ++ show fieldI) fieldTys fieldI-              selBndr <- mkInternalVar inScope "sel" ty-              let bndrs  = take fieldI wildBndrs ++ [selBndr] ++ drop (fieldI+1) wildBndrs-                  pat    = DataPat dc (dcExtTyVars dc) bndrs-                  retVal = Case scrut ty [ (pat, Var selBndr) ]-              return retVal-    go scrutTy = cantCreate $(curLoc) ("Type of subject is not a datatype: " ++ showPpr scrutTy) scrutTy--    cantCreate loc info scrutTy = error $ loc ++ "Can't create selector " ++ show (caller,dcI,fieldI) ++ " for: (" ++ showPpr scrut ++ " :: " ++ showPpr scrutTy ++ ")\nAdditional info: " ++ info  -- | Specialise an application on its argument specialise :: Lens' extra (Map.Map (Id, Int, Either Term Type) Id) -- ^ Lens into previous specialisations