From acecb0cfb62bd0f765585e07ea4360ab8a9e07dd Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Fri, 17 Apr 2026 07:24:57 +0000 Subject: [PATCH 1/4] Skip redundant unifyTypes in entailment fundep enforcement MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit When the entailment solver enforces functional dependencies after matching an instance, it unifies each inferred type with the corresponding constraint type. For constraints on wide row types (e.g. HasField on a 667-field record), this triggers O(n) row alignment via alignRowsWith — even when both sides are structurally identical (the inferred type IS the constraint type after variable substitution). Add an eqType guard before unifyTypes to skip the unification when the inferred type already equals the target type. eqType is a simple structural equality check (O(n) but no sorting, no recursive unification, no cache insertion) compared to the full unifyRows path (rowToSortedList O(n log n) + alignment O(n) + recursive unifications). Measured on pr-admin (1758 modules, optimised -O2 build): full build: 74s -> 63s (-15%) no-change: 1.2s (unchanged) prelude-edit:5.3s (unchanged) leaf-edit: 2.0s (unchanged) All 1340 tests pass. Co-Authored-By: Claude Opus 4.6 (1M context) --- src/Language/PureScript/TypeChecker/Entailment.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 7895e541b1..6d88e7c4ca 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -16,7 +16,7 @@ import Protolude (ordNub, headMay) import Control.Arrow (second, (&&&)) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State (MonadState(..), MonadTrans(..), StateT(..), evalStateT, execStateT, gets, modify) -import Control.Monad (foldM, guard, join, zipWithM, zipWithM_, (<=<)) +import Control.Monad (foldM, guard, join, unless, zipWithM, zipWithM_, (<=<)) import Control.Monad.Writer (MonadWriter(..), WriterT(..)) import Data.Monoid (Any(..)) @@ -295,7 +295,8 @@ entails SolverOptions{..} constraint context hints = subst' <- lift . lift $ withFreshTypes tcd (fmap (substituteType currentSubst) subst) lift . lift $ zipWithM_ (\t1 t2 -> do let inferredType = replaceAllTypeVars (M.toList subst') t1 - unifyTypes inferredType t2) (tcdInstanceTypes tcd) tys'' + unless (eqType inferredType t2) $ + unifyTypes inferredType t2) (tcdInstanceTypes tcd) tys'' currentSubst' <- lift . lift $ gets checkSubstitution let subst'' = fmap (substituteType currentSubst') subst' -- Solve any necessary subgoals From beaa8e0289bfa6787be2b6cf2dc94e8be6a86cb5 Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Mon, 20 Apr 2026 10:58:07 +0000 Subject: [PATCH 2/4] Fix ci, add comment --- ci/build.sh | 2 +- src/Language/PureScript/TypeChecker/Entailment.hs | 8 ++++++++ 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/ci/build.sh b/ci/build.sh index b2ef51251e..2b0d925a7f 100755 --- a/ci/build.sh +++ b/ci/build.sh @@ -25,7 +25,7 @@ set -ex # We test with --haddock because haddock generation can fail if there is invalid doc-comment syntax, # and these failures are very easy to miss otherwise. -STACK="stack --no-terminal --haddock --jobs=2" +STACK="stack --no-terminal --haddock --no-haddock-deps --jobs=2" STACK_OPTS="--test" if [ "$CI_RELEASE" = "true" -o "$CI_PRERELEASE" = "true" ] diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 6d88e7c4ca..8c9c5e8ec7 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -293,6 +293,14 @@ entails SolverOptions{..} constraint context hints = let subst = fmap head substs currentSubst <- lift . lift $ gets checkSubstitution subst' <- lift . lift $ withFreshTypes tcd (fmap (substituteType currentSubst) subst) + -- Skip unification when inferredType and t2 are structurally equal: + -- identical types always unify with no new bindings, so the call + -- is a no-op. For wide row types (e.g. a 667-field record in a + -- HasField constraint), unifyTypes dispatches to unifyRows which + -- sorts both sides, allocates intermediate RowListItem lists, and + -- walks the merge-join — all wasted work. eqType walks the type + -- trees in lockstep without allocation and short-circuits on the + -- first mismatch. lift . lift $ zipWithM_ (\t1 t2 -> do let inferredType = replaceAllTypeVars (M.toList subst') t1 unless (eqType inferredType t2) $ From 76b95816b1b43fe6b7ec193d2b6d8ba38dbea9b3 Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Mon, 20 Apr 2026 11:50:06 +0000 Subject: [PATCH 3/4] Pass --haddock --no-haddock-deps to stack exec steps The build step uses --haddock --no-haddock-deps, which affects the install-path hash. Downstream steps (glob-test, build-package-set, libtinfo check) called stack exec/path without those flags, resolving to a different install hash and failing to find the purs binary. Co-Authored-By: Claude Opus 4.7 (1M context) --- .github/workflows/ci.yml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 9b5b322dde..c99a07d2f7 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -128,7 +128,7 @@ jobs: # launch `stack exec`. The actual glob checks happen in a temporary directory. run: | apt-get install -y tree - ../ci/fix-home stack exec bash ../glob-test.sh + ../ci/fix-home stack --haddock --no-haddock-deps exec bash ../glob-test.sh - name: "(Linux only) Build the entire package set" if: startsWith(matrix.image, 'haskell') @@ -145,15 +145,15 @@ jobs: # We upgrade npm to fix this run: | apt-get install -y jq - ../ci/fix-home stack --haddock exec ../ci/build-package-set.sh + ../ci/fix-home stack --haddock --no-haddock-deps exec ../ci/build-package-set.sh - name: Verify that 'libtinfo' isn't in binary if: runner.os == 'Linux' working-directory: "sdist-test" run: | - if [ $(ldd $(../ci/fix-home stack path --local-doc-root)/../bin/purs | grep 'libtinfo' | wc -l) -ge 1 ]; then + if [ $(ldd $(../ci/fix-home stack --haddock --no-haddock-deps path --local-doc-root)/../bin/purs | grep 'libtinfo' | wc -l) -ge 1 ]; then echo "libtinfo detected" - ldd $(../ci/fix-home stack path --local-doc-root)/../bin/purs | grep 'libtinfo' + ldd $(../ci/fix-home stack --haddock --no-haddock-deps path --local-doc-root)/../bin/purs | grep 'libtinfo' exit 1 fi From 6f041e59fdd2079aee828c37f6e2f7ba78f4980d Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Mon, 20 Apr 2026 12:14:21 +0000 Subject: [PATCH 4/4] Resolve purs binary via PATH inside stack exec steps stack path --local-doc-root doesn't inherit flags from the outer stack exec invocation, so it resolved to a different install hash than the build artifacts. Since stack exec already puts the binary on PATH, use command -v / which instead. Co-Authored-By: Claude Opus 4.7 (1M context) --- .github/workflows/ci.yml | 5 +++-- glob-test.sh | 2 +- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index c99a07d2f7..0faec4c9bd 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -151,9 +151,10 @@ jobs: if: runner.os == 'Linux' working-directory: "sdist-test" run: | - if [ $(ldd $(../ci/fix-home stack --haddock --no-haddock-deps path --local-doc-root)/../bin/purs | grep 'libtinfo' | wc -l) -ge 1 ]; then + purs_bin=$(../ci/fix-home stack --haddock --no-haddock-deps exec -- which purs) + if [ $(ldd "$purs_bin" | grep 'libtinfo' | wc -l) -ge 1 ]; then echo "libtinfo detected" - ldd $(../ci/fix-home stack --haddock --no-haddock-deps path --local-doc-root)/../bin/purs | grep 'libtinfo' + ldd "$purs_bin" | grep 'libtinfo' exit 1 fi diff --git a/glob-test.sh b/glob-test.sh index aba4432f31..23afffd448 100644 --- a/glob-test.sh +++ b/glob-test.sh @@ -13,7 +13,7 @@ set -eu -o pipefail shopt -s nullglob -PURS="$(stack path --local-doc-root)/../bin/purs" +PURS="$(command -v purs)" tmpdir=$(mktemp -d) trap 'rm -rf "$tmpdir"' EXIT