From e3d18718ddbc019c20595d1df6336b2bb566f284 Mon Sep 17 00:00:00 2001
From: Jakub Majocha <1760221+majocha@users.noreply.github.com>
Date: Mon, 3 Nov 2025 18:42:30 +0100
Subject: [PATCH 01/10] add test
---
.../FSharp.Compiler.ComponentTests.fsproj | 1 +
.../TypeChecks/CrgpLibrary.fs | 34 +++++++++++++++++++
.../TypeChecks/TypeRelations.fs | 12 +++++++
3 files changed, 47 insertions(+)
create mode 100644 tests/FSharp.Compiler.ComponentTests/TypeChecks/CrgpLibrary.fs
create mode 100644 tests/FSharp.Compiler.ComponentTests/TypeChecks/TypeRelations.fs
diff --git a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj
index 29847415be2..8f5ace7aade 100644
--- a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj
+++ b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj
@@ -277,6 +277,7 @@
+
diff --git a/tests/FSharp.Compiler.ComponentTests/TypeChecks/CrgpLibrary.fs b/tests/FSharp.Compiler.ComponentTests/TypeChecks/CrgpLibrary.fs
new file mode 100644
index 00000000000..0c64b053d30
--- /dev/null
+++ b/tests/FSharp.Compiler.ComponentTests/TypeChecks/CrgpLibrary.fs
@@ -0,0 +1,34 @@
+module MyModule
+
+type IFoo<'T when 'T :> IFoo<'T>> =
+ abstract member Bar: other:'T -> unit
+
+[]
+type FooBase() =
+
+ interface IFoo with
+ member this.Bar (other: FooBase) = ()
+
+[]
+type FooDerived<'T>() =
+ inherit FooBase()
+
+ interface IFoo> with
+ member this.Bar other = ()
+
+type IFooContainer<'T> =
+ abstract member Foo: FooDerived<'T>
+
+let inline bar<'a when 'a :> IFoo<'a>> (x: 'a) (y: 'a) = x.Bar y
+let inline takeSame<'a> (x: 'a) (y: 'a) = ()
+
+// Successfully compiles under .NET 9 + F# 9
+// Error under .NET 10 + F# 10: Program.fs(26,13): Error FS0193 : The type 'FooDerived<'TId>' does not match the type 'FooBase'
+let callBar_NewlyBroken (foo1: IFooContainer<'TId>) (foo2: IFooContainer<'TId>) =
+ bar foo1.Foo foo2.Foo
+
+// Successfully compiles under both versions
+let callBar (foo1: IFooContainer<'TId>) (foo2: IFooContainer<'TId>) =
+ let id1 = foo1.Foo
+ let id2 = foo2.Foo
+ bar id1 id2
\ No newline at end of file
diff --git a/tests/FSharp.Compiler.ComponentTests/TypeChecks/TypeRelations.fs b/tests/FSharp.Compiler.ComponentTests/TypeChecks/TypeRelations.fs
new file mode 100644
index 00000000000..d3110beb697
--- /dev/null
+++ b/tests/FSharp.Compiler.ComponentTests/TypeChecks/TypeRelations.fs
@@ -0,0 +1,12 @@
+module TypeChecks.TypeRelations
+
+open Xunit
+open FSharp.Test.Compiler
+open FSharp.Test
+
+[]
+let ``Unsolved type variables are not cached`` compilation =
+ compilation
+ |> getCompilation
+ |> typecheck
+ |> shouldSucceed
\ No newline at end of file
From aec47e7ac3fcc740786fecaf62626ed917aec5fa Mon Sep 17 00:00:00 2001
From: Jakub Majocha <1760221+majocha@users.noreply.github.com>
Date: Mon, 3 Nov 2025 18:43:08 +0100
Subject: [PATCH 02/10] release notes
---
docs/release-notes/.FSharp.Compiler.Service/11.0.0.md | 1 +
1 file changed, 1 insertion(+)
diff --git a/docs/release-notes/.FSharp.Compiler.Service/11.0.0.md b/docs/release-notes/.FSharp.Compiler.Service/11.0.0.md
index 219ee92ba9f..7a19961bc04 100644
--- a/docs/release-notes/.FSharp.Compiler.Service/11.0.0.md
+++ b/docs/release-notes/.FSharp.Compiler.Service/11.0.0.md
@@ -7,6 +7,7 @@
* Fix: warn FS0049 on upper union case label. ([PR #19003](https://github.com/dotnet/fsharp/pull/19003))
* Type relations cache: handle potentially "infinite" types ([PR #19010](https://github.com/dotnet/fsharp/pull/19010))
* Disallow recursive structs with lifted type parameters ([Issue #18993](https://github.com/dotnet/fsharp/issues/18993), [PR #19031](https://github.com/dotnet/fsharp/pull/19031))
+* Type relations cache: handle unsolved type variables ([Issue #19037](https://github.com/dotnet/fsharp/issues/19037)) ([PR #19040](https://github.com/dotnet/fsharp/pull/19040))
### Added
From b4b951cc16cd259a9bb98449c1789aadec703f2a Mon Sep 17 00:00:00 2001
From: Jakub Majocha <1760221+majocha@users.noreply.github.com>
Date: Mon, 3 Nov 2025 18:50:17 +0100
Subject: [PATCH 03/10] for unsolved always recompute TypeStructure
---
src/Compiler/Utilities/TypeHashing.fs | 56 ++++++++++++++++-----------
src/Compiler/Utilities/lib.fs | 12 ++++++
src/Compiler/Utilities/lib.fsi | 5 +++
3 files changed, 51 insertions(+), 22 deletions(-)
diff --git a/src/Compiler/Utilities/TypeHashing.fs b/src/Compiler/Utilities/TypeHashing.fs
index 8e3752d5d33..92249b43370 100644
--- a/src/Compiler/Utilities/TypeHashing.fs
+++ b/src/Compiler/Utilities/TypeHashing.fs
@@ -379,17 +379,6 @@ module HashTastMemberOrVals =
///
///
module StructuralUtilities =
- []
- type NeverEqual =
- struct
- interface System.IEquatable with
- member _.Equals _ = false
-
- override _.Equals _ = false
- override _.GetHashCode() = 0
- end
-
- static member Singleton = NeverEqual()
[]
type TypeToken =
@@ -399,16 +388,17 @@ module StructuralUtilities =
| TupInfo of b: bool
| MeasureOne
| MeasureRational of int * int
- | NeverEqual of never: NeverEqual
+ | Unsolved
type TypeStructure =
| TypeStructure of TypeToken[]
- | PossiblyInfinite of never: NeverEqual
+ | UnsolvedTypeStructure of TypeToken[]
+ | PossiblyInfinite
let inline toNullnessToken (n: Nullness) =
match n.TryEvaluate() with
| ValueSome k -> TypeToken.Nullness k
- | _ -> TypeToken.NeverEqual NeverEqual.Singleton
+ | _ -> TypeToken.Unsolved
let rec private accumulateMeasure (m: Measure) =
seq {
@@ -425,7 +415,14 @@ module StructuralUtilities =
TypeToken.MeasureRational(GetNumerator r, GetDenominator r)
}
- let rec private accumulateTType (ty: TType) =
+ let rec private accumulateTypar (typar: Typar) =
+ seq {
+ match typar.Solution with
+ | Some ty -> yield! accumulateTType ty
+ | None -> TypeToken.Unsolved
+ }
+
+ and private accumulateTType (ty: TType) =
seq {
match ty with
| TType_ucase(u, tinst) ->
@@ -441,40 +438,55 @@ module StructuralUtilities =
for arg in tinst do
yield! accumulateTType arg
+
| TType_anon(info, tys) ->
TypeToken.Stamp info.Stamp
for arg in tys do
yield! accumulateTType arg
+
| TType_tuple(tupInfo, tys) ->
TypeToken.TupInfo(evalTupInfoIsStruct tupInfo)
for arg in tys do
yield! accumulateTType arg
+
| TType_forall(tps, tau) ->
for tp in tps do
- TypeToken.Stamp tp.Stamp
+ yield! accumulateTypar tp
yield! accumulateTType tau
+
| TType_fun(d, r, n) ->
yield! accumulateTType d
yield! accumulateTType r
toNullnessToken n
+
| TType_var(r, n) ->
- TypeToken.Stamp r.Stamp
toNullnessToken n
+ yield! accumulateTypar r
+
| TType_measure m -> yield! accumulateMeasure m
}
// If the sequence got too long, just drop it, we could be dealing with an infinite type.
- let private toTypeStructure tokens =
- let tokens = tokens |> Seq.truncate 256 |> Array.ofSeq
+ let private toTypeStructure (tokens: TypeToken seq) =
+ let tokens = tokens |> Seq.truncate 256 |> Seq.toArray
- if tokens.Length = 256 then
- PossiblyInfinite NeverEqual.Singleton
+ if Seq.length tokens = 256 then
+ PossiblyInfinite
+ elif tokens |> Array.exists _.IsUnsolved then
+ UnsolvedTypeStructure tokens
else
TypeStructure tokens
/// Get the full structure of a type as a sequence of tokens, suitable for equality
let getTypeStructure =
- Extras.WeakMap.getOrCreate (fun ty -> accumulateTType ty |> toTypeStructure)
+ let shouldCache =
+ function
+ | PossiblyInfinite
+ | UnsolvedTypeStructure _ -> false
+ | _ -> true
+
+ // Speed up repeated calls by caching results for types that yield a stable structure.
+ Extras.WeakMap.cacheConditionally shouldCache (fun ty -> accumulateTType ty |> toTypeStructure)
diff --git a/src/Compiler/Utilities/lib.fs b/src/Compiler/Utilities/lib.fs
index 540ea8c4527..a05bf5d20bc 100755
--- a/src/Compiler/Utilities/lib.fs
+++ b/src/Compiler/Utilities/lib.fs
@@ -473,3 +473,15 @@ module WeakMap =
// Cached factory to avoid allocating a new lambda per lookup.
let factory = ConditionalWeakTable.CreateValueCallback(fun k -> valueFactory k)
fun (key: 'Key when 'Key: not null) -> table.GetValue(key, factory)
+
+ /// Like getOrCreate, but only cache the value if it satisfies the given predicate.
+ let cacheConditionally shouldCache valueFactory =
+ let table = ConditionalWeakTable<_, _>()
+ fun (key: 'Key when 'Key: not null) ->
+ match table.TryGetValue key with
+ | true, value -> value
+ | false, _ ->
+ let value = valueFactory key
+ if shouldCache value then
+ try table.Add(key, value) with _ -> ()
+ value
diff --git a/src/Compiler/Utilities/lib.fsi b/src/Compiler/Utilities/lib.fsi
index fcf977683d3..132fbc42182 100644
--- a/src/Compiler/Utilities/lib.fsi
+++ b/src/Compiler/Utilities/lib.fsi
@@ -307,3 +307,8 @@ module internal WeakMap =
val internal getOrCreate:
valueFactory: ('Key -> 'Value) -> ('Key -> 'Value)
when 'Key: not struct and 'Key: not null and 'Value: not struct
+
+ /// Like getOrCreate, but only cache the value if it satisfies the given predicate.
+ val cacheConditionally:
+ shouldCache: ('Value -> bool) -> valueFactory: ('Key -> 'Value) -> ('Key -> 'Value)
+ when 'Key: not struct and 'Key: not null and 'Value: not struct
From 0939fbaa7cd3eef14676ec77a758097a9174e3df Mon Sep 17 00:00:00 2001
From: Jakub Majocha <1760221+majocha@users.noreply.github.com>
Date: Mon, 3 Nov 2025 23:47:11 +0100
Subject: [PATCH 04/10] nit
Co-authored-by: Brian Rourke Boll
---
src/Compiler/Utilities/TypeHashing.fs | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/src/Compiler/Utilities/TypeHashing.fs b/src/Compiler/Utilities/TypeHashing.fs
index 92249b43370..934001c5cdd 100644
--- a/src/Compiler/Utilities/TypeHashing.fs
+++ b/src/Compiler/Utilities/TypeHashing.fs
@@ -473,7 +473,7 @@ module StructuralUtilities =
let private toTypeStructure (tokens: TypeToken seq) =
let tokens = tokens |> Seq.truncate 256 |> Seq.toArray
- if Seq.length tokens = 256 then
+ if Array.length tokens = 256 then
PossiblyInfinite
elif tokens |> Array.exists _.IsUnsolved then
UnsolvedTypeStructure tokens
From 5f86502dd4d3912c5c47d733a6df4c89a1945e37 Mon Sep 17 00:00:00 2001
From: majocha <1760221+majocha@users.noreply.github.com>
Date: Tue, 4 Nov 2025 17:37:43 +0100
Subject: [PATCH 05/10] wip
---
src/Compiler/Utilities/TypeHashing.fs | 6 +++++-
1 file changed, 5 insertions(+), 1 deletion(-)
diff --git a/src/Compiler/Utilities/TypeHashing.fs b/src/Compiler/Utilities/TypeHashing.fs
index 934001c5cdd..9635bd48dc0 100644
--- a/src/Compiler/Utilities/TypeHashing.fs
+++ b/src/Compiler/Utilities/TypeHashing.fs
@@ -419,7 +419,11 @@ module StructuralUtilities =
seq {
match typar.Solution with
| Some ty -> yield! accumulateTType ty
- | None -> TypeToken.Unsolved
+ | None ->
+ TypeToken.Stamp typar.Stamp
+
+ if typar.Rigidity = TyparRigidity.Flexible then
+ TypeToken.Unsolved
}
and private accumulateTType (ty: TType) =
From 068b3b5f00d10efdffa7d05f7212446d91c3f8e6 Mon Sep 17 00:00:00 2001
From: Jakub Majocha <1760221+majocha@users.noreply.github.com>
Date: Tue, 4 Nov 2025 21:41:23 +0100
Subject: [PATCH 06/10] emit stamps for constrained vars only
---
src/Compiler/Utilities/TypeHashing.fs | 15 ++++++++++-----
1 file changed, 10 insertions(+), 5 deletions(-)
diff --git a/src/Compiler/Utilities/TypeHashing.fs b/src/Compiler/Utilities/TypeHashing.fs
index 9635bd48dc0..99f6984fc3b 100644
--- a/src/Compiler/Utilities/TypeHashing.fs
+++ b/src/Compiler/Utilities/TypeHashing.fs
@@ -388,6 +388,7 @@ module StructuralUtilities =
| TupInfo of b: bool
| MeasureOne
| MeasureRational of int * int
+ | UnconstrainedVar
| Unsolved
type TypeStructure =
@@ -420,10 +421,14 @@ module StructuralUtilities =
match typar.Solution with
| Some ty -> yield! accumulateTType ty
| None ->
- TypeToken.Stamp typar.Stamp
-
- if typar.Rigidity = TyparRigidity.Flexible then
+ if typar.Rigidity <> TyparRigidity.Rigid then
TypeToken.Unsolved
+
+ // We don't emit details of the constraints, just the stamp to avoid collisions.
+ if typar.Constraints.Length > 0 then
+ TypeToken.Stamp typar.Stamp
+ else
+ TypeToken.UnconstrainedVar
}
and private accumulateTType (ty: TType) =
@@ -477,7 +482,7 @@ module StructuralUtilities =
let private toTypeStructure (tokens: TypeToken seq) =
let tokens = tokens |> Seq.truncate 256 |> Seq.toArray
- if Array.length tokens = 256 then
+ if tokens.Length = 256 then
PossiblyInfinite
elif tokens |> Array.exists _.IsUnsolved then
UnsolvedTypeStructure tokens
@@ -492,5 +497,5 @@ module StructuralUtilities =
| UnsolvedTypeStructure _ -> false
| _ -> true
- // Speed up repeated calls by caching results for types that yield a stable structure.
+ // Speed up repeated calls by memoizing results for types that yield a stable structure.
Extras.WeakMap.cacheConditionally shouldCache (fun ty -> accumulateTType ty |> toTypeStructure)
From 25357f82ae0311b2c48aa0da694117257bbd28b1 Mon Sep 17 00:00:00 2001
From: Jakub Majocha <1760221+majocha@users.noreply.github.com>
Date: Tue, 4 Nov 2025 22:20:01 +0100
Subject: [PATCH 07/10] TType_app only
---
src/Compiler/Checking/TypeRelations.fs | 26 ++---
src/Compiler/Utilities/TypeHashing.fs | 130 ++++++++++++-------------
2 files changed, 79 insertions(+), 77 deletions(-)
diff --git a/src/Compiler/Checking/TypeRelations.fs b/src/Compiler/Checking/TypeRelations.fs
index cb71ea87de8..75a06487c61 100644
--- a/src/Compiler/Checking/TypeRelations.fs
+++ b/src/Compiler/Checking/TypeRelations.fs
@@ -29,11 +29,13 @@ type CanCoerce =
type TTypeCacheKey =
| TTypeCacheKey of TypeStructure * TypeStructure * CanCoerce
static member TryGetFromStrippedTypes(ty1, ty2, canCoerce) =
- let t1, t2 = getTypeStructure ty1, getTypeStructure ty2
- if t1.IsPossiblyInfinite || t2.IsPossiblyInfinite then
- ValueNone
- else
- ValueSome (TTypeCacheKey(t1, t2, canCoerce))
+ let tryGetTypeStructure ty =
+ match ty with
+ | TType_app _ -> tryGetTypeStructureOfStrippedType ty
+ | _ -> ValueNone
+
+ (tryGetTypeStructure ty1, tryGetTypeStructure ty2)
+ ||> ValueOption.map2(fun t1 t2 -> TTypeCacheKey(t1, t2, canCoerce))
let getTypeSubsumptionCache =
let factory (g: TcGlobals) =
@@ -137,10 +139,6 @@ let rec TypeFeasiblySubsumesType ndeep (g: TcGlobals) (amap: ImportMap) m (ty1:
let checkSubsumes ty1 ty2 =
match ty1, ty2 with
- | TType_measure _, TType_measure _
- | TType_var _, _ | _, TType_var _ ->
- true
-
| TType_app (tc1, l1, _), TType_app (tc2, l2, _) when tyconRefEq g tc1 tc2 ->
List.lengthsEqAndForall2 (TypesFeasiblyEquiv ndeep g amap m) l1 l2
@@ -160,13 +158,17 @@ let rec TypeFeasiblySubsumesType ndeep (g: TcGlobals) (amap: ImportMap) m (ty1:
// See if any interface in type hierarchy of ty2 is a supertype of ty1
List.exists (TypeFeasiblySubsumesType (ndeep + 1) g amap m ty1 NoCoerce) interfaces
- if g.langVersion.SupportsFeature LanguageFeature.UseTypeSubsumptionCache then
+ match ty1, ty2 with
+ | TType_measure _, TType_measure _
+ | TType_var _, _ | _, TType_var _ ->
+ true
+
+ | _ when g.langVersion.SupportsFeature LanguageFeature.UseTypeSubsumptionCache ->
match TTypeCacheKey.TryGetFromStrippedTypes(ty1, ty2, canCoerce) with
| ValueSome key ->
(getTypeSubsumptionCache g).GetOrAdd(key, fun _ -> checkSubsumes ty1 ty2)
| _ -> checkSubsumes ty1 ty2
- else
- checkSubsumes ty1 ty2
+ | _ -> checkSubsumes ty1 ty2
and TypeFeasiblySubsumesTypeWithSupertypeCheck g amap m ndeep ty1 ty2 =
match GetSuperTypeOfType g amap m ty2 with
diff --git a/src/Compiler/Utilities/TypeHashing.fs b/src/Compiler/Utilities/TypeHashing.fs
index 99f6984fc3b..d956f7e5a50 100644
--- a/src/Compiler/Utilities/TypeHashing.fs
+++ b/src/Compiler/Utilities/TypeHashing.fs
@@ -1,7 +1,6 @@
module internal Internal.Utilities.TypeHashing
open Internal.Utilities.Rational
-open Internal.Utilities.Library
open FSharp.Compiler.AbstractIL.IL
open FSharp.Compiler.Syntax
open FSharp.Compiler.TcGlobals
@@ -9,7 +8,6 @@ open FSharp.Compiler.Text
open FSharp.Compiler.TypedTree
open FSharp.Compiler.TypedTreeBasics
open FSharp.Compiler.TypedTreeOps
-open System.Collections.Immutable
type ObserverVisibility =
| PublicOnly
@@ -126,7 +124,6 @@ module HashAccessibility =
| _ -> true
module rec HashTypes =
- open Microsoft.FSharp.Core.LanguagePrimitives
/// Hash a reference to a type
let hashTyconRef tcref = hashTyconRefImpl tcref
@@ -371,7 +368,7 @@ module HashTastMemberOrVals =
/// * Uses per-compilation stamps (entities, typars, anon records, measures).
/// * Emits shape for union cases (declaring type stamp + case name), tuple structness,
/// function arrows, forall binders, nullness, measures, generic arguments.
-/// * Unknown/variable nullness => NeverEqual token to force inequality (avoid unsound hits).
+/// * Does not include type constraints.
///
/// Non-goals:
/// * Cross-compilation stability.
@@ -385,53 +382,42 @@ module StructuralUtilities =
| Stamp of stamp: Stamp
| UCase of name: string
| Nullness of nullness: NullnessInfo
+ | NullnessUnsolved
| TupInfo of b: bool
+ | Forall of int
| MeasureOne
| MeasureRational of int * int
- | UnconstrainedVar
- | Unsolved
+ | Unsolved of int
+ | Rigid of int
- type TypeStructure =
- | TypeStructure of TypeToken[]
- | UnsolvedTypeStructure of TypeToken[]
- | PossiblyInfinite
+ type TypeStructure = TypeStructure of TypeToken[]
- let inline toNullnessToken (n: Nullness) =
+ type private EmitContext =
+ {
+ typarMap: System.Collections.Generic.Dictionary
+ }
+
+ let inline emitNullness (n: Nullness) =
match n.TryEvaluate() with
| ValueSome k -> TypeToken.Nullness k
- | _ -> TypeToken.Unsolved
+ | ValueNone -> TypeToken.NullnessUnsolved
- let rec private accumulateMeasure (m: Measure) =
+ let rec private emitMeasure (m: Measure) =
seq {
match m with
| Measure.Var mv -> TypeToken.Stamp mv.Stamp
| Measure.Const(tcref, _) -> TypeToken.Stamp tcref.Stamp
| Measure.Prod(m1, m2, _) ->
- yield! accumulateMeasure m1
- yield! accumulateMeasure m2
- | Measure.Inv m1 -> yield! accumulateMeasure m1
+ yield! emitMeasure m1
+ yield! emitMeasure m2
+ | Measure.Inv m1 -> yield! emitMeasure m1
| Measure.One _ -> TypeToken.MeasureOne
| Measure.RationalPower(m1, r) ->
- yield! accumulateMeasure m1
+ yield! emitMeasure m1
TypeToken.MeasureRational(GetNumerator r, GetDenominator r)
}
- let rec private accumulateTypar (typar: Typar) =
- seq {
- match typar.Solution with
- | Some ty -> yield! accumulateTType ty
- | None ->
- if typar.Rigidity <> TyparRigidity.Rigid then
- TypeToken.Unsolved
-
- // We don't emit details of the constraints, just the stamp to avoid collisions.
- if typar.Constraints.Length > 0 then
- TypeToken.Stamp typar.Stamp
- else
- TypeToken.UnconstrainedVar
- }
-
- and private accumulateTType (ty: TType) =
+ and private emitTType (env: EmitContext) (ty: TType) =
seq {
match ty with
| TType_ucase(u, tinst) ->
@@ -439,63 +425,77 @@ module StructuralUtilities =
TypeToken.UCase u.CaseName
for arg in tinst do
- yield! accumulateTType arg
+ yield! emitTType env arg
| TType_app(tcref, tinst, n) ->
TypeToken.Stamp tcref.Stamp
- toNullnessToken n
+ emitNullness n
for arg in tinst do
- yield! accumulateTType arg
+ yield! emitTType env arg
| TType_anon(info, tys) ->
TypeToken.Stamp info.Stamp
for arg in tys do
- yield! accumulateTType arg
+ yield! emitTType env arg
| TType_tuple(tupInfo, tys) ->
TypeToken.TupInfo(evalTupInfoIsStruct tupInfo)
for arg in tys do
- yield! accumulateTType arg
+ yield! emitTType env arg
| TType_forall(tps, tau) ->
for tp in tps do
- yield! accumulateTypar tp
+ env.typarMap.[tp.Stamp] <- env.typarMap.Count
- yield! accumulateTType tau
+ TypeToken.Forall tps.Length
+
+ yield! emitTType env tau
| TType_fun(d, r, n) ->
- yield! accumulateTType d
- yield! accumulateTType r
- toNullnessToken n
+ yield! emitTType env d
+ yield! emitTType env r
+ emitNullness n
| TType_var(r, n) ->
- toNullnessToken n
- yield! accumulateTypar r
-
- | TType_measure m -> yield! accumulateMeasure m
+ emitNullness n
+
+ let typarId =
+ match env.typarMap.TryGetValue r.Stamp with
+ | true, idx -> idx
+ | _ ->
+ let idx = env.typarMap.Count
+ env.typarMap.[r.Stamp] <- idx
+ idx
+
+ match r.Solution with
+ | Some ty ->
+ yield! emitTType env ty
+ | None ->
+ if r.Rigidity = TyparRigidity.Rigid then
+ TypeToken.Rigid typarId
+ else
+ TypeToken.Unsolved typarId
+ | TType_measure m -> yield! emitMeasure m
}
- // If the sequence got too long, just drop it, we could be dealing with an infinite type.
- let private toTypeStructure (tokens: TypeToken seq) =
- let tokens = tokens |> Seq.truncate 256 |> Seq.toArray
+ let tryGetTypeStructureOfStrippedType (ty: TType) =
+
+ let env =
+ {
+ typarMap = System.Collections.Generic.Dictionary()
+ }
+
+ let tokens =
+ emitTType env ty
+ |> Seq.filter (fun t -> t <> TypeToken.Nullness NullnessInfo.WithoutNull)
+ |> Seq.truncate 256
+ |> Seq.toArray
+ // If the sequence got too long, just drop it, we could be dealing with an infinite type.
if tokens.Length = 256 then
- PossiblyInfinite
- elif tokens |> Array.exists _.IsUnsolved then
- UnsolvedTypeStructure tokens
+ ValueNone
else
- TypeStructure tokens
-
- /// Get the full structure of a type as a sequence of tokens, suitable for equality
- let getTypeStructure =
- let shouldCache =
- function
- | PossiblyInfinite
- | UnsolvedTypeStructure _ -> false
- | _ -> true
-
- // Speed up repeated calls by memoizing results for types that yield a stable structure.
- Extras.WeakMap.cacheConditionally shouldCache (fun ty -> accumulateTType ty |> toTypeStructure)
+ ValueSome(TypeStructure tokens)
From e22f124049c2e21d0631e403300282c25163d0f6 Mon Sep 17 00:00:00 2001
From: Jakub Majocha <1760221+majocha@users.noreply.github.com>
Date: Thu, 6 Nov 2025 09:13:49 +0100
Subject: [PATCH 08/10] memoize only stable structures
---
src/Compiler/Checking/TypeRelations.fs | 3 +-
src/Compiler/Utilities/TypeHashing.fs | 46 ++++++++++++++++++--------
2 files changed, 35 insertions(+), 14 deletions(-)
diff --git a/src/Compiler/Checking/TypeRelations.fs b/src/Compiler/Checking/TypeRelations.fs
index 75a06487c61..021370f2067 100644
--- a/src/Compiler/Checking/TypeRelations.fs
+++ b/src/Compiler/Checking/TypeRelations.fs
@@ -31,7 +31,8 @@ type TTypeCacheKey =
static member TryGetFromStrippedTypes(ty1, ty2, canCoerce) =
let tryGetTypeStructure ty =
match ty with
- | TType_app _ -> tryGetTypeStructureOfStrippedType ty
+ | TType_app _ ->
+ tryGetTypeStructureOfStrippedType ty
| _ -> ValueNone
(tryGetTypeStructure ty1, tryGetTypeStructure ty2)
diff --git a/src/Compiler/Utilities/TypeHashing.fs b/src/Compiler/Utilities/TypeHashing.fs
index 7270d69deb3..2d296aa3615 100644
--- a/src/Compiler/Utilities/TypeHashing.fs
+++ b/src/Compiler/Utilities/TypeHashing.fs
@@ -385,6 +385,7 @@ module HashTastMemberOrVals =
///
///
module StructuralUtilities =
+ open Internal.Utilities.Library.Extras
[]
type TypeToken =
@@ -399,17 +400,23 @@ module StructuralUtilities =
| Unsolved of int
| Rigid of int
- type TypeStructure = TypeStructure of TypeToken[]
+ type TypeStructure =
+ | Stable of TypeToken[]
+ | Unstable of TypeToken[]
+ | PossiblyInfinite
type private EmitContext =
{
typarMap: System.Collections.Generic.Dictionary
+ mutable stable: bool
}
- let inline emitNullness (n: Nullness) =
+ let private emitNullness env (n: Nullness) =
match n.TryEvaluate() with
| ValueSome k -> TypeToken.Nullness k
- | ValueNone -> TypeToken.NullnessUnsolved
+ | ValueNone ->
+ env.stable <- false
+ TypeToken.NullnessUnsolved
let rec private emitMeasure (m: Measure) =
seq {
@@ -438,7 +445,7 @@ module StructuralUtilities =
| TType_app(tcref, tinst, n) ->
TypeToken.Stamp tcref.Stamp
- emitNullness n
+ emitNullness env n
for arg in tinst do
yield! emitTType env arg
@@ -466,10 +473,10 @@ module StructuralUtilities =
| TType_fun(d, r, n) ->
yield! emitTType env d
yield! emitTType env r
- emitNullness n
+ emitNullness env n
| TType_var(r, n) ->
- emitNullness n
+ emitNullness env n
let typarId =
match env.typarMap.TryGetValue r.Stamp with
@@ -480,21 +487,22 @@ module StructuralUtilities =
idx
match r.Solution with
- | Some ty ->
- yield! emitTType env ty
+ | Some ty -> yield! emitTType env ty
| None ->
if r.Rigidity = TyparRigidity.Rigid then
TypeToken.Rigid typarId
else
+ env.stable <- false
TypeToken.Unsolved typarId
| TType_measure m -> yield! emitMeasure m
}
- let tryGetTypeStructureOfStrippedType (ty: TType) =
+ let private getTypeStructureOfStrippedType (ty: TType) =
let env =
{
typarMap = System.Collections.Generic.Dictionary()
+ stable = true
}
let tokens =
@@ -504,7 +512,19 @@ module StructuralUtilities =
|> Seq.toArray
// If the sequence got too long, just drop it, we could be dealing with an infinite type.
- if tokens.Length = 256 then
- ValueNone
- else
- ValueSome(TypeStructure tokens)
+ if tokens.Length = 256 then PossiblyInfinite
+ elif not env.stable then Unstable tokens
+ else Stable tokens
+
+ let tryGetTypeStructureOfStrippedType ty =
+ // Speed up repeated calls by memoizing results for types that yield a stable structure.
+ let memoize =
+ WeakMap.cacheConditionally
+ (function
+ | Stable _ -> true
+ | _ -> false)
+ getTypeStructureOfStrippedType
+
+ match memoize ty with
+ | PossiblyInfinite -> ValueNone
+ | ts -> ValueSome ts
From 105e9aa662e63723244e3bacde2af7b0e72dcded Mon Sep 17 00:00:00 2001
From: Jakub Majocha <1760221+majocha@users.noreply.github.com>
Date: Thu, 6 Nov 2025 11:51:55 +0100
Subject: [PATCH 09/10] omfg
---
src/Compiler/Utilities/TypeHashing.fs | 16 ++++++++--------
1 file changed, 8 insertions(+), 8 deletions(-)
diff --git a/src/Compiler/Utilities/TypeHashing.fs b/src/Compiler/Utilities/TypeHashing.fs
index 2d296aa3615..272ddb79dba 100644
--- a/src/Compiler/Utilities/TypeHashing.fs
+++ b/src/Compiler/Utilities/TypeHashing.fs
@@ -516,15 +516,15 @@ module StructuralUtilities =
elif not env.stable then Unstable tokens
else Stable tokens
- let tryGetTypeStructureOfStrippedType ty =
- // Speed up repeated calls by memoizing results for types that yield a stable structure.
- let memoize =
- WeakMap.cacheConditionally
- (function
- | Stable _ -> true
- | _ -> false)
- getTypeStructureOfStrippedType
+ // Speed up repeated calls by memoizing results for types that yield a stable structure.
+ let private memoize =
+ WeakMap.cacheConditionally
+ (function
+ | Stable _ -> true
+ | _ -> false)
+ getTypeStructureOfStrippedType
+ let tryGetTypeStructureOfStrippedType ty =
match memoize ty with
| PossiblyInfinite -> ValueNone
| ts -> ValueSome ts
From cb423e5bc6fe160b5dbadfebd4ba81c2d668d331 Mon Sep 17 00:00:00 2001
From: Jakub Majocha <1760221+majocha@users.noreply.github.com>
Date: Thu, 6 Nov 2025 14:29:04 +0100
Subject: [PATCH 10/10] do not weakly memoize when typars are involved, ignore
nullness
---
src/Compiler/Utilities/TypeHashing.fs | 33 +++++++++++++++------------
1 file changed, 19 insertions(+), 14 deletions(-)
diff --git a/src/Compiler/Utilities/TypeHashing.fs b/src/Compiler/Utilities/TypeHashing.fs
index 272ddb79dba..def5dbca0fa 100644
--- a/src/Compiler/Utilities/TypeHashing.fs
+++ b/src/Compiler/Utilities/TypeHashing.fs
@@ -397,6 +397,7 @@ module StructuralUtilities =
| Forall of int
| MeasureOne
| MeasureRational of int * int
+ | Solved of int
| Unsolved of int
| Rigid of int
@@ -408,15 +409,19 @@ module StructuralUtilities =
type private EmitContext =
{
typarMap: System.Collections.Generic.Dictionary
+ emitNullness: bool
mutable stable: bool
}
let private emitNullness env (n: Nullness) =
- match n.TryEvaluate() with
- | ValueSome k -> TypeToken.Nullness k
- | ValueNone ->
- env.stable <- false
- TypeToken.NullnessUnsolved
+ seq {
+ if env.emitNullness then
+ env.stable <- false //
+
+ match n.TryEvaluate() with
+ | ValueSome k -> TypeToken.Nullness k
+ | ValueNone -> TypeToken.NullnessUnsolved
+ }
let rec private emitMeasure (m: Measure) =
seq {
@@ -445,7 +450,7 @@ module StructuralUtilities =
| TType_app(tcref, tinst, n) ->
TypeToken.Stamp tcref.Stamp
- emitNullness env n
+ yield! emitNullness env n
for arg in tinst do
yield! emitTType env arg
@@ -473,10 +478,10 @@ module StructuralUtilities =
| TType_fun(d, r, n) ->
yield! emitTType env d
yield! emitTType env r
- emitNullness env n
+ yield! emitNullness env n
| TType_var(r, n) ->
- emitNullness env n
+ yield! emitNullness env n
let typarId =
match env.typarMap.TryGetValue r.Stamp with
@@ -486,14 +491,17 @@ module StructuralUtilities =
env.typarMap.[r.Stamp] <- idx
idx
+ // Solved may become unsolved, in case of Trace.Undo.
+ env.stable <- false
+
match r.Solution with
| Some ty -> yield! emitTType env ty
| None ->
if r.Rigidity = TyparRigidity.Rigid then
TypeToken.Rigid typarId
else
- env.stable <- false
TypeToken.Unsolved typarId
+
| TType_measure m -> yield! emitMeasure m
}
@@ -502,14 +510,11 @@ module StructuralUtilities =
let env =
{
typarMap = System.Collections.Generic.Dictionary()
+ emitNullness = false
stable = true
}
- let tokens =
- emitTType env ty
- |> Seq.filter (fun t -> t <> TypeToken.Nullness NullnessInfo.WithoutNull)
- |> Seq.truncate 256
- |> Seq.toArray
+ let tokens = emitTType env ty |> Seq.truncate 256 |> Seq.toArray
// If the sequence got too long, just drop it, we could be dealing with an infinite type.
if tokens.Length = 256 then PossiblyInfinite