type-hash: HashSet for unificationCache (-15.4% full build on pr-admin)

purescript.cabal

@@ -167,8 +167,8 @@ common defaults
     cheapskate >=0.1.1.2 && <0.2,
     clock >=0.8.3 && <0.9,
     containers >=0.6.5.1 && <0.7,
-    -- unordered-containers,
-    -- hashable,
+    unordered-containers >=0.2.19.1 && <0.3,
+    hashable >=1.4.2.0 && <1.5,
     cryptonite ==0.30.*,
     data-ordlist >=0.4.7.0 && <0.5,
     deepseq >=1.4.6.1 && <1.5,

src/Language/PureScript/AST/SourcePos.hs

@@ -9,6 +9,7 @@ import Prelude
 import Codec.Serialise (Serialise)
 import Control.DeepSeq (NFData)
 import Data.Aeson ((.=), (.:))
+import Data.Hashable (Hashable)
 import Data.Text (Text)
 import GHC.Generics (Generic)
 import Language.PureScript.Comments (Comment)
@@ -27,6 +28,8 @@ data SourcePos = SourcePos
     -- ^ Column number
   } deriving (Show, Eq, Ord, Generic, NFData, Serialise)
 
+instance Hashable SourcePos
+
 displaySourcePos :: SourcePos -> Text
 displaySourcePos sp =
   "line " <> T.pack (show (sourcePosLine sp)) <>

src/Language/PureScript/Label.hs

@@ -4,6 +4,7 @@ import Prelude
 import GHC.Generics (Generic)
 import Codec.Serialise (Serialise)
 import Control.DeepSeq (NFData)
+import Data.Hashable (Hashable(..))
 import Data.Monoid ()
 import Data.String (IsString(..))
 import Data.Aeson qualified as A
@@ -19,3 +20,5 @@ newtype Label = Label { runLabel :: PSString }
 
 instance NFData Label
 instance Serialise Label
+instance Hashable Label where
+  hashWithSalt s (Label p) = hashWithSalt s p

src/Language/PureScript/Names.hs

@@ -12,6 +12,7 @@ import Control.Applicative ((<|>))
 import Control.Monad.Supply.Class (MonadSupply(..))
 import Control.DeepSeq (NFData)
 import Data.Functor.Contravariant (contramap)
+import Data.Hashable (Hashable(..))
 import Data.Vector qualified as V
 
 import GHC.Generics (Generic)
@@ -36,6 +37,7 @@ data Name
 
 instance NFData Name
 instance Serialise Name
+instance Hashable Name
 
 getIdentName :: Name -> Maybe Ident
 getIdentName (IdentName name) = Just name
@@ -75,6 +77,7 @@ data InternalIdentData
 
 instance NFData InternalIdentData
 instance Serialise InternalIdentData
+instance Hashable InternalIdentData
 
 -- |
 -- Names for value identifiers
@@ -100,6 +103,7 @@ data Ident
 
 instance NFData Ident
 instance Serialise Ident
+instance Hashable Ident
 
 unusedIdent :: Text
 unusedIdent = "$__unused"
@@ -132,6 +136,8 @@ newtype OpName (a :: OpNameType) = OpName { runOpName :: Text }
 
 instance NFData (OpName a)
 instance Serialise (OpName a)
+instance Hashable (OpName a) where
+  hashWithSalt s (OpName t) = hashWithSalt s t
 
 instance ToJSON (OpName a) where
   toJSON = toJSON . runOpName
@@ -161,6 +167,8 @@ newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: Text }
 
 instance NFData (ProperName a)
 instance Serialise (ProperName a)
+instance Hashable (ProperName a) where
+  hashWithSalt s (ProperName t) = hashWithSalt s t
 
 instance ToJSON (ProperName a) where
   toJSON = toJSON . runProperName
@@ -193,6 +201,8 @@ newtype ModuleName = ModuleName Text
   deriving newtype Serialise
 
 instance NFData ModuleName
+instance Hashable ModuleName where
+  hashWithSalt s (ModuleName t) = hashWithSalt s t
 
 runModuleName :: ModuleName -> Text
 runModuleName (ModuleName name) = name
@@ -213,6 +223,7 @@ pattern ByNullSourcePos = BySourcePos (SourcePos 0 0)
 
 instance NFData QualifiedBy
 instance Serialise QualifiedBy
+instance Hashable QualifiedBy
 
 isBySourcePos :: QualifiedBy -> Bool
 isBySourcePos (BySourcePos _) = True
@@ -234,6 +245,7 @@ data Qualified a = Qualified QualifiedBy a
 
 instance NFData a => NFData (Qualified a)
 instance Serialise a => Serialise (Qualified a)
+instance Hashable a => Hashable (Qualified a)
 
 showQualified :: (a -> Text) -> Qualified a -> Text
 showQualified f (Qualified (BySourcePos  _) a) = f a

src/Language/PureScript/PSString.hs

@@ -18,6 +18,7 @@ import Control.Applicative ((<|>))
 import Data.Char qualified as Char
 import Data.Bits (shiftR)
 import Data.Either (fromRight)
+import Data.Hashable (Hashable(..))
 import Data.List (unfoldr)
 import Data.Scientific (toBoundedInteger)
 import Data.String (IsString(..))
@@ -53,6 +54,8 @@ newtype PSString = PSString { toUTF16CodeUnits :: [Word16] }
 
 instance NFData PSString
 instance Serialise PSString
+instance Hashable PSString where
+  hashWithSalt s (PSString ws) = hashWithSalt s ws
 
 instance Show PSString where
   show = show . codePoints

src/Language/PureScript/TypeChecker/Monad.hs

@@ -14,6 +14,7 @@ import Control.Monad.State.Strict qualified as StrictState
 
 import Data.Maybe (fromMaybe)
 import Data.IntMap.Lazy qualified as IM
+import Data.HashSet qualified as HS
 import Data.Map qualified as M
 import Data.Set qualified as S
 import Data.Text (Text, isPrefixOf, unpack)
@@ -133,7 +134,7 @@ data CheckState = CheckState
   , checkConstructorImportsForCoercible :: S.Set (ModuleName, Qualified (ProperName 'ConstructorName))
   -- ^ Newtype constructors imports required to solve Coercible constraints.
   -- We have to keep track of them so that we don't emit unused import warnings.
-  , unificationCache :: S.Set (SourceType, SourceType)
+  , unificationCache :: HS.HashSet (SourceType, SourceType)
   }
 
 -- | Create an empty @CheckState@

src/Language/PureScript/TypeChecker/Synonyms.hs

@@ -22,9 +22,9 @@ import Language.PureScript.Names (ProperName, ProperNameType(..), Qualified)
 import Language.PureScript.TypeChecker.Monad (getEnv, TypeCheckM)
 import Language.PureScript.Types
   ( SourceType, Type(..), TypeFlags
-  , combineFlags, completeBinderList, constraintNodeFlags, everythingOnTypes, forAllNodeFlags
-  , getAnnForType, hasFlag, overConstraintArgsAll, replaceAllTypeVars
-  , setFlag, skolemNodeFlags, tfSynonymsFree, typeFlags
+  , completeBinderList, everythingOnTypes
+  , getAnnForType, hasFlag, modifyFlags, overConstraintArgsAll
+  , replaceAllTypeVars, setFlag, tfSynonymsFree, typeFlags
   )
 
 -- | Type synonym information (arguments with kinds, aliased type), indexed by name
@@ -50,34 +50,20 @@ replaceAllTypeSynonyms' syns kinds
   sf :: TypeFlags -> TypeFlags
   sf = setFlag tfSynonymsFree
 
-  -- Mark a single node as synonym-free (no recursion)
+  -- Mark a single node as synonym-free (no recursion). 'modifyFlags' is
+  -- INLINEd, so GHC fuses construction (via pattern synonym) + flag mutation
+  -- into a single allocation via case-of-known-constructor.
   markSF :: SourceType -> SourceType
-  markSF (TUnknown_ f a b) = TUnknown_ (sf f) a b
-  markSF (TypeVar_ f a b) = TypeVar_ (sf f) a b
-  markSF (TypeLevelString_ f a b) = TypeLevelString_ (sf f) a b
-  markSF (TypeLevelInt_ f a b) = TypeLevelInt_ (sf f) a b
-  markSF (TypeWildcard_ f a b) = TypeWildcard_ (sf f) a b
-  markSF (TypeConstructor_ f a b) = TypeConstructor_ (sf f) a b
-  markSF (TypeOp_ f a b) = TypeOp_ (sf f) a b
-  markSF (TypeApp_ f a t1 t2) = TypeApp_ (sf f) a t1 t2
-  markSF (KindApp_ f a t1 t2) = KindApp_ (sf f) a t1 t2
-  markSF (ForAll_ f a v i k t s) = ForAll_ (sf f) a v i k t s
-  markSF (ConstrainedType_ f a c t) = ConstrainedType_ (sf f) a c t
-  markSF (Skolem_ f a n k i s) = Skolem_ (sf f) a n k i s
-  markSF (REmpty_ f a) = REmpty_ (sf f) a
-  markSF (RCons_ f a l t r) = RCons_ (sf f) a l t r
-  markSF (KindedType_ f a t k) = KindedType_ (sf f) a t k
-  markSF (BinaryNoParensType_ f a t1 t2 t3) = BinaryNoParensType_ (sf f) a t1 t2 t3
-  markSF (ParensInType_ f a t) = ParensInType_ (sf f) a t
+  markSF = modifyFlags sf
 
   -- Main walk: try synonym expansion at potential application sites,
   -- then recurse into children. Sets tfSynonymsFree on all output nodes.
   walk :: SourceType -> Either MultipleErrors SourceType
   walk t | hasFlag tfSynonymsFree (typeFlags t) = Right t
-  walk t@(TypeApp_ _ _ _ _) = trySyn t >>= walkChildren
-  walk t@(KindApp_ _ _ _ _) = trySyn t >>= walkChildren
-  walk t@(TypeConstructor_ _ _ _) = trySyn t >>= \t' -> case t' of
-    TypeConstructor_ _ _ _ -> Right (markSF t')  -- leaf
+  walk t@(TypeApp _ _ _) = trySyn t >>= walkChildren
+  walk t@(KindApp _ _ _) = trySyn t >>= walkChildren
+  walk t@(TypeConstructor _ _) = trySyn t >>= \t' -> case t' of
+    TypeConstructor _ _ -> Right (markSF t')  -- leaf
     _ -> walkChildren t'  -- synonym expanded to non-leaf
   walk t = walkChildren t
 
@@ -101,36 +87,38 @@ replaceAllTypeSynonyms' syns kinds
   go ss c kargs args (KindApp _ f arg) = go ss c (arg : kargs) args f
   go _ _ _ _ _ = return Nothing
 
-  -- Walk children and reconstruct with recomputed structural flags + tfSynonymsFree.
-  -- Uses raw constructors to set flags in a single allocation.
+  -- Walk children and reconstruct via pattern synonyms (which compute flags)
+  -- + markSF (which sets the synonym-free bit). The pattern synonym builder
+  -- and modifyFlags are both INLINE; GHC fuses them via case-of-known-
+  -- constructor into a single allocation per node.
   walkChildren :: SourceType -> Either MultipleErrors SourceType
-  walkChildren (TypeApp_ _ ann t1 t2) = do
+  walkChildren (TypeApp ann t1 t2) = do
     t1' <- walk t1; t2' <- walk t2
-    return $! TypeApp_ (sf (typeFlags t1' `combineFlags` typeFlags t2')) ann t1' t2'
-  walkChildren (KindApp_ _ ann t1 t2) = do
+    return $! markSF (TypeApp ann t1' t2')
+  walkChildren (KindApp ann t1 t2) = do
     t1' <- walk t1; t2' <- walk t2
-    return $! KindApp_ (sf (typeFlags t1' `combineFlags` typeFlags t2')) ann t1' t2'
-  walkChildren (ForAll_ _ ann vis ident mbK ty sco) = do
+    return $! markSF (KindApp ann t1' t2')
+  walkChildren (ForAll ann vis ident mbK ty sco) = do
     mbK' <- traverse walk mbK; ty' <- walk ty
-    return $! ForAll_ (sf (forAllNodeFlags mbK' ty' sco)) ann vis ident mbK' ty' sco
-  walkChildren (ConstrainedType_ _ ann c ty) = do
+    return $! markSF (ForAll ann vis ident mbK' ty' sco)
+  walkChildren (ConstrainedType ann c ty) = do
     c' <- overConstraintArgsAll (mapM walk) c; ty' <- walk ty
-    return $! ConstrainedType_ (sf (constraintNodeFlags c' ty')) ann c' ty'
-  walkChildren (Skolem_ _ ann name mbK i sc) = do
+    return $! markSF (ConstrainedType ann c' ty')
+  walkChildren (Skolem ann name mbK i sc) = do
     mbK' <- traverse walk mbK
-    return $! Skolem_ (sf (skolemNodeFlags mbK')) ann name mbK' i sc
-  walkChildren (RCons_ _ ann name ty rest) = do
+    return $! markSF (Skolem ann name mbK' i sc)
+  walkChildren (RCons ann name ty rest) = do
     ty' <- walk ty; rest' <- walk rest
-    return $! RCons_ (sf (typeFlags ty' `combineFlags` typeFlags rest')) ann name ty' rest'
-  walkChildren (KindedType_ _ ann ty k) = do
+    return $! markSF (RCons ann name ty' rest')
+  walkChildren (KindedType ann ty k) = do
     ty' <- walk ty; k' <- walk k
-    return $! KindedType_ (sf (typeFlags ty' `combineFlags` typeFlags k')) ann ty' k'
-  walkChildren (BinaryNoParensType_ _ ann t1 t2 t3) = do
+    return $! markSF (KindedType ann ty' k')
+  walkChildren (BinaryNoParensType ann t1 t2 t3) = do
     t1' <- walk t1; t2' <- walk t2; t3' <- walk t3
-    return $! BinaryNoParensType_ (sf (typeFlags t1' `combineFlags` typeFlags t2' `combineFlags` typeFlags t3')) ann t1' t2' t3'
-  walkChildren (ParensInType_ _ ann t) = do
+    return $! markSF (BinaryNoParensType ann t1' t2' t3')
+  walkChildren (ParensInType ann t) = do
     t' <- walk t
-    return $! ParensInType_ (sf (typeFlags t')) ann t'
+    return $! markSF (ParensInType ann t')
   walkChildren other = return $! markSF other
 
   lookupKindArgs :: Qualified (ProperName 'TypeName) -> [Text]

src/Language/PureScript/TypeChecker/Unify.hs

@@ -34,7 +34,7 @@ import Language.PureScript.TypeChecker.Kinds (elaborateKind, instantiateKind, un
 import Language.PureScript.TypeChecker.Monad (CheckState(..), Substitution(..), UnkLevel(..), Unknown, getLocalContext, guardWith, lookupUnkName, withErrorMessageHint, TypeCheckM)
 import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, skolemize)
 import Language.PureScript.Types (Constraint(..), pattern REmptyKinded, RowListItem(..), SourceType, Type(..), WildcardData(..), alignRowsWith, everythingOnTypes, everywhereOnTypes, everywhereOnTypesM, getAnnForType, hasFlag, mkForAll, rowFromList, srcTUnknown, tfHasWildcards, typeFlags)
-import Data.Set qualified as S
+import Data.HashSet qualified as HS
 
 -- | Generate a fresh type variable with an unknown kind. Avoid this if at all possible.
 freshType :: TypeCheckM SourceType
@@ -119,8 +119,8 @@ unifyTypes t1 t2 = do
   where
   unifyTypes'' t1' t2'= do
     cache <- gets unificationCache
-    when (S.notMember (t1', t2') cache) $ do
-      modify $ \st -> st { unificationCache = S.insert (t1', t2') cache }
+    when (not (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 ()
   unifyTypes' (TUnknown _ u) t = solveType u t