do not cache unsolved typars

Author: majocha

src/Compiler/Checking/TypeRelations.fs

@@ -29,8 +29,13 @@ type CanCoerce =
 type TTypeCacheKey =
     | TTypeCacheKey of TypeStructure * TypeStructure * CanCoerce
     static member TryGetFromStrippedTypes(ty1, ty2, canCoerce) =
+        match ty1, ty2 with
+        | TType_measure _, TType_measure _
+        | TType_var _, _ | _, TType_var _ ->
+            ValueNone
+        | _ ->
         let t1, t2 = getTypeStructure ty1, getTypeStructure ty2
-        if t1.IsPossiblyInfinite || t2.IsPossiblyInfinite then
+        if t1.IsUnsolved || t2.IsUnsolved then
             ValueNone
         else
             ValueSome (TTypeCacheKey(t1, t2, canCoerce))
@@ -137,10 +142,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 +161,15 @@ 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

@@ -399,16 +399,18 @@ module StructuralUtilities =
         | TupInfo of b: bool
         | MeasureOne
         | MeasureRational of int * int
-        | NeverEqual of never: NeverEqual
+        | Unsolved of never: NeverEqual
 
     type TypeStructure =
         | TypeStructure of TypeToken[]
-        | PossiblyInfinite of never: NeverEqual
+
+        member x.IsUnsolved =
+            let (TypeStructure tokens) = x in tokens |> Seq.exists _.IsUnsolved
 
     let inline toNullnessToken (n: Nullness) =
         match n.TryEvaluate() with
         | ValueSome k -> TypeToken.Nullness k
-        | _ -> TypeToken.NeverEqual NeverEqual.Singleton
+        | _ -> TypeToken.Unsolved NeverEqual.Singleton
 
     let rec private accumulateMeasure (m: Measure) =
         seq {
@@ -461,8 +463,11 @@ module StructuralUtilities =
                 yield! accumulateTType r
                 toNullnessToken n
             | TType_var(r, n) ->
-                TypeToken.Stamp r.Stamp
-                toNullnessToken n
+                if r.IsSolved then
+                    TypeToken.Stamp r.Stamp
+                    toNullnessToken n
+                else
+                    TypeToken.Unsolved NeverEqual.Singleton
             | TType_measure m -> yield! accumulateMeasure m
         }
 
@@ -471,7 +476,7 @@ module StructuralUtilities =
         let tokens = tokens |> Seq.truncate 256 |> Array.ofSeq
 
         if tokens.Length = 256 then
-            PossiblyInfinite NeverEqual.Singleton
+            TypeStructure [| TypeToken.Unsolved NeverEqual.Singleton |]
         else
             TypeStructure tokens
 

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