Type subsumption cache: handle unsolved type vars

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
 

src/Compiler/Utilities/TypeHashing.fs

@@ -379,17 +379,6 @@ module HashTastMemberOrVals =
 ///
 /// </summary>
 module StructuralUtilities =
-    [<Struct; CustomEquality; NoComparison>]
-    type NeverEqual =
-        struct
-            interface System.IEquatable<NeverEqual> with
-                member _.Equals _ = false
-
-            override _.Equals _ = false
-            override _.GetHashCode() = 0
-        end
-
-        static member Singleton = NeverEqual()
 
     [<Struct; NoComparison; RequireQualifiedAccess>]
     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 Array.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)

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

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

tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj

@@ -277,6 +277,7 @@
     <Compile Include="Interop\Literals.fs" />
     <Compile Include="Scripting\Interactive.fs" />
     <Compile Include="Scripting\TypeCheckOnlyTests.fs" />
+    <Compile Include="TypeChecks\TypeRelations.fs" />
     <Compile Include="TypeChecks\SeqTypeCheckTests.fs" />
     <Compile Include="TypeChecks\CheckDeclarationsTests.fs" />
     <Compile Include="TypeChecks\Graph\Utils.fs" />

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
+
+[<AbstractClass>]
+type FooBase() =
+
+    interface IFoo<FooBase> with
+        member this.Bar (other: FooBase) = ()
+
+[<Sealed>]
+type FooDerived<'T>() =
+    inherit FooBase()
+
+    interface IFoo<FooDerived<'T>> 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

tests/FSharp.Compiler.ComponentTests/TypeChecks/TypeRelations.fs

@@ -0,0 +1,12 @@
+module TypeChecks.TypeRelations
+
+open Xunit
+open FSharp.Test.Compiler
+open FSharp.Test
+
+[<Theory; FileInlineData("CrgpLibrary.fs")>]
+let ``Unsolved type variables are not cached`` compilation =
+    compilation
+    |> getCompilation
+    |> typecheck
+    |> shouldSucceed