Skip to content

unifyTypes: pointer-eq fast-path (-7.5% full build) #17

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
kozak wants to merge 2 commits into
base: type-hash
Choose a base branch
from
Open

unifyTypes: pointer-eq fast-path (-7.5% full build) #17

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
5713e83
Fix hlint warnings introduced by type-hash branch
kozak Apr 28, 2026
b9fcf10
unifyTypes: pointer-eq fast-path before substituteType + cache lookup
kozak Apr 28, 2026
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
14 changes: 11 additions & 3 deletions src/Language/PureScript/TypeChecker/Unify.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
{-# LANGUAGE MagicHash #-}
-- |
-- Functions and instances relating to unification
--
Expand All @@ -17,7 +18,8 @@ module Language.PureScript.TypeChecker.Unify
import Prelude

import Control.Exception (assert)
import Control.Monad (forM_, void, when)
import Control.Monad (forM_, unless, void)
import GHC.Exts (reallyUnsafePtrEquality#, isTrue#)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.State.Class (MonadState(..), gets, modify, state)
import Control.Monad.Writer.Class (MonadWriter(..))
Expand Down Expand Up @@ -113,13 +115,19 @@ unknownsInType t = everythingOnTypes (.) go t []

-- | Unify two types, updating the current substitution
unifyTypes :: SourceType -> SourceType -> TypeCheckM ()
unifyTypes t1 t2 = do
unifyTypes t1 t2
-- Pointer-equal arguments are structurally equal, so unifyTypes is a
-- no-op: no fresh TUnknowns to solve, no errors. Skip substituteType,
-- the hint stack push, and the cache lookup. Sound regardless of the
-- ptr-eq result (False just falls through to the existing path).
| isTrue# (reallyUnsafePtrEquality# t1 t2) = pure ()
| otherwise = do
sub <- gets checkSubstitution
withErrorMessageHint (ErrorUnifyingTypes t1 t2) $ unifyTypes'' (substituteType sub t1) (substituteType sub t2)
where
unifyTypes'' t1' t2'= do
cache <- gets unificationCache
when (not (HS.member (t1', t2') cache)) $ do
unless (HS.member (t1', t2') cache) $ do
modify $ \st -> st { unificationCache = HS.insert (t1', t2') cache }
unifyTypes' t1' t2'
unifyTypes' (TUnknown _ u1) (TUnknown _ u2) | u1 == u2 = return ()
Expand Down
78 changes: 39 additions & 39 deletions src/Language/PureScript/Types.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -301,29 +301,29 @@ modifyFlags f = \case
-- | Per-constructor salt. Distinct so two leaves with the same payload but
-- different constructors get different hashes (e.g. @TypeVar "x"@ vs
-- @TypeLevelString "x"@). Values are arbitrary primes.
ctorSalt_TUnknown, ctorSalt_TypeVar, ctorSalt_TypeLevelString,
ctorSalt_TypeLevelInt, ctorSalt_TypeWildcard, ctorSalt_TypeConstructor,
ctorSalt_TypeOp, ctorSalt_TypeApp, ctorSalt_KindApp, ctorSalt_ForAll,
ctorSalt_ConstrainedType, ctorSalt_Skolem, ctorSalt_REmpty, ctorSalt_RCons,
ctorSalt_KindedType, ctorSalt_BinaryNoParensType, ctorSalt_ParensInType
ctorSaltTUnknown, ctorSaltTypeVar, ctorSaltTypeLevelString,
ctorSaltTypeLevelInt, ctorSaltTypeWildcard, ctorSaltTypeConstructor,
ctorSaltTypeOp, ctorSaltTypeApp, ctorSaltKindApp, ctorSaltForAll,
ctorSaltConstrainedType, ctorSaltSkolem, ctorSaltREmpty, ctorSaltRCons,
ctorSaltKindedType, ctorSaltBinaryNoParensType, ctorSaltParensInType
:: Int
ctorSalt_TUnknown = 1009
ctorSalt_TypeVar = 1013
ctorSalt_TypeLevelString = 1019
ctorSalt_TypeLevelInt = 1021
ctorSalt_TypeWildcard = 1031
ctorSalt_TypeConstructor = 1033
ctorSalt_TypeOp = 1039
ctorSalt_TypeApp = 1049
ctorSalt_KindApp = 1051
ctorSalt_ForAll = 1061
ctorSalt_ConstrainedType = 1063
ctorSalt_Skolem = 1069
ctorSalt_REmpty = 1087
ctorSalt_RCons = 1091
ctorSalt_KindedType = 1093
ctorSalt_BinaryNoParensType = 1097
ctorSalt_ParensInType = 1103
ctorSaltTUnknown = 1009
ctorSaltTypeVar = 1013
ctorSaltTypeLevelString = 1019
ctorSaltTypeLevelInt = 1021
ctorSaltTypeWildcard = 1031
ctorSaltTypeConstructor = 1033
ctorSaltTypeOp = 1039
ctorSaltTypeApp = 1049
ctorSaltKindApp = 1051
ctorSaltForAll = 1061
ctorSaltConstrainedType = 1063
ctorSaltSkolem = 1069
ctorSaltREmpty = 1087
ctorSaltRCons = 1091
ctorSaltKindedType = 1093
ctorSaltBinaryNoParensType = 1097
ctorSaltParensInType = 1103

-- | Build TypeFlags for a leaf node, hashing one payload value.
leafFlags1 :: Hashable x => Word8 -> Int -> x -> TypeFlags
Expand All @@ -333,7 +333,7 @@ leafFlags1 bits salt x = TypeFlags bits (salt `hashWithSalt` x)
-- | Compute hash of a 'Constraint' from its already-hashed children.
constraintHash :: Constraint a -> Int
constraintHash c =
ctorSalt_ConstrainedType
ctorSaltConstrainedType
`hashWithSalt` constraintClass c
`hashWithSalt` constraintData c
`hashWithSalt` map (tfHash . typeFlags) (constraintKindArgs c)
Expand All @@ -350,7 +350,7 @@ forAllNodeFlags vis ident mbK ty sco =
.|. unscoped
unscoped = case sco of Nothing -> tfBits tfHasUnscopedForAlls; _ -> 0
hash_ =
ctorSalt_ForAll
ctorSaltForAll
`hashWithSalt` vis
`hashWithSalt` ident
`hashWithSalt` fmap (tfHash . typeFlags) mbK
Expand Down Expand Up @@ -379,7 +379,7 @@ skolemNodeFlags name mbK i sco =
where
bits = maybe 0 (tfBits . typeFlags) mbK .&. structuralMask
hash_ =
ctorSalt_Skolem
ctorSaltSkolem
`hashWithSalt` name
`hashWithSalt` fmap (tfHash . typeFlags) mbK
`hashWithSalt` i
Expand All @@ -402,7 +402,7 @@ rconsNodeFlags :: Label -> Type a -> Type a -> TypeFlags
rconsNodeFlags l ty rest =
TypeFlags
((tfBits f1 .|. tfBits f2) .&. structuralMask)
(ctorSalt_RCons `hashWithSalt` l `hashWithSalt` tfHash f1 `hashWithSalt` tfHash f2)
(ctorSaltRCons `hashWithSalt` l `hashWithSalt` tfHash f1 `hashWithSalt` tfHash f2)
where
f1 = typeFlags ty
f2 = typeFlags rest
Expand Down Expand Up @@ -462,39 +462,39 @@ instance Serialise a => Serialise (Type a)

pattern TUnknown :: a -> Int -> Type a
pattern TUnknown a i <- TUnknown_ _ a i
where TUnknown a i = TUnknown_ (leafFlags1 0 ctorSalt_TUnknown i) a i
where TUnknown a i = TUnknown_ (leafFlags1 0 ctorSaltTUnknown i) a i

pattern TypeVar :: a -> Text -> Type a
pattern TypeVar a t <- TypeVar_ _ a t
where TypeVar a t = TypeVar_ (leafFlags1 0 ctorSalt_TypeVar t) a t
where TypeVar a t = TypeVar_ (leafFlags1 0 ctorSaltTypeVar t) a t

pattern TypeLevelString :: a -> PSString -> Type a
pattern TypeLevelString a s <- TypeLevelString_ _ a s
where TypeLevelString a s = TypeLevelString_ (leafFlags1 0 ctorSalt_TypeLevelString s) a s
where TypeLevelString a s = TypeLevelString_ (leafFlags1 0 ctorSaltTypeLevelString s) a s

pattern TypeLevelInt :: a -> Integer -> Type a
pattern TypeLevelInt a n <- TypeLevelInt_ _ a n
where TypeLevelInt a n = TypeLevelInt_ (leafFlags1 0 ctorSalt_TypeLevelInt n) a n
where TypeLevelInt a n = TypeLevelInt_ (leafFlags1 0 ctorSaltTypeLevelInt n) a n

pattern TypeWildcard :: a -> WildcardData -> Type a
pattern TypeWildcard a w <- TypeWildcard_ _ a w
where TypeWildcard a w = TypeWildcard_ (leafFlags1 (tfBits tfHasWildcards) ctorSalt_TypeWildcard w) a w
where TypeWildcard a w = TypeWildcard_ (leafFlags1 (tfBits tfHasWildcards) ctorSaltTypeWildcard w) a w

pattern TypeConstructor :: a -> Qualified (ProperName 'TypeName) -> Type a
pattern TypeConstructor a q <- TypeConstructor_ _ a q
where TypeConstructor a q = TypeConstructor_ (leafFlags1 0 ctorSalt_TypeConstructor q) a q
where TypeConstructor a q = TypeConstructor_ (leafFlags1 0 ctorSaltTypeConstructor q) a q

pattern TypeOp :: a -> Qualified (OpName 'TypeOpName) -> Type a
pattern TypeOp a q <- TypeOp_ _ a q
where TypeOp a q = TypeOp_ (leafFlags1 0 ctorSalt_TypeOp q) a q
where TypeOp a q = TypeOp_ (leafFlags1 0 ctorSaltTypeOp q) a q

pattern TypeApp :: a -> Type a -> Type a -> Type a
pattern TypeApp a t1 t2 <- TypeApp_ _ a t1 t2
where TypeApp a t1 t2 = TypeApp_ (binaryNodeFlags ctorSalt_TypeApp t1 t2) a t1 t2
where TypeApp a t1 t2 = TypeApp_ (binaryNodeFlags ctorSaltTypeApp t1 t2) a t1 t2

pattern KindApp :: a -> Type a -> Type a -> Type a
pattern KindApp a t1 t2 <- KindApp_ _ a t1 t2
where KindApp a t1 t2 = KindApp_ (binaryNodeFlags ctorSalt_KindApp t1 t2) a t1 t2
where KindApp a t1 t2 = KindApp_ (binaryNodeFlags ctorSaltKindApp t1 t2) a t1 t2

pattern ForAll :: a -> TypeVarVisibility -> Text -> Maybe (Type a) -> Type a -> Maybe SkolemScope -> Type a
pattern ForAll a vis ident mbK ty sco <- ForAll_ _ a vis ident mbK ty sco
Expand All @@ -510,23 +510,23 @@ pattern Skolem a t mbK i s <- Skolem_ _ a t mbK i s

pattern REmpty :: a -> Type a
pattern REmpty a <- REmpty_ _ a
where REmpty a = REmpty_ (TypeFlags 0 ctorSalt_REmpty) a
where REmpty a = REmpty_ (TypeFlags 0 ctorSaltREmpty) a

pattern RCons :: a -> Label -> Type a -> Type a -> Type a
pattern RCons a l ty rest <- RCons_ _ a l ty rest
where RCons a l ty rest = RCons_ (rconsNodeFlags l ty rest) a l ty rest

pattern KindedType :: a -> Type a -> Type a -> Type a
pattern KindedType a ty k <- KindedType_ _ a ty k
where KindedType a ty k = KindedType_ (binaryNodeFlags ctorSalt_KindedType ty k) a ty k
where KindedType a ty k = KindedType_ (binaryNodeFlags ctorSaltKindedType ty k) a ty k

pattern BinaryNoParensType :: a -> Type a -> Type a -> Type a -> Type a
pattern BinaryNoParensType a t1 t2 t3 <- BinaryNoParensType_ _ a t1 t2 t3
where BinaryNoParensType a t1 t2 t3 = BinaryNoParensType_ (ternaryNodeFlags ctorSalt_BinaryNoParensType t1 t2 t3) a t1 t2 t3
where BinaryNoParensType a t1 t2 t3 = BinaryNoParensType_ (ternaryNodeFlags ctorSaltBinaryNoParensType t1 t2 t3) a t1 t2 t3

pattern ParensInType :: a -> Type a -> Type a
pattern ParensInType a t <- ParensInType_ _ a t
where ParensInType a t = ParensInType_ (unaryNodeFlags ctorSalt_ParensInType t) a t
where ParensInType a t = ParensInType_ (unaryNodeFlags ctorSaltParensInType t) a t

{-# COMPLETE TUnknown, TypeVar, TypeLevelString, TypeLevelInt, TypeWildcard, TypeConstructor, TypeOp, TypeApp, KindApp, ForAll, ConstrainedType, Skolem, REmpty, RCons, KindedType, BinaryNoParensType, ParensInType #-}

Expand Down