diff --git a/src/Compiler/Symbols/Exprs.fs b/src/Compiler/Symbols/Exprs.fs index 33c87edb597..3a514db3df7 100644 --- a/src/Compiler/Symbols/Exprs.fs +++ b/src/Compiler/Symbols/Exprs.fs @@ -508,14 +508,47 @@ module FSharpExprConvert = and GetWitnessArgs cenv (env: ExprTranslationEnv) (vref: ValRef) m tps tyargs : FSharpExpr list = let g = cenv.g - if g.langVersion.SupportsFeature(Features.LanguageFeature.WitnessPassing) && not env.suppressWitnesses then - let witnessExprs = + if g.langVersion.SupportsFeature(Features.LanguageFeature.WitnessPassing) && not env.suppressWitnesses then + /// There are two *conditional* properties a typar can have: equality and comparison. + /// A generic type having that constraint may be conditional on whether a specific type parameter to that generic has that + /// constraint. + /// This function returns `true` iff after unification, the type definition contains any conditional typars. + /// + /// Note that these conditions are only marked on typars that actually appear in the code, *not* on phantom types. + /// So `hasConditionalTypar` should tell us exactly when the type parameter is actually being used in the type's equality or + /// comparison. + let rec hasConditionalTypar ty = + match stripTyEqns g ty with + | TType_var (tp, _) -> tp.ComparisonConditionalOn || tp.EqualityConditionalOn + | TType_app (_, tinst, _) -> tinst |> List.exists hasConditionalTypar + | _ -> false + + let witnessExprs = match ConstraintSolver.CodegenWitnessesForTyparInst cenv.tcValF g cenv.amap m tps tyargs with // There is a case where optimized code makes expressions that do a shift-left on the 'char' // type. There is no witness for this case. This is due to the code // let inline HashChar (x:char) = (# "or" (# "shl" x 16 : int #) x : int #) - // in FSharp.Core. + // in FSharp.Core. | ErrorResult _ when vref.LogicalName = "op_LeftShift" && List.isSingleton tyargs -> [] + // We don't need a witness either at compile time or runtime when there are conditional typars. + // Attempting to call a comparison operation with the type causes a compile-time check that all the generic type args + // support comparison (thanks to the ComparisonConditionalOn mechanism); the compile-time check doesn't need witnesses, + // it's just pure constraint solving. + // Nor do we need a witness for runtime logic: the compiler generates a `CompareTo` method (see + // `MakeValsForCompareAugmentation`) which handles the comparison by dynamically type-testing, not going through a witness. + // + // So we don't need to generate a witness. + // + // In fact, we *can't* generate a witness, because the constraint on the type parameter is only conditional: a rigid type + // parameter, defined without the `comparison` constraint, cannot have the constraint added to it later (that's what "rigid" + // means). It would change the type signature of the type to add this constraint to the type parameter! + // + // This code path is only reached through the auto-generated comparison/equality code, which only calls single-constraint + // intrinsics: there's exactly one constraint per type parameter in each of those two cases. + // In theory, if a function had an autogenerated `'a : comparison and 'b : SomethingElse`, where the `SomethingElse` was + // not comparison and failed for a different reason, we'd spuriously hide that failure here; but in fact the only code + // paths which get here have no other constraints. + | ErrorResult _ when List.exists hasConditionalTypar tyargs -> [] | res -> CommitOperationResult res let env = { env with suppressWitnesses = true } witnessExprs |> List.map (fun arg -> diff --git a/src/Compiler/TypedTree/TypedTreeBasics.fsi b/src/Compiler/TypedTree/TypedTreeBasics.fsi index 2b9372be3de..4f67c7aa377 100644 --- a/src/Compiler/TypedTree/TypedTreeBasics.fsi +++ b/src/Compiler/TypedTree/TypedTreeBasics.fsi @@ -141,6 +141,8 @@ val tryShortcutSolvedUnitPar: canShortcut: bool -> r: Typar -> Measure val stripUnitEqnsAux: canShortcut: bool -> unt: Measure -> Measure +/// Follows type variable solutions: when a type variable has been solved by unifying it with another type, +/// replaces that type variable with its solution. val stripTyparEqnsAux: nullness0: Nullness -> canShortcut: bool -> ty: TType -> TType val replaceNullnessOfTy: nullness: Nullness -> ty: TType -> TType diff --git a/src/Compiler/TypedTree/TypedTreeOps.fsi b/src/Compiler/TypedTree/TypedTreeOps.fsi index 72601a04aad..a68ffaf8af1 100755 --- a/src/Compiler/TypedTree/TypedTreeOps.fsi +++ b/src/Compiler/TypedTree/TypedTreeOps.fsi @@ -604,9 +604,41 @@ val reduceTyconRefMeasureableOrProvided: TcGlobals -> TyconRef -> TypeInst -> TT val reduceTyconRefAbbrevMeasureable: TyconRef -> Measure -/// set bool to 'true' to allow shortcutting of type parameter equation chains during stripping -val stripTyEqnsA: TcGlobals -> bool -> TType -> TType - +/// +/// Normalizes types. +/// +/// +/// Normalizes a type by: +/// +/// replacing type variables with their solutions found by unification +/// expanding type abbreviations +/// +/// as well as a couple of special-case normalizations: +/// +/// identifying int<1> with int (for any measurable type) +/// identifying byref<'T> with byref<'T, ByRefKinds.InOut> +/// +/// +/// +/// true to allow shortcutting of type parameter equation chains during stripping +/// +val stripTyEqnsA: TcGlobals -> canShortcut: bool -> TType -> TType + +/// +/// Normalizes types. +/// +/// +/// Normalizes a type by: +/// +/// replacing type variables with their solutions found by unification +/// expanding type abbreviations +/// +/// as well as a couple of special-case normalizations: +/// +/// identifying int<1> with int (for any measurable type) +/// identifying byref<'T> with byref<'T, ByRefKinds.InOut> +/// +/// val stripTyEqns: TcGlobals -> TType -> TType val stripTyEqnsAndMeasureEqns: TcGlobals -> TType -> TType @@ -707,6 +739,8 @@ val tcrefOfAppTy: TcGlobals -> TType -> TyconRef val tryTcrefOfAppTy: TcGlobals -> TType -> TyconRef voption +/// Returns ValueSome if this type is a type variable, even after abbreviations are expanded and +/// variables have been solved through unification. val tryDestTyparTy: TcGlobals -> TType -> Typar voption val tryDestFunTy: TcGlobals -> TType -> (TType * TType) voption diff --git a/tests/FSharp.Compiler.Service.Tests/ExprTests.fs b/tests/FSharp.Compiler.Service.Tests/ExprTests.fs index 2508675108f..874c680a89c 100644 --- a/tests/FSharp.Compiler.Service.Tests/ExprTests.fs +++ b/tests/FSharp.Compiler.Service.Tests/ExprTests.fs @@ -3504,3 +3504,193 @@ let ``Test ProjectForWitnesses4 GetWitnessPassingInfo`` () = printfn "actual:\n\n%A" actual actual |> shouldEqual expected + +//--------------------------------------------------------------------------------------------------------- +// Regression tests for ImmediateSubExpressions on generic types with conditional comparison/equality +// https://github.com/dotnet/fsharp/issues/19118 +// +// The bug: FCS crashes when accessing ImmediateSubExpressions on auto-generated comparison code +// for generic DUs/records whose type parameters have ComparisonConditionalOn but not actual +// comparison constraints. This is because GetWitnessArgs tries to generate witnesses for the +// comparison constraint, but fails because the type parameter is rigid and can't have constraints added. + +module internal ProjectForWitnessConditionalComparison = + + /// Helper to walk ALL expressions in a file, including ImmediateSubExpressions + /// This triggers the bug because it forces conversion of auto-generated comparison code + let walkAllExpressions (source : string) = + let fileName1 = System.IO.Path.ChangeExtension(getTemporaryFileName (), ".fs") + try + FileSystem.OpenFileForWriteShim(fileName1).Write(source) + let options = createProjectOptions [source] [] + let exprChecker = FSharpChecker.Create(keepAssemblyContents=true, useTransparentCompiler=CompilerAssertHelpers.UseTransparentCompiler) + let wholeProjectResults = exprChecker.ParseAndCheckProject(options) |> Async.RunImmediate + + if wholeProjectResults.Diagnostics.Length > 0 then + for diag in wholeProjectResults.Diagnostics do + printfn "Diagnostic: %s" diag.Message + + for implFile in wholeProjectResults.AssemblyContents.ImplementationFiles do + // Walk all declarations and their expressions, including ImmediateSubExpressions + let rec walkExpr (e: FSharpExpr) = + // Access ImmediateSubExpressions - this is what triggered #19118 + for subExpr in e.ImmediateSubExpressions do + walkExpr subExpr + + let rec walkDecl d = + match d with + | FSharpImplementationFileDeclaration.Entity (_, subDecls) -> + for subDecl in subDecls do + walkDecl subDecl + | FSharpImplementationFileDeclaration.MemberOrFunctionOrValue (_, _, e) -> + walkExpr e + | FSharpImplementationFileDeclaration.InitAction e -> + walkExpr e + + for decl in implFile.Declarations do + walkDecl decl + finally + try + FileSystem.FileDeleteShim fileName1 + with + | _ -> () + +[] +let ``ImmediateSubExpressions - generic DU with no constraints should not crash`` () = + // This is the core bug repro - a generic DU where the type parameter has + // ComparisonConditionalOn but no actual comparison constraint + let source = """ +module M + +type Bar<'appEvent> = + | Wibble of 'appEvent +""" + // This should not throw. Before the fix, it crashed with ConstraintSolverMissingConstraint. + ProjectForWitnessConditionalComparison.walkAllExpressions source + +[] +let ``ImmediateSubExpressions - generic DU with multiple type parameters should not crash`` () = + let source = """ +module M + +type MultiParam<'a, 'b, 'c> = + | Case1 of 'a + | Case2 of 'b * 'c + | Case3 of 'a * 'b * 'c +""" + ProjectForWitnessConditionalComparison.walkAllExpressions source + +[] +let ``ImmediateSubExpressions - generic record with no constraints should not crash`` () = + let source = """ +module M + +type MyRecord<'t> = { Value: 't; Name: string } +""" + ProjectForWitnessConditionalComparison.walkAllExpressions source + +[] +let ``ImmediateSubExpressions - generic struct DU should not crash`` () = + let source = """ +module M + +[] +type StructDU<'a> = + | StructCase of value: 'a +""" + ProjectForWitnessConditionalComparison.walkAllExpressions source + +[] +let ``ImmediateSubExpressions - nested generic types should not crash`` () = + let source = """ +module M + +type Outer<'a> = + | OuterCase of Inner<'a> + +and Inner<'b> = + | InnerCase of 'b +""" + ProjectForWitnessConditionalComparison.walkAllExpressions source + +[] +let ``ImmediateSubExpressions - generic DU with explicit comparison constraint works`` () = + // When the type parameter has the comparison constraint, witness generation should work; + // no crash occurred even before the bug was fixed. This test is here for completeness. + let source = """ +module M + +type WithConstraint<'a when 'a : comparison> = + | Constrained of 'a +""" + ProjectForWitnessConditionalComparison.walkAllExpressions source + +[] +let ``ImmediateSubExpressions - non-generic DU works`` () = + // Non-generic types always worked fine (no generics = no witness issues). This test is here for completeness. + let source = """ +module M + +type SimpleUnion = + | Case1 of int + | Case2 of string +""" + ProjectForWitnessConditionalComparison.walkAllExpressions source + +[] +let ``ImmediateSubExpressions - generic DU with NoComparison attribute should not crash`` () = + // With NoComparison, no comparison code is generated, so no crash ever occurred even before the bug was fixed. + // This test is here for completeness. + let source = """ +module M + +[] +type NoCompare<'a> = + | NoCompareCase of 'a +""" + ProjectForWitnessConditionalComparison.walkAllExpressions source + +[] +let ``ImmediateSubExpressions - generic DU with NoEquality attribute should not crash`` () = + let source = """ +module M + +[] +type NoEq<'a> = + | NoEqCase of 'a +""" + ProjectForWitnessConditionalComparison.walkAllExpressions source + +[] +let ``ImmediateSubExpressions - generic DU used in function should not crash`` () = + // Test that using the generic DU in actual code still works + let source = """ +module M + +type Option2<'t> = + | Some2 of 't + | None2 + +let mapOption2 f opt = + match opt with + | Some2 x -> Some2 (f x) + | None2 -> None2 +""" + ProjectForWitnessConditionalComparison.walkAllExpressions source + +[] +let ``ImmediateSubExpressions - complex generic type hierarchy should not crash`` () = + let source = """ +module M + +type Result<'ok, 'err> = + | Ok of 'ok + | Error of 'err + +type Validated<'a> = Result<'a, string list> + +let validate pred msg value : Validated<'a> = + if pred value then Ok value + else Error [msg] +""" + ProjectForWitnessConditionalComparison.walkAllExpressions source diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Quotations/FSharpQuotations.fs b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Quotations/FSharpQuotations.fs index a8ea2816a73..a61c8a97e2e 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Quotations/FSharpQuotations.fs +++ b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Quotations/FSharpQuotations.fs @@ -5,6 +5,8 @@ namespace FSharp.Core.UnitTests.Quotations open System +open FSharp.Core.UnitTests +open FSharp.Core.UnitTests.Collections open FSharp.Core.UnitTests.LibraryTestFx open Xunit open FSharp.Quotations @@ -139,4 +141,122 @@ type FSharpQuotationsTests() = let expr = Expr.NewTuple [ <@@ 1 @@>; <@@ "" @@> ] match expr with | NewStructTuple _ -> Assert.Fail() - | _ -> () \ No newline at end of file + | _ -> () + +/// This fixture is here to test handling of EqualityConditionalOn and ComparisonConditionalOn. +/// We don't generate witnesses for equality and comparison if they're conditional; the tests +/// assert that code gen doesn't fail in those cases. +[] +module TestConditionalConstraints = + open FSharp.Linq.RuntimeHelpers + + let eval q = LeafExpressionConverter.EvaluateQuotation q + + type DiscriminatedUnionWithGeneric<'a> = + | Case of 'a + + [] + type ThingWithNoComparison = + | NoComparison + + [] + type ThingWithNoEquality = + | NoEquality + + override this.ToString () = + "NoEquality" + + let inline compare< ^T when ^T : comparison> (x : ^T) (y : ^T) : bool = + x < y + + let inline equate< ^T when ^T : equality> (x : ^T) (y : ^T) : bool = + x = y + + [] + let ``SRTP quotations can consume conditionally constrained types `` () = + // Just normal calls, no quotation + Assert.False (equate (DiscriminatedUnionWithGeneric.Case 3) (DiscriminatedUnionWithGeneric.Case 4)) + Assert.True (equate (DiscriminatedUnionWithGeneric.Case 3) (DiscriminatedUnionWithGeneric.Case 3)) + Assert.True (compare (DiscriminatedUnionWithGeneric.Case 3) (DiscriminatedUnionWithGeneric.Case 4)) + + // Typed quotation, int + <@ equate (DiscriminatedUnionWithGeneric.Case 3) (DiscriminatedUnionWithGeneric.Case 4) @> + |> eval + |> unbox + |> Assert.False + + <@ equate (DiscriminatedUnionWithGeneric.Case 3) (DiscriminatedUnionWithGeneric.Case 3) @> + |> eval + |> unbox + |> Assert.True + + <@ compare (DiscriminatedUnionWithGeneric.Case 3) (DiscriminatedUnionWithGeneric.Case 4) @> + |> eval + |> unbox + |> Assert.True + + // Untyped quotation, int + <@@ equate (DiscriminatedUnionWithGeneric.Case 3) (DiscriminatedUnionWithGeneric.Case 4) @@> + |> eval + |> unbox + |> Assert.False + + <@@ equate (DiscriminatedUnionWithGeneric.Case 3) (DiscriminatedUnionWithGeneric.Case 3) @@> + |> eval + |> unbox + |> Assert.True + + <@@ compare (DiscriminatedUnionWithGeneric.Case 3) (DiscriminatedUnionWithGeneric.Case 4) @@> + |> eval + |> unbox + |> Assert.True + + // Typed and untyped quotation, ThingWithNoComparison + <@ equate ThingWithNoComparison.NoComparison ThingWithNoComparison.NoComparison @> + |> eval + |> unbox + |> Assert.True + + <@@ equate ThingWithNoComparison.NoComparison ThingWithNoComparison.NoComparison @@> + |> eval + |> unbox + |> Assert.True + + // Typed and untyped quotation, ThingWithNoEquality + <@ (fun x -> x.ToString ()) ThingWithNoEquality.NoEquality @> + |> eval + |> unbox + |> fun s -> Assert.AreEqual (s, "NoEquality") + + <@@ (fun x -> x.ToString ()) ThingWithNoEquality.NoEquality @@> + |> eval + |> unbox + |> fun s -> Assert.AreEqual (s, "NoEquality") + + // This test isn't quotation-related, but it *is* closely related to the quotation test: both are checking + // we can cope without witnesses. + [] + let ``Reflective invocations of conditionally constrained types throw with a reasonable error`` () = + let compare = typeof.DeclaringType.GetMethod "compare" + let compare = compare.MakeGenericMethod([| typeof |]) + let exc = + try + compare.Invoke (null, [|ThingWithNoComparison.NoComparison ; ThingWithNoComparison.NoComparison|]) + |> ignore + None + with + | exc -> + Some exc + + Assert.Contains ("does not implement the System.IComparable interface", exc.Value.InnerException.Message, StringComparison.Ordinal) + + // This test isn't quotation-related, but it *is* closely related to the quotation test: both are checking + // we can cope without witnesses. + [] + let ``We still use Object.ReferenceEquals for non-equatable methods when reflectively invoked`` () = + let equate = typeof.DeclaringType.GetMethod "equate" + let equate = equate.MakeGenericMethod([| typeof |]) + let anotherOne = Activator.CreateInstance (typeof, nonPublic=true) + equate.Invoke (null, [| ThingWithNoEquality.NoEquality ; anotherOne |]) + |> unbox + |> Assert.False