diff --git a/changelog/2026-01-29T18_10_05+01_00_fix_3129 b/changelog/2026-01-29T18_10_05+01_00_fix_3129 new file mode 100644 index 0000000000..ab9c343ea8 --- /dev/null +++ b/changelog/2026-01-29T18_10_05+01_00_fix_3129 @@ -0,0 +1 @@ +FIXED: Reduce constants to NF before specialization [#3129](https://github.com/clash-lang/clash-compiler/issues/3129) diff --git a/clash-lib/src/Clash/Normalize/Transformations/Specialize.hs b/clash-lib/src/Clash/Normalize/Transformations/Specialize.hs index 696beb07e4..8fe5935de8 100644 --- a/clash-lib/src/Clash/Normalize/Transformations/Specialize.hs +++ b/clash-lib/src/Clash/Normalize/Transformations/Specialize.hs @@ -2,7 +2,7 @@ Copyright : (C) 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd, 2017-2018, Google Inc., - 2021-2024, QBayLogic B.V. + 2021-2026, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -87,7 +87,7 @@ import Clash.Rewrite.Types , typeTranslator, workFreeBinders, debugOpts, topEntities, specializationLimit) import Clash.Rewrite.Util ( mkBinderFor, mkDerivedName, mkFunction, mkTmBinderFor, setChanged, changed - , normalizeTermTypes, normalizeId) + , normalizeTermTypes, normalizeId, whnfRW) import Clash.Rewrite.WorkFree (isWorkFree) import Clash.Normalize.Types ( NormRewrite, NormalizeSession, specialisationCache, specialisationHistory) @@ -290,9 +290,17 @@ constantSpec ctx@(TransformContext is0 tfCtx) e@(App e1 e2) = do specInfo<- constantSpecInfo ctx e2 if csrFoundConstant specInfo then let newBindings = csrNewBindings specInfo in - if null newBindings then - -- Whole of e2 is constant - specialize ctx (App e1 e2) + if null newBindings then do + -- Whole of e2 is constant, we reduce it here eagerly before specialization + -- because we have observed long running compile times when having + -- recursively defined constants, see: + -- https://github.com/clash-lang/clash-compiler/issues/3129 + e2Red <- case collectArgs e2 of + (Prim p0, _) -> whnfRW False ctx e2 $ \_ctx1 e2Red -> case e2Red of + (collectArgs -> (Prim p1, _)) | primName p0 == primName p1 -> return e2 + _ -> changed e2Red + _ -> return e2 + specialize ctx (App e1 e2Red) else do -- Parts of e2 are constant let is1 = extendInScopeSetList is0 (fst <$> csrNewBindings specInfo) diff --git a/tests/Main.hs b/tests/Main.hs index 530ef86e41..f02e32a503 100755 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -962,6 +962,7 @@ runClashTest = defaultMain , outputTest "PortNamesWithRTree" def{hdlTargets=[Verilog]} , clashLibTest "T1182A" def , clashLibTest "T1182B" def + , runTest "T3129" def{hdlSim=[], clashFlags=["-fclash-spec-limit=400"]} ] , clashTestGroup "Unit" [ runTest "Imap" def diff --git a/tests/shouldwork/TopEntity/T3129.hs b/tests/shouldwork/TopEntity/T3129.hs new file mode 100644 index 0000000000..15c54bffb3 --- /dev/null +++ b/tests/shouldwork/TopEntity/T3129.hs @@ -0,0 +1,33 @@ +module T3129 where + +import Clash.Prelude + +import GHC.Base (isTrue#) +import GHC.Num.Natural (Natural (NS), naturalLogBase#) +import GHC.Prim (eqWord#, plusWord#) + +naturalCLogBase :: Natural -> Natural -> Natural +naturalCLogBase x y = + let z1 = naturalLogBase# x y + z2 = naturalLogBase# x (y-1) + in case y of + 1 -> 0 + _ | isTrue# (z1 `eqWord#` z2) -> NS (z1 `plusWord#` 1##) + | otherwise -> NS z1 + +f :: Natural -> Natural +f m = 2 * (naturalCLogBase 2 m) + +g :: Natural -> Natural +g m = + let i = f m + calc 0 _ _ = 1 + calc 1 val tmp = (val * tmp) `mod` m + calc n val tmp = calc + (if n `mod` 2 == 0 then n `div` 2 else n - 1 ) + (if n `mod` 2 == 0 then val * val `mod` m else val ) + (if n `mod` 2 == 0 then tmp `mod` m else (tmp * val) `mod` m) + in calc (m - i - 1) 2 1 + +topEntity :: Natural +topEntity = g 0xffffffff00000001000000000000000000000000ffffffffffffffffffffffff