diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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`. 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.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, 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 @@ -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. @@ -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 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 @@ -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. -} @@ -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 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 @@ -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. @@ -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: -- diff --git a/src-ghc/Clash/GHC/PartialEval/Eval.hs b/src-ghc/Clash/GHC/PartialEval/Eval.hs --- a/src-ghc/Clash/GHC/PartialEval/Eval.hs +++ b/src-ghc/Clash/GHC/PartialEval/Eval.hs @@ -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. @@ -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