clash-ghc 1.4.0 → 1.4.1
raw patch · 5 files changed
+83/−42 lines, 5 filesdep ~clash-libdep ~clash-preludePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: clash-lib, clash-prelude
API changes (from Hackage documentation)
Files
- CHANGELOG.md +17/−1
- clash-ghc.cabal +3/−3
- src-ghc/Clash/GHC/Evaluator/Primitive.hs +1/−2
- src-ghc/Clash/GHC/GHC2Core.hs +44/−23
- src-ghc/Clash/GHC/GenerateBindings.hs +18/−13
CHANGELOG.md view
@@ -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.
clash-ghc.cabal view
@@ -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,
src-ghc/Clash/GHC/Evaluator/Primitive.hs view
@@ -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)
src-ghc/Clash/GHC/GHC2Core.hs view
@@ -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)
src-ghc/Clash/GHC/GenerateBindings.hs view
@@ -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)