clash-ghc 1.6.2 → 1.6.3
raw patch · 6 files changed
+184/−68 lines, 6 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)
+ Clash.GHC.Evaluator.Primitive: isUndefinedXPrimVal :: Value -> Bool
Files
- CHANGELOG.md +15/−1
- clash-ghc.cabal +5/−5
- src-ghc/Clash/GHC/Evaluator.hs +23/−7
- src-ghc/Clash/GHC/Evaluator/Primitive.hs +104/−17
- src-ghc/Clash/GHC/GHC2Core.hs +31/−35
- src-ghc/Clash/GHC/PartialEval/Eval.hs +6/−3
CHANGELOG.md view
@@ -1,6 +1,20 @@ # Changelog for the Clash project+## 1.6.3 *Apr 7th 2022*+Fixed:+ * Handle `~ISUNDEFINED` hole in black boxes for `BitVector` and for product types. This means that with `-fclash-aggressive-x-optimization-blackboxes`, resets are now omitted for _undefined_ reset values of such types as well. [#2117](https://github.com/clash-lang/clash-compiler/issues/2117)+ * The `alteraPll` primitive was unusable since commit `d325557750` (release v1.4.0), it now works again. [#2136](https://github.com/clash-lang/clash-compiler/pull/2136)+ * Simulation/Synthesis mismatch for X-exception to undefined bitvector conversion [#2154](https://github.com/clash-lang/clash-compiler/issues/2154)+ * The VHDL blackbox for `Signed.fromInteger` can now handle any `Netlist Expr` as input [#2149](https://github.com/clash-lang/clash-compiler/issues/2149)+ * Clash no longer escapes extended identifiers when rendering SDC files. [#2142](https://github.com/clash-lang/clash-compiler/pull/2142)+ * The types defined in `clash-prelude-hedgehog` now come with `Show` instances [#2133](https://github.com/clash-lang/clash-compiler/issues/2133)+ * Extreme values are now generated from the input range instead of the type's bounds [#2138](https://github.com/clash-lang/clash-compiler/issues/2138) -## 1.6.2 *Fed 25th 2022*+Internal change:+ * Clash now always generates non-extended identifiers for port names, so that generated names play nicer with different vendor tools. [#2142](https://github.com/clash-lang/clash-compiler/pull/2142)+ * Top entity name available in netlist context. Top entity name used in generated name for include files. [#2146](https://github.com/clash-lang/clash-compiler/pull/2146)+++## 1.6.2 *Feb 25th 2022* Fixed: * Clash now compiles for users of Clang - i.e., all macOS users. * The `trueDualPortBlockRam` model did not accurately simulate concurrent active ports, thus causing a Haskell/HDL simulation mismatch for `asyncFIFOSynchronizer`.
clash-ghc.cabal view
@@ -1,6 +1,6 @@ Cabal-version: 2.2 Name: clash-ghc-Version: 1.6.2+Version: 1.6.3 Synopsis: Clash: a functional hardware description language - GHC frontend Description: Clash is a functional hardware description language that borrows both its@@ -68,7 +68,7 @@ executable clash Main-Is: src-ghc/Batch.hs Build-Depends: base, clash-ghc- GHC-Options: -Wall -Wcompat -threaded -rtsopts+ GHC-Options: -Wall -Wcompat -threaded -rtsopts -with-rtsopts=-A128m if flag(dynamic) GHC-Options: -dynamic extra-libraries: pthread@@ -77,7 +77,7 @@ executable clashi Main-Is: src-ghc/Interactive.hs Build-Depends: base, clash-ghc- GHC-Options: -Wall -Wcompat+ GHC-Options: -Wall -Wcompat -rtsopts -with-rtsopts=-A128m if flag(dynamic) GHC-Options: -dynamic extra-libraries: pthread@@ -151,8 +151,8 @@ transformers >= 0.5.2.0 && < 0.7, unordered-containers >= 0.2.1.0 && < 0.3, - clash-lib == 1.6.2,- clash-prelude == 1.6.2,+ clash-lib == 1.6.3,+ clash-prelude == 1.6.3, 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.hs view
@@ -1,6 +1,6 @@ {-|- Copyright : (C) 2017, Google Inc.,- 2021, QBayLogic B.V.+ Copyright : (C) 2017-2022, Google Inc.,+ 2021 , QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. <devops@qbaylogic.com> @@ -49,7 +49,7 @@ import Clash.Core.Var import Clash.Core.VarEnv import Clash.Debug-import qualified Clash.Normalize.Primitives as NP (undefined)+import qualified Clash.Normalize.Primitives as NP (removedArg, undefined, undefinedX) import Clash.Unique import Clash.Util (curLoc) @@ -165,8 +165,17 @@ (m1,j) = newLetBinding tcm m0 a1 in ghcPrimStep tcm (forcePrims m) p [] [Suspend (Var i), Suspend (Var j)] m1 - (e':es) ->- Just . setTerm e' $ stackPush (PrimApply p (rights args) [] es) m+ (e':es)+ | primName p `elem` (undefinedXPrims ++ undefinedPrims)+ -- The above primitives are (bottoming) values, whose arguments+ -- are never used anywhere in the rest of the compiler. So+ -- instead of pushing a PrimApply frame on the stack to evaluate+ -- those arguments, we instead just unwind the stack with the+ -- primitive value and leave its arguments in an unevaluated+ -- state (Suspend).+ -> ghcUnwind (PrimVal p (rights args) (map Suspend (e':es))) m tcm+ | otherwise+ -> Just . setTerm e' $ stackPush (PrimApply p (rights args) [] es) m _ -> error "internal error" @@ -195,8 +204,9 @@ let tys = fst $ splitFunForallTy (primType p) in case compare (length args) (length tys) of EQ -> case lefts args of- [] | primName p `elem` [ "Clash.Normalize.Primitives.removedArg"- , "Clash.Normalize.Primitives.undefined" ] ->+ [] | primName p `elem` fmap primName [ NP.removedArg+ , NP.undefined+ , NP.undefinedX ] -> ghcUnwind (PrimVal p (rights args) []) m tcm | otherwise ->@@ -312,6 +322,8 @@ subst = extendIdSubst subst0 x' (Var x) subst0 = mkSubst $ extendInScopeSet (mScopeNames m) x apply tcm pVal@(PrimVal (PrimInfo{primType}) tys vs) x m+ | isUndefinedXPrimVal pVal+ = setTerm (TyApp (Prim NP.undefinedX) ty) m | isUndefinedPrimVal pVal = setTerm (TyApp (Prim NP.undefined) ty) m where@@ -328,6 +340,8 @@ subst0 = mkSubst iss0 iss0 = mkInScopeSet (freeVarsOf e `unionUniqSet` freeVarsOf ty) instantiate tcm pVal@(PrimVal (PrimInfo{primType}) tys []) ty m+ | isUndefinedXPrimVal pVal+ = setTerm (TyApp (Prim NP.undefinedX) (piResultTys tcm primType (tys ++ [ty]))) m | isUndefinedPrimVal pVal = setTerm (TyApp (Prim NP.undefined) (piResultTys tcm primType (tys ++ [ty]))) m @@ -402,6 +416,8 @@ = setTerm altE m scrutinise v@(PrimVal p _ vs) altTy alts m+ | isUndefinedXPrimVal v+ = setTerm (TyApp (Prim NP.undefinedX) altTy) m | isUndefinedPrimVal v = setTerm (TyApp (Prim NP.undefined) altTy) m
src-ghc/Clash/GHC/Evaluator/Primitive.hs view
@@ -1,8 +1,8 @@ {-| Copyright : (C) 2013-2016, University of Twente, 2016-2017, Myrtle Software Ltd,- 2017 , QBayLogic, Google Inc.,- 2021-2022, QBayLogic B.V.+ 2017-2022, Google Inc.,+ 2017-2022, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. <devops@qbaylogic.com> -}@@ -20,6 +20,7 @@ ( ghcPrimStep , ghcPrimUnwind , isUndefinedPrimVal+ , isUndefinedXPrimVal ) where import Control.Concurrent.Supply (Supply,freshId)@@ -88,7 +89,7 @@ import Clash.Core.Pretty (showPpr) import Clash.Core.Term (IsMultiPrim (..), Pat (..), PrimInfo (..), Term (..), WorkInfo (..), mkApps,- PrimUnfolding(..))+ PrimUnfolding(..), collectArgs) import Clash.Core.Type (Type (..), ConstTy (..), LitTy (..), TypeView (..), mkFunTy, mkTyConApp, splitFunForallTy, tyView)@@ -96,7 +97,8 @@ (TyConMap, TyConName, tyConDataCons) import Clash.Core.TysPrim import Clash.Core.Util- (mkRTree,mkVec,tyNatSize,dataConInstArgTys,primCo, mkSelectorCase,undefinedPrims)+ (mkRTree,mkVec,tyNatSize,dataConInstArgTys,primCo, mkSelectorCase,undefinedPrims,+ undefinedXPrims) import Clash.Core.Var (mkLocalId, mkTyVar) import Clash.Debug import Clash.GHC.GHC2Core (modNameM)@@ -124,6 +126,11 @@ primName `elem` undefinedPrims isUndefinedPrimVal _ = False +isUndefinedXPrimVal :: Value -> Bool+isUndefinedXPrimVal (PrimVal (PrimInfo{primName}) _ _) =+ primName `elem` undefinedXPrims+isUndefinedXPrimVal _ = False+ -- | Evaluation of primitive operations. ghcPrimUnwind :: PrimUnwind ghcPrimUnwind tcm p tys vs v [] m@@ -132,6 +139,7 @@ , Text.pack (show 'NP.removedArg) , "GHC.Prim.MutableByteArray#" , Text.pack (show 'NP.undefined)+ , Text.pack (show 'NP.undefinedX) ] -- The above primitives are actually values, and not operations. = ghcUnwind (PrimVal p tys (vs ++ [v])) m tcm@@ -160,10 +168,18 @@ tmArgs = map (Left . valToTerm) (vs ++ [v]) in Just $ flip setTerm m $ TyApp (Prim NP.undefined) $ applyTypeToArgs (Prim p) tcm (primType p) (tyArgs ++ tmArgs)+ | isUndefinedXPrimVal v+ = let tyArgs = map Right tys+ tmArgs = map (Left . valToTerm) (vs ++ [v])+ in Just $ flip setTerm m $ TyApp (Prim NP.undefinedX) $+ applyTypeToArgs (Prim p) tcm (primType p) (tyArgs ++ tmArgs) | otherwise = ghcPrimStep tcm (forcePrims m) p tys (vs ++ [v]) m ghcPrimUnwind tcm p tys vs v [e] m0+ -- Note [Lazy primitives]+ -- ~~~~~~~~~~~~~~~~~~~~~~+ -- -- Primitives are usually considered undefined when one of their arguments is -- (unless they're unused). _Some_ primitives can still yield a result even -- though one of their arguments is undefined. It turns out that all primitives@@ -174,6 +190,7 @@ , "Clash.Sized.Vector.replace_int" , "GHC.Classes.&&" , "GHC.Classes.||"+ , "Clash.Class.BitPack.Internal.xToBV" ] = if isUndefinedPrimVal v then let tyArgs = map Right tys@@ -1585,6 +1602,11 @@ | [Lit (NaturalLiteral n), _] <- args -> reduce (Literal (NaturalLiteral n)) + "GHC.TypeNats.someNatVal"+ | [Lit (NaturalLiteral n)] <- args+ -> let resTy = getResultTy tcm ty tys+ in reduce (mkSomeNat tcm n resTy)+ "GHC.Int.I8#" | isSubj , [Lit (IntLiteral i)] <- args@@ -1790,6 +1812,29 @@ val = unpack (toBV i :: BitVector 64) in reduce (mkDoubleCLit tcm val resTy) + "Clash.Class.BitPack.Internal.xToBV"+ | isSubj+ , Just (nTy, kn) <- extractKnownNat tcm tys+ -- The second argument to `xToBV` is always going to be suspended.+ -- See Note [Lazy primitives]+ , [ _, (Suspend arg) ] <- args+ , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind+ , mach1@Machine{mStack=[],mTerm=argWHNF} <-+ whnf eval tcm True (setTerm arg (stackClear mach))+ , let undefBitVector =+ Just $ mach1+ { mStack = mStack mach+ , mTerm = mkBitVectorLit ty nTy kn (bit (fromInteger kn)-1) 0+ }+ -> case isX argWHNF of+ Left _ -> undefBitVector+ _ -> case collectArgs argWHNF of+ (Prim p,_) | primName p `elem` undefinedXPrims -> undefBitVector+ _ -> Just $ mach1+ { mStack = mStack mach+ , mTerm = argWHNF+ }+ -- expIndex# -- :: KnownNat m -- => Index m@@ -1925,7 +1970,7 @@ -- Enum "Clash.Sized.Internal.BitVector.toEnum##"- | [i] <- intLiterals' args+ | [i] <- intCLiterals' args -> let Bit msk val = BitVector.toEnum## (fromInteger i) in reduce (mkBitLit ty (toInteger msk) (toInteger val)) @@ -2140,7 +2185,8 @@ "Clash.Sized.Internal.BitVector.fromEnum#" | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftBitVector2Int (toInteger . BitVector.fromEnum#) args)+ , let resTy = getResultTy tcm ty tys+ , Just val <- reifyNat kn (liftBitVector2CInt tcm resTy (toInteger . BitVector.fromEnum#) args) -> reduce val -- Bounded@@ -2317,13 +2363,14 @@ -- Enum "Clash.Sized.Internal.Index.toEnum#"- | [i] <- intLiterals' args+ | [i] <- intCLiterals' args , Just (nTy, mb) <- extractKnownNat tcm tys -> reduce (mkIndexLit ty nTy mb i) "Clash.Sized.Internal.Index.fromEnum#" | [i] <- indexLiterals' args- -> reduce (integerToIntLiteral i)+ -> let resTy = getResultTy tcm ty tys+ in reduce (mkIntCLit tcm i resTy) -- Bounded "Clash.Sized.Internal.Index.maxBound#"@@ -2433,13 +2480,14 @@ -- Enum "Clash.Sized.Internal.Signed.toEnum#"- | [i] <- intLiterals' args+ | [i] <- intCLiterals' args , Just (litTy, mb) <- extractKnownNat tcm tys -> reduce (mkSignedLit ty litTy mb i) "Clash.Sized.Internal.Signed.fromEnum#" | [i] <- signedLiterals' args- -> reduce (integerToIntLiteral i)+ -> let resTy = getResultTy tcm ty tys+ in reduce (mkIntCLit tcm i resTy) -- Bounded "Clash.Sized.Internal.Signed.minBound#"@@ -2650,13 +2698,14 @@ -- Enum "Clash.Sized.Internal.Unsigned.toEnum#"- | [i] <- intLiterals' args+ | [i] <- intCLiterals' args , Just (litTy, mb) <- extractKnownNat tcm tys -> reduce (mkUnsignedLit ty litTy mb i) "Clash.Sized.Internal.Unsigned.fromEnum#" | [i] <- unsignedLiterals' args- -> reduce (integerToIntLiteral i)+ -> let resTy = getResultTy tcm ty tys+ in reduce (mkIntCLit tcm i resTy) -- Bounded "Clash.Sized.Internal.Unsigned.minBound#"@@ -4047,6 +4096,9 @@ intLiterals' :: [Value] -> [Integer] intLiterals' = listOf intLiteral +intCLiterals' :: [Value] -> [Integer]+intCLiterals' = listOf intCLiteral+ intLiteral :: Value -> Maybe Integer intLiteral x = case x of Lit (IntLiteral i) -> Just i@@ -4182,6 +4234,14 @@ | otherwise = Nothing +mkIntCLit :: TyConMap -> Integer -> Type -> Term+mkIntCLit tcm lit resTy =+ App (Data intDc) (Literal (IntLiteral lit))+ where+ (_, tyView -> TyConApp intTcNm []) = splitFunForallTy resTy+ Just intTc = lookupUniqMap intTcNm tcm+ [intDc] = tyConDataCons intTc+ mkFloatCLit :: TyConMap -> Word32 -> Type -> Term mkFloatCLit tcm lit resTy = App (Data floatDc) (Literal (FloatLiteral lit))@@ -4198,6 +4258,31 @@ (Just doubleTc) = lookupUniqMap doubleTcNm tcm [doubleDc] = tyConDataCons doubleTc +mkSomeNat :: TyConMap -> Integer -> Type -> Term+mkSomeNat tcm lit resTy =+ mkApps (Data someNatDc)+ [ Right (LitTy (NumTy lit))+ , Left (Literal (NaturalLiteral lit))+ , Left proxy+ ]+ where+ -- Get the SomeNat data constructor+ TyConApp someNatTcNm [] = tyView resTy+ (Just someNatTc) = lookupUniqMap someNatTcNm tcm+ [someNatDc] = tyConDataCons someNatTc++ -- Get the Proxy data constructor+ (_:_:Right (tyView -> TyConApp proxyTcNm [natTy,_]):_,_) =+ splitFunForallTy (dcType someNatDc)+ (Just proxyTc) = lookupUniqMap proxyTcNm tcm+ [proxyDc] = tyConDataCons proxyTc++ -- Build the Proxy argument+ proxy = mkApps (Data proxyDc)+ [ Right natTy+ , Right (LitTy (NumTy lit))+ ]+ -- From an argument list to function of type -- forall n. KnownNat n => ... -- extract (nTy,nInt)@@ -4468,22 +4553,24 @@ -> [Value] -> (Proxy n -> Maybe Term) liftInteger2BitVector f resTyInfo args _p- | [i] <- intLiterals' args+ | [i] <- intCLiterals' args = let BV msk val = f i in Just (mkBitVectorLit' resTyInfo (toInteger msk) (toInteger val)) | otherwise = Nothing -liftBitVector2Int+liftBitVector2CInt :: KnownNat n- => (BitVector n -> Integer)+ => TyConMap+ -> Type+ -> (BitVector n -> Integer) -> [Value] -> (Proxy n -> Maybe Term)-liftBitVector2Int f args _p+liftBitVector2CInt tcm resTy f args _p | [i] <- bitVectorLiterals' args = let val = f (toBV i)- in Just $ integerToIntLiteral val+ in Just $ mkIntCLit tcm val resTy | otherwise = Nothing
src-ghc/Clash/GHC/GHC2Core.hs view
@@ -1,7 +1,7 @@ {-| Copyright : (C) 2013-2016, University of Twente, 2016-2017, Myrtle Software Ltd,- 2017-2818, Google Inc.+ 2017-2022, Google Inc. 2021, QBayLogic B.V., License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. <devops@qbaylogic.com>@@ -159,8 +159,9 @@ import qualified Clash.Core.Term as C import qualified Clash.Core.TyCon as C import qualified Clash.Core.Type as C-import qualified Clash.Core.Util as C (undefinedTy)+import qualified Clash.Core.Util as C (undefinedTy, undefinedXPrims) import qualified Clash.Core.Var as C+import Clash.Normalize.Primitives as C import Clash.Primitives.Types import qualified Clash.Unique as C import Clash.Util@@ -381,9 +382,6 @@ go "GHC.Stack.withFrozenCallStack" args | length args == 3 = term (App (args!!2) (args!!1))- go "Clash.Class.BitPack.Internal.packXWith" args- | [_nTy,_aTy,_kn,f] <- args- = term f go "Clash.Sized.BitVector.Internal.checkUnpackUndef" args | [_nTy,_aTy,_kn,_typ,f] <- args = term f@@ -461,9 +459,34 @@ x' <- coreToIdSP sp x return (x',b') - term' (Case _ _ ty []) =- C.TyApp (C.Prim (C.PrimInfo (pack "EmptyCase") C.undefinedTy C.WorkNever C.SingleResult C.NoUnfolding))- <$> coreToType ty+ term' (Case s _ ty []) = do+ s' <- term' s+ ty' <- coreToType ty+ case C.collectArgs s' of+ (C.Prim p, _) | C.primName p `elem` C.undefinedXPrims ->+ -- GHC translates things like:+ --+ -- xToBV (Index.pack# (errorX @TY "QQ"))+ --+ -- to+ --+ -- xToBV (case (errorX @TY "QQ") of {})+ --+ --+ -- Here we then translate+ --+ -- case (errorX @TY "QQ") of {}+ --+ -- to+ --+ -- undefinedX @TY+ --+ -- So that the evaluator rule for 'xToBV' can recognize things that+ -- would normally throw XException+ return (C.TyApp (C.Prim C.undefinedX) ty')+ _ ->+ return (C.TyApp (C.Prim C.undefined) ty')+ term' (Case e b ty alts) = do let usesBndr = any ( not . isEmptyVarSet . exprSomeFreeVars (== b)) $ rhssOfAlts alts@@ -550,7 +573,6 @@ | f == "GHC.Magic.noinline" -> return (idTerm xType) | f == "GHC.Magic.lazy" -> return (idTerm xType) | f == "GHC.Magic.runRW#" -> return (runRWTerm xType)- | f == "Clash.Class.BitPack.Internal.packXWith" -> return (packXWithTerm xType) | f == "Clash.Sized.Internal.BitVector.checkUnpackUndef" -> return (checkUnpackUndefTerm xType) | f == "Clash.Magic.prefixName" -> return (nameModTerm C.PrefixName xType)@@ -1342,32 +1364,6 @@ rwNm = pack "GHC.Prim.realWorld#" runRWTerm ty = error $ $(curLoc) ++ show ty---- | Given type type:------ @forall (n :: Nat) (a :: Type) .Knownnat n => (a -> BitVector n) -> a -> BitVector n@------ Generate the term:------ @/\(n:Nat)./\(a:TYPE r).\(kn:KnownNat n).\(f:a -> BitVector n).f@-packXWithTerm- :: C.Type- -> C.Term-packXWithTerm (C.ForAllTy nTV (C.ForAllTy aTV funTy)) =- C.TyLam nTV (- C.TyLam aTV (- C.Lam knId (- C.Lam fId (- C.Var fId))))- where- C.FunTy knTy rTy = C.tyView funTy- C.FunTy fTy _ = C.tyView rTy- knName = C.mkUnsafeSystemName "kn" 0- fName = C.mkUnsafeSystemName "f" 1- knId = C.mkLocalId knTy knName- fId = C.mkLocalId fTy fName--packXWithTerm ty = error $ $(curLoc) ++ show ty -- | Given type type: --
src-ghc/Clash/GHC/PartialEval/Eval.hs view
@@ -1,5 +1,6 @@ {-|-Copyright : (C) 2020-2021, QBayLogic B.V.+Copyright : (C) 2020-2021, QBayLogic B.V.,+ 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. <devops@qbaylogic.com> @@ -49,7 +50,7 @@ import Clash.Core.TysPrim (integerPrimTy) import Clash.Core.Var import Clash.Driver.Types (Binding(..), IsPrim(..))-import qualified Clash.Normalize.Primitives as NP (undefined)+import qualified Clash.Normalize.Primitives as NP (undefined, undefinedX) import Clash.Unique (lookupUniqMap') -- | Evaluate a term to WHNF.@@ -290,7 +291,9 @@ forcedSubject <- keepLifted (forceEval subject) -- If the subject is undefined, the whole expression is undefined.- case isUndefined forcedSubject of+ case isUndefinedX forcedSubject of+ True -> eval (TyApp (Prim NP.undefinedX) ty)+ False -> case isUndefined forcedSubject of True -> eval (TyApp (Prim NP.undefined) ty) False -> case stripValue forcedSubject of