diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/clash-lib.cabal b/clash-lib.cabal --- a/clash-lib.cabal +++ b/clash-lib.cabal @@ -1,6 +1,6 @@ Cabal-version: 2.2 Name: clash-lib -Version: 1.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, diff --git a/prims/vhdl/Clash_Sized_Internal_BitVector.primitives b/prims/vhdl/Clash_Sized_Internal_BitVector.primitives --- a/prims/vhdl/Clash_Sized_Internal_BitVector.primitives +++ b/prims/vhdl/Clash_Sized_Internal_BitVector.primitives @@ -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" diff --git a/src/Clash/Core/Type.hs b/src/Clash/Core/Type.hs --- a/src/Clash/Core/Type.hs +++ b/src/Clash/Core/Type.hs @@ -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 diff --git a/src/Clash/Core/Util.hs b/src/Clash/Core/Util.hs --- a/src/Clash/Core/Util.hs +++ b/src/Clash/Core/Util.hs @@ -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)) diff --git a/src/Clash/Driver.hs b/src/Clash/Driver.hs --- a/src/Clash/Driver.hs +++ b/src/Clash/Driver.hs @@ -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 -> diff --git a/src/Clash/Normalize/DEC.hs b/src/Clash/Normalize/DEC.hs --- a/src/Clash/Normalize/DEC.hs +++ b/src/Clash/Normalize/DEC.hs @@ -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. diff --git a/src/Clash/Normalize/Strategy.hs b/src/Clash/Normalize/Strategy.hs --- a/src/Clash/Normalize/Strategy.hs +++ b/src/Clash/Normalize/Strategy.hs @@ -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) diff --git a/src/Clash/Normalize/Transformations.hs b/src/Clash/Normalize/Transformations.hs --- a/src/Clash/Normalize/Transformations.hs +++ b/src/Clash/Normalize/Transformations.hs @@ -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)] diff --git a/src/Clash/Rewrite/Util.hs b/src/Clash/Rewrite/Util.hs --- a/src/Clash/Rewrite/Util.hs +++ b/src/Clash/Rewrite/Util.hs @@ -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