From 2f01eb81fed6138973e04d0c70f6c6275fc74dc9 Mon Sep 17 00:00:00 2001 From: Christiaan Baaij Date: Mon, 28 Aug 2023 23:19:41 +0200 Subject: [PATCH 1/3] Load all unfoldings on GHC 9.4+ GHC 9.4+ differentiates between regular unfoldings and unfoldings of loop breakers. Previously we wouldn't load unfoldings of loop breakers, unintentionally marking them as primitives. Now we load all unfoldings from interface files, even loop breakers. --- clash-ghc/src-ghc/Clash/GHC/LoadInterfaceFiles.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/clash-ghc/src-ghc/Clash/GHC/LoadInterfaceFiles.hs b/clash-ghc/src-ghc/Clash/GHC/LoadInterfaceFiles.hs index 5d666e61fa..5169fc997f 100644 --- a/clash-ghc/src-ghc/Clash/GHC/LoadInterfaceFiles.hs +++ b/clash-ghc/src-ghc/Clash/GHC/LoadInterfaceFiles.hs @@ -495,7 +495,11 @@ loadExprFromTyThing :: CoreSyn.CoreBndr -> GHC.TyThing -> Maybe CoreSyn.CoreExpr loadExprFromTyThing bndr tyThing = case tyThing of GHC.AnId _id | Var.isId _id -> let _idInfo = Var.idInfo _id +#if MIN_VERSION_ghc(9,4,0) + unfolding = IdInfo.realUnfoldingInfo _idInfo +#else unfolding = IdInfo.unfoldingInfo _idInfo +#endif in case unfolding of CoreSyn.CoreUnfolding {} -> Just (CoreSyn.unfoldingTemplate unfolding) From dcca85199d1b1e8e0f7558117d47c4a24520646b Mon Sep 17 00:00:00 2001 From: Christiaan Baaij Date: Mon, 28 Aug 2023 23:23:42 +0200 Subject: [PATCH 2/3] Give evaluator access to inscope let-bindings Without it, Clash goes into an infinite loop on T1354A in combination with: https://github.com/clash-lang/ghc-typelits-knownnat/pull/47 --- clash-lib/src/Clash/Core/Evaluator/Types.hs | 5 +++-- clash-lib/src/Clash/Core/Pretty.hs | 2 +- clash-lib/src/Clash/Core/Term.hs | 4 ++-- clash-lib/src/Clash/Core/VarEnv.hs | 8 ++++++++ .../src/Clash/Normalize/Transformations/DEC.hs | 2 +- .../Normalize/Transformations/EtaExpand.hs | 4 ++-- clash-lib/src/Clash/Rewrite/Combinators.hs | 2 +- clash-lib/src/Clash/Rewrite/Util.hs | 18 +++++++++++++----- clash-term/Main.hs | 2 +- 9 files changed, 32 insertions(+), 15 deletions(-) diff --git a/clash-lib/src/Clash/Core/Evaluator/Types.hs b/clash-lib/src/Clash/Core/Evaluator/Types.hs index 9d28a11b0f..831a636d8e 100644 --- a/clash-lib/src/Clash/Core/Evaluator/Types.hs +++ b/clash-lib/src/Clash/Core/Evaluator/Types.hs @@ -38,6 +38,7 @@ import Clash.Pretty (ClashPretty(..), fromPretty, showDoc) whnf' :: Evaluator -> BindingMap + -> VarEnv Term -> TyConMap -> PrimHeap -> Supply @@ -45,12 +46,12 @@ whnf' -> Bool -> Term -> (PrimHeap, PureHeap, Term) -whnf' eval bm tcm ph ids is isSubj e = +whnf' eval bm lh tcm ph ids is isSubj e = toResult $ whnf eval tcm isSubj m where toResult x = (mHeapPrim x, mHeapLocal x, mTerm x) - m = Machine ph gh emptyVarEnv [] ids is e + m = Machine ph gh lh [] ids is e gh = mapVarEnv bindingTerm bm -- | Evaluate to WHNF given an existing Heap and Stack diff --git a/clash-lib/src/Clash/Core/Pretty.hs b/clash-lib/src/Clash/Core/Pretty.hs index 3c80c6cc39..e35a077de7 100644 --- a/clash-lib/src/Clash/Core/Pretty.hs +++ b/clash-lib/src/Clash/Core/Pretty.hs @@ -455,7 +455,7 @@ pprPrecCast prec e ty1 ty2 = do pprPrecLetrec :: Monad m => Rational -> Bool -> [(Id, Term)] -> Term -> m ClashDoc pprPrecLetrec prec isRec xes body = do let bndrs = fst <$> xes - body' <- annotate (AnnContext $ LetBody bndrs) <$> pprPrec noPrec body + body' <- annotate (AnnContext $ LetBody xes) <$> pprPrec noPrec body xes' <- mapM (\(x,e) -> do x' <- pprBndr LetBind x e' <- pprPrec noPrec e diff --git a/clash-lib/src/Clash/Core/Term.hs b/clash-lib/src/Clash/Core/Term.hs index ef735115f4..614fe5faf5 100644 --- a/clash-lib/src/Clash/Core/Term.hs +++ b/clash-lib/src/Clash/Core/Term.hs @@ -266,7 +266,7 @@ data CoreContext -- ^ Function position of a type application | LetBinding Id [Id] -- ^ RHS of a Let-binder with the sibling LHS' - | LetBody [Id] + | LetBody [LetBinding] -- ^ Body of a Let-binding with the bound LHS' | LamBody Id -- ^ Body of a lambda-term with the abstracted variable @@ -303,7 +303,7 @@ instance Eq CoreContext where -- NB: we do not see inside the argument here (TyAppC, TyAppC) -> True (LetBinding i is, LetBinding i' is') -> i == i' && is == is' - (LetBody is, LetBody is') -> is == is' + (LetBody is, LetBody is') -> map fst is == map fst is' (LamBody i, LamBody i') -> i == i' (TyLamBody tv, TyLamBody tv') -> tv == tv' (CaseAlt p, CaseAlt p') -> p == p' diff --git a/clash-lib/src/Clash/Core/VarEnv.hs b/clash-lib/src/Clash/Core/VarEnv.hs index 46be1cb6b7..a55439bb10 100644 --- a/clash-lib/src/Clash/Core/VarEnv.hs +++ b/clash-lib/src/Clash/Core/VarEnv.hs @@ -25,6 +25,7 @@ module Clash.Core.VarEnv , delVarEnvList , unionVarEnv , unionVarEnvWith + , differenceVarEnv -- ** Element-wise operations -- *** Mapping , mapVarEnv @@ -227,6 +228,13 @@ unionVarEnvWith -> VarEnv a unionVarEnvWith = UniqMap.unionWith +-- | Filter the first varenv to only contain keys which are not in the second varenv. +differenceVarEnv + :: VarEnv a + -> VarEnv a + -> VarEnv a +differenceVarEnv = UniqMap.difference + -- | Create an environment given a list of var-value pairs mkVarEnv :: [(Var a,b)] diff --git a/clash-lib/src/Clash/Normalize/Transformations/DEC.hs b/clash-lib/src/Clash/Normalize/Transformations/DEC.hs index bff3a0cee8..134995b715 100644 --- a/clash-lib/src/Clash/Normalize/Transformations/DEC.hs +++ b/clash-lib/src/Clash/Normalize/Transformations/DEC.hs @@ -303,7 +303,7 @@ collectGlobals' is0 substitution seen e@(collectArgsTicks -> (fun, args@(_:_), t let (ids1,ids2) = splitSupply ids uniqSupply Lens..= ids2 gh <- Lens.use globalHeap - let eval = (Lens.view Lens._3) . whnf' evaluate bndrs tcm gh ids1 is0 False + let eval = (Lens.view Lens._3) . whnf' evaluate bndrs mempty tcm gh ids1 is0 False let eTy = inferCoreTypeOf tcm e untran <- isUntranslatableType False eTy case untran of diff --git a/clash-lib/src/Clash/Normalize/Transformations/EtaExpand.hs b/clash-lib/src/Clash/Normalize/Transformations/EtaExpand.hs index 16c123c200..682030c1a3 100644 --- a/clash-lib/src/Clash/Normalize/Transformations/EtaExpand.hs +++ b/clash-lib/src/Clash/Normalize/Transformations/EtaExpand.hs @@ -71,7 +71,7 @@ etaExpansionTL (TransformContext is0 ctx) (Lam bndr e) = do return $ Lam bndr e' etaExpansionTL (TransformContext is0 ctx) (Let (NonRec i x) e) = do - let ctx' = TransformContext (extendInScopeSet is0 i) (LetBody [i] : ctx) + let ctx' = TransformContext (extendInScopeSet is0 i) (LetBody [(i,x)] : ctx) e' <- etaExpansionTL ctx' e case stripLambda e' of (bs@(_:_),e2) -> do @@ -81,7 +81,7 @@ etaExpansionTL (TransformContext is0 ctx) (Let (NonRec i x) e) = do etaExpansionTL (TransformContext is0 ctx) (Let (Rec xes) e) = do let bndrs = map fst xes - ctx' = TransformContext (extendInScopeSetList is0 bndrs) (LetBody bndrs : ctx) + ctx' = TransformContext (extendInScopeSetList is0 bndrs) (LetBody xes : ctx) e' <- etaExpansionTL ctx' e case stripLambda e' of (bs@(_:_),e2) -> do diff --git a/clash-lib/src/Clash/Rewrite/Combinators.hs b/clash-lib/src/Clash/Rewrite/Combinators.hs index 379e12af1b..8e1e6fc716 100644 --- a/clash-lib/src/Clash/Rewrite/Combinators.hs +++ b/clash-lib/src/Clash/Rewrite/Combinators.hs @@ -54,7 +54,7 @@ allR trans (TransformContext is c) (Cast e ty1 ty2) = allR trans (TransformContext is c) (Letrec xes e) = do xes' <- traverse rewriteBind xes - e' <- trans (TransformContext is' (LetBody bndrs:c)) e + e' <- trans (TransformContext is' (LetBody xes:c)) e return (Letrec xes' e') where bndrs = map fst xes diff --git a/clash-lib/src/Clash/Rewrite/Util.hs b/clash-lib/src/Clash/Rewrite/Util.hs index 3d1a30ed09..420fa29574 100644 --- a/clash-lib/src/Clash/Rewrite/Util.hs +++ b/clash-lib/src/Clash/Rewrite/Util.hs @@ -79,7 +79,8 @@ import Clash.Core.Var import Clash.Core.VarEnv (InScopeSet, extendInScopeSet, extendInScopeSetList, mkInScopeSet, uniqAway, uniqAway', mapVarEnv, eltsVarEnv, unitVarSet, emptyVarEnv, - mkVarEnv, eltsVarSet, elemVarEnv, lookupVarEnv, extendVarEnv, elemVarSet) + mkVarEnv, eltsVarSet, elemVarEnv, lookupVarEnv, extendVarEnv, elemVarSet, + differenceVarEnv) import Clash.Data.UniqMap (UniqMap) import qualified Clash.Data.UniqMap as UniqMap import Clash.Debug @@ -730,7 +731,7 @@ whnfRW -> Term -> Rewrite extra -> RewriteMonad extra Term -whnfRW isSubj ctx@(TransformContext is0 _) e rw = do +whnfRW isSubj ctx@(TransformContext is0 hist) e rw = do tcm <- Lens.view tcCache bndrs <- Lens.use bindings eval <- Lens.view evaluator @@ -738,11 +739,18 @@ whnfRW isSubj ctx@(TransformContext is0 _) e rw = do let (ids1,ids2) = splitSupply ids uniqSupply Lens..= ids2 gh <- Lens.use globalHeap + let lh = localBinders mempty hist - case whnf' eval bndrs tcm gh ids1 is0 isSubj e of + case whnf' eval bndrs lh tcm gh ids1 is0 isSubj e of (!gh1,ph,v) -> do globalHeap Lens..= gh1 - bindPureHeap tcm ph rw ctx v + bindPureHeap tcm (ph `differenceVarEnv` lh) rw ctx v + where + localBinders acc [] = acc + localBinders !acc (h:hs) = case h of + LetBody ls -> localBinders (acc <> mkVarEnv ls) hs + _ -> localBinders acc hs + {-# SCC whnfRW #-} -- | Binds variables on the PureHeap over the result of the rewrite @@ -791,7 +799,7 @@ bindPureHeap tcm heap rw ctx0@(TransformContext is0 hist) e = do where heapIds = map fst bndrs is1 = extendInScopeSetList is0 heapIds - ctx = TransformContext is1 (LetBody heapIds : hist) + ctx = TransformContext is1 (LetBody bndrs : hist) bndrs = map toLetBinding $ UniqMap.toList heap diff --git a/clash-term/Main.hs b/clash-term/Main.hs index 5f0f6e14f5..2868a14da5 100644 --- a/clash-term/Main.hs +++ b/clash-term/Main.hs @@ -105,7 +105,7 @@ instance Diff Term where (Letrec bnds body, LetBinding i' _) -> Letrec (mapBindings i' bnds) body (Letrec bnds t, LetBody is) -> - if (fst <$> bnds) == is + if (fst <$> bnds) == (fst <$> is) then Letrec bnds (go t) else error "Ctx.LetBody: different bindings" (Lam i t, LamBody i') -> From 10ac261d1af6de496b343866c519263ab8715002 Mon Sep 17 00:00:00 2001 From: Christiaan Baaij Date: Wed, 25 Oct 2023 16:02:29 +0200 Subject: [PATCH 3/3] Avoid bang-patterns in Internal.Index It generates core that pattern matches on the constructor of the Index data type. This can mess up certain parts of the Clash compiler. --- .../src/Clash/Sized/Internal/Index.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/clash-prelude/src/Clash/Sized/Internal/Index.hs b/clash-prelude/src/Clash/Sized/Internal/Index.hs index 0509fcd646..9ea0e0b16a 100644 --- a/clash-prelude/src/Clash/Sized/Internal/Index.hs +++ b/clash-prelude/src/Clash/Sized/Internal/Index.hs @@ -112,7 +112,7 @@ import {-# SOURCE #-} Clash.Sized.Internal.BitVector (BitVector (BV), high, low, import qualified Clash.Sized.Internal.BitVector as BV import Clash.Promoted.Nat (SNat(..), snatToNum, natToInteger, leToPlusKN) import Clash.XException - (ShowX (..), NFDataX (..), errorX, showsPrecXWith, rwhnfX) + (ShowX (..), NFDataX (..), errorX, showsPrecXWith, rwhnfX, seqX) {- $setup >>> import Clash.Sized.Internal.Index @@ -379,9 +379,9 @@ times# :: Index m -> Index n -> Index (((m - 1) * (n - 1)) + 1) times# (I a) (I b) = I (a * b) instance (KnownNat n, 1 <= n) => SaturatingNum (Index n) where - satAdd SatWrap !a !b = + satAdd SatWrap a b = case natToInteger @n of - 1 -> fromInteger# 0 + 1 -> a +# b _ -> leToPlusKN @1 @n $ case plus# a b of z | let m = fromInteger# (natToInteger @n) @@ -419,9 +419,9 @@ instance (KnownNat n, 1 <= n) => SaturatingNum (Index n) where then fromInteger# 0 else a -# b - satMul SatWrap !a !b = + satMul SatWrap a b = case natToInteger @n of - 1 -> fromInteger# 0 + 1 -> a *# b 2 -> case a of {0 -> 0; _ -> b} _ -> leToPlusKN @1 @n $ case times# a b of @@ -446,9 +446,9 @@ instance (KnownNat n, 1 <= n) => SaturatingNum (Index n) where , z > m -> maxBound# z -> resize# z - satSucc SatError !a = + satSucc SatError a = case natToInteger @n of - 1 -> errorX "Index.satSucc: overflow" + 1 -> a `seqX` errorX "Index.satSucc: overflow" _ -> satAdd SatError a $ fromInteger# 1 satSucc satMode !a = case natToInteger @n of @@ -456,9 +456,9 @@ instance (KnownNat n, 1 <= n) => SaturatingNum (Index n) where _ -> satAdd satMode a $ fromInteger# 1 {-# INLINE satSucc #-} - satPred SatError !a = + satPred SatError a = case natToInteger @n of - 1 -> errorX "Index.satPred: underflow" + 1 -> a `seqX` errorX "Index.satPred: underflow" _ -> satSub SatError a $ fromInteger# 1 satPred satMode !a = case natToInteger @n of