diff --git a/changelog/2022-03-30T13_55_22+02_00_fix2154 b/changelog/2022-03-30T13_55_22+02_00_fix2154 new file mode 100644 index 0000000000..c3bfc2594e --- /dev/null +++ b/changelog/2022-03-30T13_55_22+02_00_fix2154 @@ -0,0 +1 @@ +FIXED: Simulation/Synthesis mismatch for X-exception to undefined bitvector conversion [#2154](https://github.com/clash-lang/clash-compiler/issues/2154) diff --git a/clash-ghc/src-ghc/Clash/GHC/Evaluator.hs b/clash-ghc/src-ghc/Clash/GHC/Evaluator.hs index 936ed778cc..138917407c 100644 --- a/clash-ghc/src-ghc/Clash/GHC/Evaluator.hs +++ b/clash-ghc/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.Util 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 (undefined, undefinedX) import Clash.Unique import Clash.Util (curLoc) @@ -166,7 +166,7 @@ stepApp x y m tcm = in ghcPrimStep tcm (forcePrims m) p [] [Suspend (Var i), Suspend (Var j)] m1 (e':es) - | primName p `elem` undefinedPrims + | primName p `elem` (undefinedXPrims ++ undefinedPrims) -> ghcUnwind (PrimVal p (rights args) (map Suspend (e':es))) m tcm | otherwise -> Just . setTerm e' $ stackPush (PrimApply p (rights args) [] es) m @@ -199,7 +199,8 @@ stepTyApp x ty m tcm = in case compare (length args) (length tys) of EQ -> case lefts args of [] | primName p `elem` [ "Clash.Normalize.Primitives.removedArg" - , "Clash.Normalize.Primitives.undefined" ] -> + , "Clash.Normalize.Primitives.undefined" + , "Clash.Normalize.Primitives.undefinedX" ] -> ghcUnwind (PrimVal p (rights args) []) m tcm | otherwise -> @@ -315,6 +316,8 @@ apply _tcm (Lambda x' e) x m = 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 @@ -331,6 +334,8 @@ instantiate _tcm (TyLambda x e) ty m = 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 @@ -405,6 +410,8 @@ scrutinise (DC dc xs) _altTy alts m = 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/clash-ghc/src-ghc/Clash/GHC/Evaluator/Primitive.hs b/clash-ghc/src-ghc/Clash/GHC/Evaluator/Primitive.hs index 3514d3800b..fb70a3868d 100644 --- a/clash-ghc/src-ghc/Clash/GHC/Evaluator/Primitive.hs +++ b/clash-ghc/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 @@ module Clash.GHC.Evaluator.Primitive ( ghcPrimStep , ghcPrimUnwind , isUndefinedPrimVal + , isUndefinedXPrimVal ) where import Control.Concurrent.Supply (Supply,freshId) @@ -88,7 +89,7 @@ import Clash.Core.Name 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 @@ import Clash.Core.TyCon (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 @@ isUndefinedPrimVal (PrimVal (PrimInfo{primName}) _ _) = 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 @@ ghcPrimUnwind tcm p tys vs v [] m , 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,6 +168,11 @@ ghcPrimUnwind tcm p tys vs v [] m 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 @@ -174,6 +187,7 @@ ghcPrimUnwind tcm p tys vs v [e] m0 , "Clash.Sized.Vector.replace_int" , "GHC.Classes.&&" , "GHC.Classes.||" + , "Clash.Class.BitPack.Internal.xToBV" ] = if isUndefinedPrimVal v then let tyArgs = map Right tys @@ -1795,6 +1809,27 @@ ghcPrimStep tcm isSubj pInfo tys args mach = case primName pInfo of val = unpack (toBV i :: BitVector 64) in reduce (mkDoubleCLit tcm val resTy) + "Clash.Class.BitPack.Internal.xToBV" + | isSubj + , Just (nTy, kn) <- extractKnownNat tcm tys + , [ _, (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 diff --git a/clash-ghc/src-ghc/Clash/GHC/GHC2Core.hs b/clash-ghc/src-ghc/Clash/GHC/GHC2Core.hs index 6b88c556fc..66c4ca1136 100644 --- a/clash-ghc/src-ghc/Clash/GHC/GHC2Core.hs +++ b/clash-ghc/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.Name as C 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 @@ coreToTerm primMap unlocs = term 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 @@ coreToTerm primMap unlocs = term 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 @@ coreToTerm primMap unlocs = term | 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) @@ -1343,32 +1365,6 @@ runRWTerm (C.ForAllTy rTV (C.ForAllTy oTV funTy)) = 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: -- -- @forall (n :: Nat) (a :: Type) .Knownnat n => Typeable a => (BitVector n -> a) -> BitVector n -> a@ diff --git a/clash-ghc/src-ghc/Clash/GHC/PartialEval/Eval.hs b/clash-ghc/src-ghc/Clash/GHC/PartialEval/Eval.hs index 43640ab910..8ed0cf1633 100644 --- a/clash-ghc/src-ghc/Clash/GHC/PartialEval/Eval.hs +++ b/clash-ghc/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.Type 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 @@ caseCon subject ty alts = do 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 diff --git a/clash-lib/prims/common/Clash_Class_BitPack.primitives.yaml b/clash-lib/prims/common/Clash_Class_BitPack.primitives.yaml index afaf71b49b..354221505c 100644 --- a/clash-lib/prims/common/Clash_Class_BitPack.primitives.yaml +++ b/clash-lib/prims/common/Clash_Class_BitPack.primitives.yaml @@ -26,3 +26,9 @@ 64 -> Double' template: ~ARG[0] workInfo: Never +- BlackBox: + name: Clash.Class.BitPack.Internal.xToBV + kind: Expression + type: 'xToBV :: KnownNat n => BitVector n -> BitVector n' + template: ~ARG[1] + workInfo: Never diff --git a/clash-lib/prims/common/Clash_GHC_GHC2Core.primitives.yaml b/clash-lib/prims/common/Clash_GHC_GHC2Core.primitives.yaml index 4bb9745b0e..374ba2ce52 100644 --- a/clash-lib/prims/common/Clash_GHC_GHC2Core.primitives.yaml +++ b/clash-lib/prims/common/Clash_GHC_GHC2Core.primitives.yaml @@ -1,8 +1,3 @@ -- BlackBox: - name: EmptyCase - kind: Expression - template: ~ERRORO - workInfo: Constant - Primitive: name: _CO_ primType: Constructor diff --git a/clash-lib/prims/common/Clash_Normalize_Primitives.primitives.yaml b/clash-lib/prims/common/Clash_Normalize_Primitives.primitives.yaml index 8ecccbc893..db5eae76a0 100644 --- a/clash-lib/prims/common/Clash_Normalize_Primitives.primitives.yaml +++ b/clash-lib/prims/common/Clash_Normalize_Primitives.primitives.yaml @@ -11,6 +11,12 @@ a . a' template: ~ERRORO workInfo: Constant +- BlackBox: + name: Clash.Normalize.Primitives.undefinedX + kind: Expression + type: 'undefinedX :: forall a . a' + template: ~ERRORO + workInfo: Constant - BlackBox: name: c$multiPrimSelect kind: Expression diff --git a/clash-lib/src/Clash/Core/PartialEval/NormalForm.hs b/clash-lib/src/Clash/Core/PartialEval/NormalForm.hs index a32a7e5130..d201aed0b3 100644 --- a/clash-lib/src/Clash/Core/PartialEval/NormalForm.hs +++ b/clash-lib/src/Clash/Core/PartialEval/NormalForm.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. @@ -24,6 +25,7 @@ module Clash.Core.PartialEval.NormalForm , stripValue , collectValueTicks , isUndefined + , isUndefinedX , Normal(..) , LocalEnv(..) , GlobalEnv(..) @@ -40,7 +42,7 @@ import Clash.Core.Literal import Clash.Core.Term (Bind, Term(..), PrimInfo(primName), TickInfo, Pat) import Clash.Core.TyCon (TyConMap) import Clash.Core.Type (Type, TyVar) -import Clash.Core.Util (undefinedPrims) +import Clash.Core.Util (undefinedPrims, undefinedXPrims) import Clash.Core.Var (Id) import Clash.Core.VarEnv (VarEnv, InScopeSet) import Clash.Driver.Types (Binding(..)) @@ -127,6 +129,13 @@ isUndefined = \case _ -> False +isUndefinedX :: Value -> Bool +isUndefinedX = \case + VNeutral (NePrim pr _) -> + primName pr `elem` undefinedXPrims + + _ -> False + -- | A term which is in beta-normal eta-long form (NF). This has no redexes, -- and all partially applied functions in sub-terms are eta-expanded. -- diff --git a/clash-lib/src/Clash/Core/Util.hs b/clash-lib/src/Clash/Core/Util.hs index 752f783ff8..724f4c5d1c 100644 --- a/clash-lib/src/Clash/Core/Util.hs +++ b/clash-lib/src/Clash/Core/Util.hs @@ -1,6 +1,7 @@ {-| Copyright : (C) 2012-2016, University of Twente, - 2021 , QBayLogic B.V. + 2021 , QBayLogic B.V., + 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -466,10 +467,8 @@ primUCo = undefinedPrims :: [T.Text] undefinedPrims = [ "Clash.Normalize.Primitives.undefined" - , "Clash.XException.errorX" , "Control.Exception.Base.absentError" , "Control.Exception.Base.patError" - , "EmptyCase" , "GHC.Err.error" , "GHC.Err.errorWithoutStackTrace" , "GHC.Err.undefined" @@ -479,6 +478,12 @@ undefinedPrims = , "GHC.Real.underflowError" ] +undefinedXPrims :: [T.Text] +undefinedXPrims = + [ "Clash.Normalize.Primitives.undefinedX" + , "Clash.XException.errorX" + ] + substArgTys :: DataCon -> [Type] diff --git a/clash-lib/src/Clash/Normalize/Primitives.hs b/clash-lib/src/Clash/Normalize/Primitives.hs index 56caf6fa7e..3df6aab9d8 100644 --- a/clash-lib/src/Clash/Normalize/Primitives.hs +++ b/clash-lib/src/Clash/Normalize/Primitives.hs @@ -1,5 +1,6 @@ {-| -Copyright : (C) 2021, QBayLogic B.V. +Copyright : (C) 2021, QBayLogic B.V., + 2022, Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -11,6 +12,7 @@ Special primitives created during the normalization process. module Clash.Normalize.Primitives ( removedArg , undefined + , undefinedX ) where import Prelude hiding (undefined) @@ -46,3 +48,15 @@ undefined = PrimInfo , primMultiResult = SingleResult , primUnfolding = NoUnfolding } + +-- | The undefinedX primitive represents an X-exception throwing value that was +-- identified during normalization. +-- +undefinedX :: PrimInfo +undefinedX = PrimInfo + { primName = Text.showt 'undefinedX + , primType = undefinedTy + , primWorkInfo = WorkNever + , primMultiResult = SingleResult + , primUnfolding = NoUnfolding + } diff --git a/clash-lib/src/Clash/Normalize/Transformations/Case.hs b/clash-lib/src/Clash/Normalize/Transformations/Case.hs index 1d09926b74..94455fa216 100644 --- a/clash-lib/src/Clash/Normalize/Transformations/Case.hs +++ b/clash-lib/src/Clash/Normalize/Transformations/Case.hs @@ -1,7 +1,7 @@ {-| Copyright : (C) 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd, - 2017-2018, Google Inc., + 2017-2022, Google Inc., 2021-2022, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -70,7 +70,7 @@ import Clash.Debug (traceIf) import Clash.Driver.Types (DebugOpts(dbg_invariants)) import Clash.Netlist.Types (FilteredHWType(..), HWType(..)) import Clash.Netlist.Util (coreTypeToHWType, representableType) -import qualified Clash.Normalize.Primitives as NP (undefined) +import qualified Clash.Normalize.Primitives as NP (undefined, undefinedX) import Clash.Normalize.Types (NormRewrite, NormalizeSession) import Clash.Rewrite.Combinators ((>-!)) import Clash.Rewrite.Types @@ -290,8 +290,7 @@ caseCon' ctx@(TransformContext is0 _) e@(Case subj ty alts) = do -- means the entire case-expression is _|_ (Prim pInfo,[_],ticks) | primName pInfo `elem` [ Text.showt 'NP.undefined - , "Clash.GHC.Evaluator.undefined" - , "EmptyCase"] -> + , Text.showt 'NP.undefinedX ] -> let e1 = mkApps (mkTicks (Prim pInfo) ticks) [Right ty] in changed e1 -- WHNF of subject is _|_, in the form of `errorX`: that means that diff --git a/clash-lib/src/Clash/Normalize/Transformations/Inline.hs b/clash-lib/src/Clash/Normalize/Transformations/Inline.hs index 79e1288a78..c37dca4b73 100644 --- a/clash-lib/src/Clash/Normalize/Transformations/Inline.hs +++ b/clash-lib/src/Clash/Normalize/Transformations/Inline.hs @@ -1,7 +1,7 @@ {-| Copyright : (C) 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd, - 2017-2018, Google Inc., + 2017-2022, Google Inc., 2021-2022, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -425,8 +425,32 @@ collapseRHSNoops _ (Letrec binds body) = do Monad.guard $ not isRecursive isNoop $ bindingTerm binding isNoop (Prim PrimInfo{primWorkInfo=WorkIdentity _ []}) = return True + isNoop (Lam x e) = isNoopApp x (collectArgs e) isNoop _ = return False + -- Check whether we have a term of the form: + -- + -- primX a (primY b (primZ c (... x ...)))) + -- + -- Where primX, primY and primZ are either: + -- + -- 1. xToBV, or + -- 2. Primitives that are the identity on their argument + -- + -- And that the variable 'x' is used by the last primitive in the chain. + isNoopApp x (Var y,[]) = return (x == y) + isNoopApp x (Prim PrimInfo{primWorkInfo=WorkIdentity i []},args) = do + arg <- getTermArg (lefts args) i + isNoopApp x (collectArgs arg) + isNoopApp x (Prim PrimInfo{primName="Clash.Class.BitPack.Internal.xToBV"},args) = do + -- We don't make 'xToBV' something of 'WorkIdentity 1 []' because we don't + -- want 'getIdentity' to replace "naked" occurances of 'xToBV' by + -- 'unsafeCoerce#'. We don't want that since 'xToBV' has a special evaluator + -- rule that can translate XExceptions to 'undefined# :: BitVector n'. + arg@(App {}) <- getTermArg (lefts args) 1 + isNoopApp x (collectArgs arg) + isNoopApp _ _ = return False + collapseRHSNoops _ e = return e {-# SCC collapseRHSNoops #-} diff --git a/clash-prelude/src/Clash/Class/BitPack/Internal.hs b/clash-prelude/src/Clash/Class/BitPack/Internal.hs index 9d66226370..e6e53ad99b 100644 --- a/clash-prelude/src/Clash/Class/BitPack/Internal.hs +++ b/clash-prelude/src/Clash/Class/BitPack/Internal.hs @@ -1,7 +1,8 @@ {-| Copyright : (C) 2013-2016, University of Twente, 2016-2017, Myrtle Software Ltd, - 2021, QBayLogic B.V. + 2021, QBayLogic B.V., + 2022, Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. -} @@ -142,10 +143,15 @@ packXWith => (a -> BitVector n) -> a -> BitVector n -packXWith f x = - unsafeDupablePerformIO (catch (f <$> evaluate x) +packXWith f = xToBV . f +{-# INLINE packXWith #-} + +xToBV :: KnownNat n => BitVector n -> BitVector n +xToBV x = + unsafeDupablePerformIO (catch (evaluate x) (\(XException _) -> return undefined#)) -{-# NOINLINE packXWith #-} +{-# NOINLINE xToBV #-} +{-# ANN xToBV hasBlackBox #-} -- | Pack both arguments to a 'BitVector' and use -- 'Clash.Sized.Internal.BitVector.isLike#' to compare them. This is a more diff --git a/tests/Main.hs b/tests/Main.hs index fc95f63860..dc228f9c19 100755 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -571,6 +571,7 @@ runClashTest = defaultMain $ clashTestRoot , runTest "T2046B" def{clashFlags=["-Werror"]} , runTest "T2046C" def{hdlSim=False,clashFlags=["-Werror"],buildTargets=BuildSpecific["topEntity"]} , runTest "T2097" def{hdlSim=False} + , runTest "T2154" def{hdlTargets=[VHDL], hdlSim=False} ] <> if compiledWith == Cabal then -- This tests fails without environment files present, which are only diff --git a/tests/shouldwork/Basic/T1591.hs b/tests/shouldwork/Basic/T1591.hs index 6e65ea1643..404f3cc9b9 100644 --- a/tests/shouldwork/Basic/T1591.hs +++ b/tests/shouldwork/Basic/T1591.hs @@ -32,8 +32,7 @@ data NextLineMask this that = } deriving (Generic) nextLineMask :: forall this that. (KnownNat this, KnownNat that) => Index (CountStates this that) -> NextLineMask this that -nextLineMask = - errorX "" +nextLineMask x = NextLineMask x topEntity :: Signal System (Index (CountStates 3 4)) -> Signal System (NextLineMask 3 4) diff --git a/tests/shouldwork/Issues/T2154.hs b/tests/shouldwork/Issues/T2154.hs new file mode 100644 index 0000000000..3bc0e6b165 --- /dev/null +++ b/tests/shouldwork/Issues/T2154.hs @@ -0,0 +1,10 @@ +module T2154 where + +import Clash.Explicit.Prelude + +topEntity (clk :: Clock System) rst = + let r = unpack (pack ( errorX "T2154" :: (Index 10) + , 3 :: Index 10 + )) :: Vec 2 (Index 10) + s = register clk rst enableGen (seq r r) s + in s diff --git a/tests/shouldwork/TopEntity/PortGeneration.hs b/tests/shouldwork/TopEntity/PortGeneration.hs index ee4c2b4f1a..08eb484907 100644 --- a/tests/shouldwork/TopEntity/PortGeneration.hs +++ b/tests/shouldwork/TopEntity/PortGeneration.hs @@ -5,8 +5,6 @@ module PortGeneration where -import qualified Prelude as P - import Clash.Prelude import Clash.Annotations.TH @@ -55,7 +53,7 @@ data Passthrough a b = Passthrough a b topEntity1 :: "in1" ::: Signal System Int -> "in2" ::: Signal System Bool -> "out" ::: Signal System Int -topEntity1 = undefined +topEntity1 _ _ = pure (deepErrorX "out") makeTopEntity 'topEntity1 topEntity2 :: "int" ::: Signal System Int @@ -65,7 +63,7 @@ topEntity2 :: "int" ::: Signal System Int -> "named" ::: Signal System Named -> "embedded" ::: Signal System Embedded -> "out" ::: Signal System Bool -topEntity2 = undefined +topEntity2 _ _ _ _ _ = pure (deepErrorX "out") makeTopEntity 'topEntity2 topEntity3 :: "clk" ::: Clock System @@ -77,7 +75,7 @@ topEntity3 :: "clk" ::: Clock System -> "tup4" ::: ("int":::Signal System Int, "bool":::Signal System Bool) -> "custom" ::: Signal System Named -> "outTup" ::: Signal System ("outint":::Int, "outbool":::Bool) -topEntity3 = undefined +topEntity3 _ _ _ _ _ _ _ _ = pure (deepErrorX "outTup") makeTopEntity 'topEntity3 topEntity4 :: Signal System (Gadt Int) @@ -89,13 +87,13 @@ topEntity4 :: Signal System (Gadt Int) -> Signal System (X Int Int Int) -> Signal System (X Bool Int Int) -> Signal System Single -topEntity4 = undefined +topEntity4 _ _ _ _ _ _ _ _ = pure (errorX "out") makeTopEntity 'topEntity4 topEntity5 :: "in1" ::: Signal System SuccessTy -> "ab" ::: Signal System (Passthrough (Passthrough Simple Simple) Simple) -> "out" ::: Signal System Int -topEntity5 = undefined +topEntity5 _ _ = pure (deepErrorX "out") makeTopEntity 'topEntity5 topEntity7 :: (HiddenClockResetEnable System) @@ -103,14 +101,14 @@ topEntity7 :: (HiddenClockResetEnable System) -> "in2" ::: Signal System (Vec 3 Simple) -> "passthrough" ::: Signal System (Passthrough Single Single) -> "out" ::: Signal System Int -topEntity7 = undefined +topEntity7 _ _ = pure (deepErrorX "out") makeTopEntity 'topEntity7 topEntity8 :: (HiddenClockResetEnable System) => "pair" ::: Signal System (Pair Bool) -> "pair" ::: Signal System (Pair Single) -> "out" ::: Signal System Int -topEntity8 = undefined +topEntity8 _ _ = pure (deepErrorX "out") makeTopEntity 'topEntity8 -- Only check for successful Clash compilation, not content