diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # Changelog for the Clash project +## 1.2.4 *July 28th 2020* +* Changed: + * Relaxed upper bound versions of `aeson` and `dlist`, in preparation for the new Stack LTS. + * Reverted changes to primitive definitions for 'zipWith', 'map', 'foldr', and 'init' introduced in 1.2.2. They have shown to cause problems in very specific circumstances. + ## 1.2.3 *July 11th 2020* * Changed: * Upgrade to nixos 20.03. Nix and snap users will now use packages present in 20.03. diff --git a/clash-ghc.cabal b/clash-ghc.cabal --- a/clash-ghc.cabal +++ b/clash-ghc.cabal @@ -1,6 +1,6 @@ Cabal-version: 2.2 Name: clash-ghc -Version: 1.2.3 +Version: 1.2.4 Synopsis: CAES Language for Synchronous Hardware Description: Clash is a functional hardware description language that borrows both its @@ -151,8 +151,8 @@ transformers >= 0.5.2.0 && < 0.6, unordered-containers >= 0.2.1.0 && < 0.3, - clash-lib == 1.2.3, - clash-prelude == 1.2.3, + clash-lib == 1.2.4, + clash-prelude == 1.2.4, concurrent-supply >= 0.1.7 && < 0.2, ghc-typelits-extra >= 0.3.3 && < 0.5, ghc-typelits-knownnat >= 0.7.2 && < 0.8, @@ -177,7 +177,7 @@ CPP-Options: -DUSE_GHC_PATHS=1 if os(windows) - Build-Depends: Win32 >= 2.3.1 && < 2.9 + Build-Depends: Win32 >= 2.3.1 && < 2.10 else Build-Depends: unix >= 2.7.1 && < 2.9 diff --git a/src-ghc/Clash/GHC/Evaluator.hs b/src-ghc/Clash/GHC/Evaluator.hs --- a/src-ghc/Clash/GHC/Evaluator.hs +++ b/src-ghc/Clash/GHC/Evaluator.hs @@ -54,7 +54,10 @@ import BasicTypes (Boxity (..)) import Name (getSrcSpan, nameOccName, occNameString) -import PrelNames (trueDataConKey, falseDataConKey) +import PrelNames + (typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatSubTyFamNameKey, + trueDataConKey, falseDataConKey) +import SrcLoc (wiredInSrcSpan) import qualified TyCon import TysWiredIn (tupleTyCon) import Unique (getKey) @@ -86,9 +89,6 @@ import Clash.Unique (lookupUniqMap) import Clash.Util (MonadUnique (..), clogBase, flogBase, curLoc) -import Clash.Normalize.PrimitiveReductions - (typeNatMul, typeNatSub, typeNatAdd, vecLastPrim, vecInitPrim, vecHeadPrim, - vecTailPrim, mkVecCons, mkVecNil) import Clash.Promoted.Nat.Unsafe (unsafeSNat) import qualified Clash.Sized.Internal.BitVector as BitVector @@ -3011,31 +3011,6 @@ ,Left (Either.lefts vArgs !! 2) ]) - -- :: forall n a. KnownNat n => (a -> a) -> a -> Vec n a - "Clash.Sized.Vector.iterateI" - | isSubj - , [nTy, aTy] <- tys - , [_n, f, a] <- args - , Right n <- runExcept (tyNatSize tcm nTy) - -> - let - TyConApp vecTcNm _ = tyView (getResultTy tcm ty tys) - Just vecTc = lookupUniqMap vecTcNm tcm - [nilCon, consCon] = tyConDataCons vecTc - in case n of - 0 -> reduce (mkVecNil nilCon aTy) - _ -> reduce $ - mkVecCons consCon aTy n - (valToTerm a) - (mkApps - (Prim pInfo) - [ Right (LitTy (NumTy (n - 1))) - , Right aTy - , Left (valToTerm (Lit (NaturalLiteral (n - 1)))) - , Left (valToTerm f) - , Left (mkApps (valToTerm f) [Left (valToTerm a)]) - ]) - -- - Zipping "Clash.Sized.Vector.zipWith" -- :: (a -> b -> c) -> Vec n a -> Vec n b -> Vec n c | isSubj @@ -3862,6 +3837,47 @@ -> Term mkIndexLit' (rTy,nTy,kn) = mkIndexLit rTy nTy kn +-- | Create a vector of supplied elements +mkVecCons + :: DataCon + -- ^ The Cons (:>) constructor + -> Type + -- ^ Element type + -> Integer + -- ^ Length of the vector + -> Term + -- ^ head of the vector + -> Term + -- ^ tail of the vector + -> Term +mkVecCons consCon resTy n h t = + mkApps (Data consCon) [Right (LitTy (NumTy n)) + ,Right resTy + ,Right (LitTy (NumTy (n-1))) + ,Left (primCo consCoTy) + ,Left h + ,Left t] + + where + args = dataConInstArgTys consCon [LitTy (NumTy n),resTy,LitTy (NumTy (n-1))] + Just (consCoTy : _) = args + +-- | Create an empty vector +mkVecNil + :: DataCon + -- ^ The Nil constructor + -> Type + -- ^ The element type + -> Term +mkVecNil nilCon resTy = + mkApps (Data nilCon) [Right (LitTy (NumTy 0)) + ,Right resTy + ,Left (primCo nilCoTy) + ] + where + args = dataConInstArgTys nilCon [LitTy (NumTy 0),resTy] + Just (nilCoTy : _ ) = args + boolToIntLiteral :: Bool -> Term boolToIntLiteral b = if b then Literal (IntLiteral 1) else Literal (IntLiteral 0) @@ -4094,6 +4110,72 @@ r = f a in Literal . FloatLiteral . toRational $ F# r +vecHeadPrim + :: TyConName + -- ^ Vec TyCon name + -> Term +vecHeadPrim vecTcNm = + Prim (PrimInfo "Clash.Sized.Vector.head" (vecHeadTy vecTcNm) WorkNever) + +vecLastPrim + :: TyConName + -- ^ Vec TyCon name + -> Term +vecLastPrim vecTcNm = + Prim (PrimInfo "Clash.Sized.Vector.last" (vecHeadTy vecTcNm) WorkNever) + +vecHeadTy + :: TyConName + -- ^ Vec TyCon name + -> Type +vecHeadTy vecNm = + ForAllTy nTV ( + ForAllTy aTV ( + mkFunTy + (mkTyConApp vecNm [mkTyConApp typeNatAdd + [VarTy nTV + ,LitTy (NumTy 1)] + ,VarTy aTV + ]) + (VarTy aTV))) + where + aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 0) + nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 1) + +vecTailPrim + :: TyConName + -- ^ Vec TyCon name + -> Term +vecTailPrim vecTcNm = + Prim (PrimInfo "Clash.Sized.Vector.tail" (vecTailTy vecTcNm) WorkNever) + +vecInitPrim + :: TyConName + -- ^ Vec TyCon name + -> Term +vecInitPrim vecTcNm = + Prim (PrimInfo "Clash.Sized.Vector.init" (vecTailTy vecTcNm) WorkNever) + +vecTailTy + :: TyConName + -- ^ Vec TyCon name + -> Type +vecTailTy vecNm = + ForAllTy nTV ( + ForAllTy aTV ( + mkFunTy + (mkTyConApp vecNm [mkTyConApp typeNatAdd + [VarTy nTV + ,LitTy (NumTy 1)] + ,VarTy aTV + ]) + (mkTyConApp vecNm [VarTy nTV + ,VarTy aTV + ]))) + where + nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 0) + aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 1) + splitAtPrim :: TyConName -- ^ SNat TyCon name @@ -4317,6 +4399,25 @@ nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 0) mTV = mkTyVar typeNatKind (mkUnsafeSystemName "m" 1) tupNm = ghcTyconToTyConName (tupleTyCon Boxed 2) + +typeNatAdd :: TyConName +typeNatAdd = Name User + "GHC.TypeNats.+" + (getKey typeNatAddTyFamNameKey) + wiredInSrcSpan + + +typeNatMul :: TyConName +typeNatMul = Name User + "GHC.TypeNats.*" + (getKey typeNatMulTyFamNameKey) + wiredInSrcSpan + +typeNatSub :: TyConName +typeNatSub = Name User + "GHC.TypeNats.-" + (getKey typeNatSubTyFamNameKey) + wiredInSrcSpan ghcTyconToTyConName :: TyCon.TyCon