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-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.4.0 +Version: 1.4.1 Synopsis: Clash: a functional hardware description language - GHC frontend Description: Clash is a functional hardware description language that borrows both its @@ -163,8 +163,8 @@ transformers >= 0.5.2.0 && < 0.6, unordered-containers >= 0.2.1.0 && < 0.3, - clash-lib == 1.4.0, - clash-prelude == 1.4.0, + clash-lib == 1.4.1, + clash-prelude == 1.4.1, concurrent-supply >= 0.1.7 && < 0.2, ghc-typelits-extra >= 0.3.2 && < 0.5, ghc-typelits-knownnat >= 0.6 && < 0.8, diff --git a/src-ghc/Clash/GHC/Evaluator/Primitive.hs b/src-ghc/Clash/GHC/Evaluator/Primitive.hs --- a/src-ghc/Clash/GHC/Evaluator/Primitive.hs +++ b/src-ghc/Clash/GHC/Evaluator/Primitive.hs @@ -94,11 +94,10 @@ import Clash.Core.TysPrim import Clash.Core.Util (mkRTree,mkVec,tyNatSize,dataConInstArgTys,primCo, - undefinedTm) + undefinedTm, mkSelectorCase) import Clash.Core.Var (mkLocalId, mkTyVar) import Clash.Debug import Clash.GHC.GHC2Core (modNameM) -import Clash.Rewrite.Util (mkSelectorCase) import Clash.Unique (lookupUniqMap) import Clash.Util (MonadUnique (..), clogBase, flogBase, curLoc) diff --git a/src-ghc/Clash/GHC/GHC2Core.hs b/src-ghc/Clash/GHC/GHC2Core.hs --- a/src-ghc/Clash/GHC/GHC2Core.hs +++ b/src-ghc/Clash/GHC/GHC2Core.hs @@ -16,6 +16,8 @@ module Clash.GHC.GHC2Core ( C2C , GHC2CoreState + , GHC2CoreEnv (..) + , srcSpan , tyConMap , coreToTerm , coreToId @@ -29,7 +31,7 @@ where -- External Modules -import Control.Lens ((^.), (%~), (&), (%=)) +import Control.Lens ((^.), (%~), (&), (%=), (.~), view) import Control.Monad.RWS.Strict (RWS) import qualified Control.Monad.RWS.Strict as RWS import qualified Data.ByteString.Char8 as Char8 @@ -51,7 +53,7 @@ #if MIN_VERSION_ghc(9,0,0) import GHC.Core.Coercion.Axiom (CoAxiom (co_ax_branches), CoAxBranch (cab_lhs,cab_rhs), fromBranches) -import GHC.Core.Coercion (coercionType,coercionKind) +import GHC.Core.Coercion (Role (Nominal), coercionType, coercionKind) import GHC.Core.FVs (exprSomeFreeVars) import GHC.Core (AltCon (..), Bind (..), CoreExpr, Expr (..), Unfolding (..), Tickish (..), @@ -60,7 +62,8 @@ (DataCon, dataConExTyCoVars, dataConName, dataConRepArgTys, dataConTag, dataConTyCon, dataConUnivTyVars, dataConWorkId, dataConFieldLabels, flLabel) import GHC.Driver.Session (unsafeGlobalDynFlags) -import GHC.Core.FamInstEnv (FamInst (..), FamInstEnvs, familyInstances) +import GHC.Core.FamInstEnv + (FamInst (..), FamInstEnvs, familyInstances, normaliseType, emptyFamInstEnvs) import GHC.Data.FastString (unpackFS, bytesFS) import GHC.Types.Id (isDataConId_maybe) import GHC.Types.Id.Info (IdDetails (..), unfoldingInfo) @@ -87,7 +90,7 @@ import GHC.Types.Var.Set (isEmptyVarSet) #else import CoAxiom (CoAxiom (co_ax_branches), CoAxBranch (cab_lhs,cab_rhs), - fromBranches) + fromBranches, Role (Nominal)) import Coercion (coercionType,coercionKind) import CoreFVs (exprSomeFreeVars) import CoreSyn @@ -105,7 +108,7 @@ dataConFieldLabels, flLabel) import DynFlags (unsafeGlobalDynFlags) import FamInstEnv (FamInst (..), FamInstEnvs, - familyInstances) + familyInstances, normaliseType, emptyFamInstEnvs) #if MIN_VERSION_ghc(8,10,0) import FastString (unpackFS, bytesFS) @@ -174,6 +177,14 @@ makeLenses ''GHC2CoreState +data GHC2CoreEnv + = GHC2CoreEnv + { _srcSpan :: SrcSpan + , _famInstEnvs :: FamInstEnvs + } + +makeLenses ''GHC2CoreEnv + emptyGHC2CoreState :: GHC2CoreState emptyGHC2CoreState = GHC2CoreState C.emptyUniqMap HashMap.empty @@ -191,7 +202,7 @@ mappend = (<>) #endif -type C2C = RWS SrcSpan SrcSpanRB GHC2CoreState +type C2C = RWS GHC2CoreEnv SrcSpanRB GHC2CoreState makeAllTyCons :: GHC2CoreState @@ -203,13 +214,14 @@ | C.nullUniqMap (new ^. tyConMap) = C.emptyUniqMap | otherwise = tcm `C.unionUniqMap` tcm' where - (tcm,old', _) = RWS.runRWS (T.mapM (makeTyCon fiEnvs) (new ^. tyConMap)) noSrcSpan old + (tcm,old', _) = RWS.runRWS (T.mapM makeTyCon (new ^. tyConMap)) + (GHC2CoreEnv noSrcSpan fiEnvs) + old tcm' = go old' (old' & tyConMap %~ (`C.differenceUniqMap` (old ^. tyConMap))) -makeTyCon :: FamInstEnvs - -> TyCon +makeTyCon :: TyCon -> C2C C.TyCon -makeTyCon fiEnvs tc = tycon +makeTyCon tc = tycon where tycon | isFamilyTyCon tc = mkFunTyCon @@ -242,8 +254,9 @@ tcName <- coreToName tyConName tyConUnique qualifiedNameString tc tcKind <- coreToType (tyConKind tc) substs <- case isClosedSynFamilyTyConWithAxiom_maybe tc of - Nothing -> let instances = familyInstances fiEnvs tc - in mapM famInstToSubst instances + Nothing -> do + instances <- familyInstances <$> view famInstEnvs <*> pure tc + mapM famInstToSubst instances Just cx -> let bx = fromBranches (co_ax_branches cx) in mapM (\b -> (,) <$> mapM coreToType (cab_lhs b) <*> coreToType (cab_rhs b)) @@ -338,7 +351,7 @@ term e | (Var x,args) <- collectArgs e , let (nm, _) = RWS.evalRWS (qualifiedNameString (varName x)) - noSrcSpan + (GHC2CoreEnv noSrcSpan emptyFamInstEnvs) emptyGHC2CoreState = go nm args | otherwise @@ -495,7 +508,12 @@ termSP sp = fmap (second unSrcSpanRB) . RWS.listen . addUsefullR sp . term - coreToIdSP sp = RWS.local (\r -> if isGoodSrcSpan sp then sp else r) . coreToId + coreToIdSP sp = RWS.local (\r@(GHC2CoreEnv _ e) -> + if isGoodSrcSpan sp then + GHC2CoreEnv sp e + else + r) + . coreToId lookupPrim :: Text -> Maybe (Maybe CompiledPrimitive) @@ -516,7 +534,7 @@ unfolding = unfoldingInfo xInfo in case unfolding of CoreUnfolding {} -> do - sp <- RWS.ask + sp <- view srcSpan RWS.censor (const (SrcSpanRB sp)) (term (unfoldingTemplate unfolding)) NoUnfolding -> error ("No unfolding for DC wrapper: " ++ showPpr unsafeGlobalDynFlags x) _ -> error ("Unexpected unfolding for DC wrapper: " ++ showPpr unsafeGlobalDynFlags x) @@ -621,7 +639,7 @@ -> C2C a addUsefull x m = if isGoodSrcSpan x - then do a <- RWS.local (const x) m + then do a <- RWS.local (srcSpan .~ x) m RWS.tell (SrcSpanRB x) return a else m @@ -631,7 +649,7 @@ -> C2C a addUsefullR x m = if isGoodSrcSpan x - then RWS.local (const x) m + then RWS.local (srcSpan .~ x) m else m isSizedCast :: Type -> Type -> C2C Bool @@ -789,16 +807,19 @@ let key = args !! 0 let value = args !! 1 name' <- typeConstructorToString ty + envs <- view famInstEnvs + let (_,key1) = normaliseType envs Nominal key + (_,value1) = normaliseType envs Nominal value case name' of "Clash.Annotations.SynthesisAttributes.StringAttr" -> - return $ C.StringAttr' (tyLitToString key) (tyLitToString value) + return $ C.StringAttr' (tyLitToString key1) (tyLitToString value1) "Clash.Annotations.SynthesisAttributes.IntegerAttr" -> - return $ C.IntegerAttr' (tyLitToString key) (tyLitToInteger value) + return $ C.IntegerAttr' (tyLitToString key1) (tyLitToInteger value1) "Clash.Annotations.SynthesisAttributes.BoolAttr" -> do - bool <- boolTypeToBool value - return $ C.BoolAttr' (tyLitToString key) bool + bool <- boolTypeToBool value1 + return $ C.BoolAttr' (tyLitToString key1) bool "Clash.Annotations.SynthesisAttributes.Attr" -> - return $ C.Attr' (tyLitToString key) + return $ C.Attr' (tyLitToString key1) _ -> error $ unwords [ "Expected StringAttr, IntegerAttr, BoolAttr or Attr" , "constructor, got:" ++ name' ] @@ -977,7 +998,7 @@ = C.System | otherwise = C.User - locR <- RWS.ask + locR <- view srcSpan let loc = if isGoodSrcSpan locI then locI else locR return (C.Name sort ns key loc) diff --git a/src-ghc/Clash/GHC/GenerateBindings.hs b/src-ghc/Clash/GHC/GenerateBindings.hs --- a/src-ghc/Clash/GHC/GenerateBindings.hs +++ b/src-ghc/Clash/GHC/GenerateBindings.hs @@ -16,7 +16,7 @@ import Control.Arrow ((***), first) import Control.DeepSeq (deepseq) -import Control.Lens ((%~),(&)) +import Control.Lens ((%~),(&),(.~)) import Control.Monad (unless) import qualified Control.Monad.State as State import qualified Control.Monad.RWS.Strict as RWS @@ -38,17 +38,21 @@ import qualified GHC.Types.Id.Info as GHC import qualified GHC.Utils.Outputable as GHC import qualified GHC.Types.Name as GHC hiding (varName) +import qualified GHC.Core.FamInstEnv as GHC import qualified GHC.Core.TyCon as GHC import qualified GHC.Core.Type as GHC import qualified GHC.Builtin.Types as GHC import qualified GHC.Utils.Misc as GHC +import qualified GHC.Settings.Constants as GHC import qualified GHC.Types.Var as GHC import qualified GHC.Types.SrcLoc as GHC #else import qualified BasicTypes as GHC +import qualified Constants as GHC import qualified CoreSyn as GHC import qualified Demand as GHC import qualified DynFlags as GHC +import qualified FamInstEnv as GHC import qualified IdInfo as GHC import qualified Outputable as GHC import qualified Name as GHC hiding (varName) @@ -69,6 +73,7 @@ import Clash.Core.Type (Type (..), TypeView (..), mkFunTy, splitFunForallTy, tyView) import Clash.Core.TyCon (TyConMap, TyConName, isNewTypeTc) import Clash.Core.TysPrim (tysPrimMap) +import Clash.Core.Util (mkInternalVar, mkSelectorCase) import Clash.Core.Var (Var (..), Id, IdScope (..), setIdScope) import Clash.Core.VarEnv (InScopeSet, VarEnv, emptyInScopeSet, extendInScopeSet, mkInScopeSet @@ -77,15 +82,14 @@ import Clash.Driver (compilePrimitive) import Clash.Driver.Types (BindingMap, Binding(..), IsPrim(..)) import Clash.GHC.GHC2Core - (C2C, GHC2CoreState, tyConMap, coreToId, coreToName, coreToTerm, - makeAllTyCons, qualifiedNameString, emptyGHC2CoreState) + (C2C, GHC2CoreState, GHC2CoreEnv (..), tyConMap, coreToId, coreToName, coreToTerm, + makeAllTyCons, qualifiedNameString, emptyGHC2CoreState, srcSpan) import Clash.GHC.LoadModules (ghcLibDir, loadModules) import Clash.Netlist.BlackBox.Util (getUsedArguments) import Clash.Netlist.Types (TopEntityT(..)) import Clash.Primitives.Types (Primitive (..), CompiledPrimMap) import Clash.Primitives.Util (generatePrimMap) -import Clash.Rewrite.Util (mkInternalVar, mkSelectorCase) import Clash.Unique (listToUniqMap, lookupUniqMap, mapUniqMap, unionUniqMap, uniqMapToUniqSet) import Clash.Util (reportTimeDiff) @@ -140,7 +144,7 @@ primMapR let ((bindingsMap,clsVMap),tcMap,_) = RWS.runRWS (mkBindings primMapC bindings clsOps unlocatable) - GHC.noSrcSpan + (GHC2CoreEnv GHC.noSrcSpan fiEnvs) emptyGHC2CoreState (tcMap',tupTcCache) = mkTupTyCons tcMap tcCache = makeAllTyCons tcMap' fiEnvs @@ -151,9 +155,10 @@ clsMap = mapUniqMap (\(v,i) -> (Binding v GHC.noSrcSpan GHC.Inline IsFun (mkClassSelector inScope0 allTcCache (varType v) i))) clsVMap allBindings = bindingsMap `unionVarEnv` clsMap topEntities' = - (\m -> fst (RWS.evalRWS m GHC.noSrcSpan tcMap')) $ mapM (\(topEnt,annM,isTb) -> do - topEnt' <- coreToName GHC.varName GHC.varUnique qualifiedNameString topEnt - return (topEnt', annM, isTb)) topEntities + (\m -> fst (RWS.evalRWS m (GHC2CoreEnv GHC.noSrcSpan fiEnvs) tcMap')) $ + mapM (\(topEnt,annM,isTb) -> do + topEnt' <- coreToName GHC.varName GHC.varUnique qualifiedNameString topEnt + return (topEnt', annM, isTb)) topEntities topEntities'' = map (\(topEnt, annM, isTb) -> case lookupUniqMap topEnt allBindings of @@ -210,7 +215,7 @@ GHC.NonRec v e -> do let sp = GHC.getSrcSpan v inl = GHC.inlinePragmaSpec . GHC.inlinePragInfo $ GHC.idInfo v - tm <- RWS.local (const sp) (coreToTerm primMap unlocatable e) + tm <- RWS.local (srcSpan .~ sp) (coreToTerm primMap unlocatable e) v' <- coreToId v nm <- qualifiedNameString (GHC.varName v) let pr = if HashMap.member nm primMap then IsPrim else IsFun @@ -220,7 +225,7 @@ tms <- mapM (\(v,e) -> do let sp = GHC.getSrcSpan v inl = GHC.inlinePragmaSpec . GHC.inlinePragInfo $ GHC.idInfo v - tm <- RWS.local (const sp) (coreToTerm primMap unlocatable e) + tm <- RWS.local (srcSpan .~ sp) (coreToTerm primMap unlocatable e) v' <- coreToId v nm <- qualifiedNameString (GHC.varName v) let pr = if HashMap.member nm primMap then IsPrim else IsFun @@ -339,12 +344,12 @@ mkTupTyCons tcMap = (tcMap'',tupTcCache) where tupTyCons = GHC.boolTyCon : GHC.promotedTrueDataCon : GHC.promotedFalseDataCon - : map (GHC.tupleTyCon GHC.Boxed) [2..62] + : map (GHC.tupleTyCon GHC.Boxed) [2..GHC.mAX_TUPLE_SIZE] (tcNames,tcMap',_) = RWS.runRWS (mapM (\tc -> coreToName GHC.tyConName GHC.tyConUnique qualifiedNameString tc) tupTyCons) - GHC.noSrcSpan + (GHC2CoreEnv GHC.noSrcSpan GHC.emptyFamInstEnvs) tcMap - tupTcCache = IMS.fromList (zip [2..62] (drop 3 tcNames)) + tupTcCache = IMS.fromList (zip [2..GHC.mAX_TUPLE_SIZE] (drop 3 tcNames)) tupHM = listToUniqMap (zip tcNames tupTyCons) tcMap'' = tcMap' & tyConMap %~ (`unionUniqMap` tupHM)