Type subsumption cache: handle unsolved type vars

docs/release-notes/.FSharp.Compiler.Service/11.0.0.md

@@ -8,6 +8,7 @@
 * 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))
 * Fix units-of-measure changes not invalidating incremental builds. ([Issue #19049](https://github.com/dotnet/fsharp/issues/19049))
+* 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/Checking/TypeRelations.fs

@@ -29,11 +29,14 @@ 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 +140,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 +159,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

src/Compiler/Utilities/TypeHashing.fs

@@ -1,15 +1,13 @@
 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
 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
@@ -380,110 +377,154 @@ 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.
 ///   * Perfect canonicalisation or alpha-equivalence collapsing.
 ///
 /// </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()
+    open Internal.Utilities.Library.Extras
 
     [<Struct; NoComparison; RequireQualifiedAccess>]
     type TypeToken =
         | 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
-        | NeverEqual of never: NeverEqual
+        | Unsolved of int
+        | Rigid of int
 
     type TypeStructure =
-        | TypeStructure of TypeToken[]
-        | PossiblyInfinite of never: NeverEqual
+        | Stable of TypeToken[]
+        | Unstable of TypeToken[]
+        | PossiblyInfinite
+
+    type private EmitContext =
+        {
+            typarMap: System.Collections.Generic.Dictionary<Stamp, int>
+            mutable stable: bool
+        }
 
-    let inline toNullnessToken (n: Nullness) =
+    let private emitNullness env (n: Nullness) =
         match n.TryEvaluate() with
         | ValueSome k -> TypeToken.Nullness k
-        | _ -> TypeToken.NeverEqual NeverEqual.Singleton
+        | ValueNone ->
+            env.stable <- false
+            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 accumulateTType (ty: TType) =
+    and private emitTType (env: EmitContext) (ty: TType) =
         seq {
             match ty with
             | TType_ucase(u, tinst) ->
                 TypeToken.Stamp u.TyconRef.Stamp
                 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 env 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
-                    TypeToken.Stamp tp.Stamp
+                    env.typarMap.[tp.Stamp] <- env.typarMap.Count
+
+                TypeToken.Forall tps.Length
+
+                yield! emitTType env tau
 
-                yield! accumulateTType tau
             | TType_fun(d, r, n) ->
-                yield! accumulateTType d
-                yield! accumulateTType r
-                toNullnessToken n
+                yield! emitTType env d
+                yield! emitTType env r
+                emitNullness env n
+
             | TType_var(r, n) ->
-                TypeToken.Stamp r.Stamp
-                toNullnessToken n
-            | TType_measure m -> yield! accumulateMeasure m
+                emitNullness env 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
+                        env.stable <- false
+                        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 =
-        let tokens = tokens |> Seq.truncate 256 |> Array.ofSeq
-
-        if tokens.Length = 256 then
-            PossiblyInfinite NeverEqual.Singleton
-        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 private getTypeStructureOfStrippedType (ty: TType) =
+
+        let env =
+            {
+                typarMap = System.Collections.Generic.Dictionary<Stamp, int>()
+                stable = true
+            }
+
+        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 not env.stable then Unstable tokens
+        else Stable tokens
+
+    // 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

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