From 49bec1c6ab58218b87f38e9149d563492083e0f7 Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Tue, 9 Jul 2024 18:16:22 +0200 Subject: [PATCH] Nullness subsumption when used for contravariant typars --- src/Compiler/Checking/ConstraintSolver.fs | 36 +++++++++++++++++-- src/Compiler/Checking/import.fs | 2 ++ src/Compiler/TypedTree/TypedTree.fs | 24 +++++++++---- src/Compiler/TypedTree/TypedTree.fsi | 6 ++++ src/Compiler/TypedTree/TypedTreeBasics.fs | 2 +- src/Compiler/TypedTree/TypedTreePickle.fs | 2 +- .../Nullness/NullableReferenceTypesTests.fs | 25 +++++++++++++ 7 files changed, 85 insertions(+), 12 deletions(-) diff --git a/src/Compiler/Checking/ConstraintSolver.fs b/src/Compiler/Checking/ConstraintSolver.fs index dd2faa900aa..91c17302e98 100644 --- a/src/Compiler/Checking/ConstraintSolver.fs +++ b/src/Compiler/Checking/ConstraintSolver.fs @@ -1411,6 +1411,36 @@ and SolveTypeEqualsTypeEqns csenv ndeep m2 trace cxsln origl1 origl2 = ErrorD(ConstraintSolverTupleDiffLengths(csenv.DisplayEnv, csenv.eContextInfo, origl1, origl2, csenv.m, m2)) loop origl1 origl2 +and SolveTypeEqualsTypeWithContravarianceEqns (csenv:ConstraintSolverEnv) ndeep m2 trace cxsln origl1 origl2 typars = + let isContravariant (t:Typar) = + t.typar_opt_data + |> Option.map (fun d -> d.typar_is_contravariant) + |> Option.defaultValue(false) + + match origl1, origl2, typars with + | [], [], [] -> CompleteD + | _ -> + // We unwind Iterate2D by hand here for performance reasons. + let rec loop l1 l2 tps = + match l1, l2, tps with + | [], [], [] -> CompleteD + | h1 :: t1, h2 :: t2, hTp :: tTps when t1.Length = t2.Length && t1.Length = tTps.Length -> + trackErrors { + let h1 = + // For contravariant typars (` in C#'), if the required type is WithNull, the actual type can have any nullness it wants + // Without this added logic, their nullness would be forced to be equal. + if isContravariant hTp && (nullnessOfTy csenv.g h2).TryEvaluate() = ValueSome NullnessInfo.WithNull then + replaceNullnessOfTy csenv.g.knownWithNull h1 + else + h1 + + do! SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace cxsln h1 h2 + do! loop t1 t2 tTps + } + | _ -> + ErrorD(ConstraintSolverTupleDiffLengths(csenv.DisplayEnv, csenv.eContextInfo, origl1, origl2, csenv.m, m2)) + loop origl1 origl2 typars + and SolveFunTypeEqn csenv ndeep m2 trace cxsln domainTy1 domainTy2 rangeTy1 rangeTy2 = trackErrors { let g = csenv.g @@ -1503,11 +1533,11 @@ and SolveTypeSubsumesType (csenv: ConstraintSolverEnv) ndeep m2 (trace: Optional (tyconRefEq g tagc1 g.byrefkind_In_tcr || tyconRefEq g tagc1 g.byrefkind_Out_tcr) ) -> () | _ -> return! SolveTypeEqualsType csenv ndeep m2 trace cxsln tag1 tag2 } - | _ -> SolveTypeEqualsTypeEqns csenv ndeep m2 trace cxsln l1 l2 + | _ -> SolveTypeEqualsTypeWithContravarianceEqns csenv ndeep m2 trace cxsln l1 l2 tc1.TyparsNoRange | TType_app (tc1, l1, _) , TType_app (tc2, l2, _) when tyconRefEq g tc1 tc2 -> - trackErrors { - do! SolveTypeEqualsTypeEqns csenv ndeep m2 trace cxsln l1 l2 + trackErrors { + do! SolveTypeEqualsTypeWithContravarianceEqns csenv ndeep m2 trace cxsln l1 l2 tc1.TyparsNoRange do! SolveNullnessSubsumesNullness csenv m2 trace ty1 ty2 (nullnessOfTy g sty1) (nullnessOfTy g sty2) } diff --git a/src/Compiler/Checking/import.fs b/src/Compiler/Checking/import.fs index df3881824bc..4fbb7312584 100644 --- a/src/Compiler/Checking/import.fs +++ b/src/Compiler/Checking/import.fs @@ -624,6 +624,8 @@ let ImportILGenericParameters amap m scoref tinst (nullableFallback:Nullness.Nul let tptys = tps |> List.map mkTyparTy let importInst = tinst@tptys (tps, gps) ||> List.iter2 (fun tp gp -> + if gp.Variance = ILGenericVariance.ContraVariant then + tp.MarkAsContravariant() let constraints = [ if amap.g.langFeatureNullness && amap.g.checkNullness then diff --git a/src/Compiler/TypedTree/TypedTree.fs b/src/Compiler/TypedTree/TypedTree.fs index 4f313e1db39..6f897c7889a 100644 --- a/src/Compiler/TypedTree/TypedTree.fs +++ b/src/Compiler/TypedTree/TypedTree.fs @@ -2254,6 +2254,9 @@ type TyparOptionalData = /// The declared attributes of the type parameter. Empty for type inference variables. mutable typar_attribs: Attribs + + /// Set to true if the typar is contravariant, i.e. declared as in C# + mutable typar_is_contravariant: bool } [] @@ -2355,10 +2358,10 @@ type Typar = member x.SetAttribs attribs = match attribs, x.typar_opt_data with | [], None -> () - | [], Some { typar_il_name = None; typar_xmldoc = doc; typar_constraints = [] } when doc.IsEmpty -> + | [], Some { typar_il_name = None; typar_xmldoc = doc; typar_constraints = []; typar_is_contravariant = false } when doc.IsEmpty -> x.typar_opt_data <- None | _, Some optData -> optData.typar_attribs <- attribs - | _ -> x.typar_opt_data <- Some { typar_il_name = None; typar_xmldoc = XmlDoc.Empty; typar_constraints = []; typar_attribs = attribs } + | _ -> x.typar_opt_data <- Some { typar_il_name = None; typar_xmldoc = XmlDoc.Empty; typar_constraints = []; typar_attribs = attribs; typar_is_contravariant = false } /// Get the XML documetnation for the type parameter member x.XmlDoc = @@ -2376,7 +2379,7 @@ type Typar = member x.SetILName il_name = match x.typar_opt_data with | Some optData -> optData.typar_il_name <- il_name - | _ -> x.typar_opt_data <- Some { typar_il_name = il_name; typar_xmldoc = XmlDoc.Empty; typar_constraints = []; typar_attribs = [] } + | _ -> x.typar_opt_data <- Some { typar_il_name = il_name; typar_xmldoc = XmlDoc.Empty; typar_constraints = []; typar_attribs = []; typar_is_contravariant = false } /// Indicates the display name of a type variable member x.DisplayName = if x.Name = "?" then "?"+string x.Stamp else x.Name @@ -2385,10 +2388,17 @@ type Typar = member x.SetConstraints cs = match cs, x.typar_opt_data with | [], None -> () - | [], Some { typar_il_name = None; typar_xmldoc = doc; typar_attribs = [] } when doc.IsEmpty -> + | [], Some { typar_il_name = None; typar_xmldoc = doc; typar_attribs = [];typar_is_contravariant = false } when doc.IsEmpty -> x.typar_opt_data <- None | _, Some optData -> optData.typar_constraints <- cs - | _ -> x.typar_opt_data <- Some { typar_il_name = None; typar_xmldoc = XmlDoc.Empty; typar_constraints = cs; typar_attribs = [] } + | _ -> x.typar_opt_data <- Some { typar_il_name = None; typar_xmldoc = XmlDoc.Empty; typar_constraints = cs; typar_attribs = []; typar_is_contravariant = false } + + /// Marks the typar as being contravariant + member x.MarkAsContravariant() = + match x.typar_opt_data with + | Some optData -> optData.typar_is_contravariant <- true + | _ -> + x.typar_opt_data <- Some { typar_il_name = None; typar_xmldoc = XmlDoc.Empty; typar_constraints = []; typar_attribs = []; typar_is_contravariant = true } /// Creates a type variable that contains empty data, and is not yet linked. Only used during unpickling of F# metadata. static member NewUnlinked() : Typar = @@ -2410,7 +2420,7 @@ type Typar = x.typar_solution <- tg.typar_solution match tg.typar_opt_data with | Some tg -> - let optData = { typar_il_name = tg.typar_il_name; typar_xmldoc = tg.typar_xmldoc; typar_constraints = tg.typar_constraints; typar_attribs = tg.typar_attribs } + let optData = { typar_il_name = tg.typar_il_name; typar_xmldoc = tg.typar_xmldoc; typar_constraints = tg.typar_constraints; typar_attribs = tg.typar_attribs; typar_is_contravariant = tg.typar_is_contravariant } x.typar_opt_data <- Some optData | None -> () @@ -6142,7 +6152,7 @@ type Construct() = typar_opt_data = match attribs with | [] -> None - | _ -> Some { typar_il_name = None; typar_xmldoc = XmlDoc.Empty; typar_constraints = []; typar_attribs = attribs } } + | _ -> Some { typar_il_name = None; typar_xmldoc = XmlDoc.Empty; typar_constraints = []; typar_attribs = attribs; typar_is_contravariant = false } } /// Create a new type parameter node for a declared type parameter static member NewRigidTypar nm m = diff --git a/src/Compiler/TypedTree/TypedTree.fsi b/src/Compiler/TypedTree/TypedTree.fsi index 9c688826ae0..2abe8ed08f7 100644 --- a/src/Compiler/TypedTree/TypedTree.fsi +++ b/src/Compiler/TypedTree/TypedTree.fsi @@ -1485,6 +1485,9 @@ type TyparOptionalData = /// The declared attributes of the type parameter. Empty for type inference variables. mutable typar_attribs: Attribs + + /// Set to true if the typar is contravariant, i.e. declared as in C# + mutable typar_is_contravariant: bool } override ToString: unit -> string @@ -1541,6 +1544,9 @@ type Typar = /// Adjusts the constraints associated with a type variable member SetConstraints: cs: TyparConstraint list -> unit + /// Marks the typar as being contravariant + member MarkAsContravariant: unit -> unit + /// Sets whether a type variable is required at runtime member SetDynamicReq: b: TyparDynamicReq -> unit diff --git a/src/Compiler/TypedTree/TypedTreeBasics.fs b/src/Compiler/TypedTree/TypedTreeBasics.fs index 303d18fdec5..c8268ffcf8a 100644 --- a/src/Compiler/TypedTree/TypedTreeBasics.fs +++ b/src/Compiler/TypedTree/TypedTreeBasics.fs @@ -198,7 +198,7 @@ let mkTyparTy (tp:Typar) = // For fresh type variables clear the StaticReq when copying because the requirement will be re-established through the // process of type inference. let copyTypar clearStaticReq (tp: Typar) = - let optData = tp.typar_opt_data |> Option.map (fun tg -> { typar_il_name = tg.typar_il_name; typar_xmldoc = tg.typar_xmldoc; typar_constraints = tg.typar_constraints; typar_attribs = tg.typar_attribs }) + let optData = tp.typar_opt_data |> Option.map (fun tg -> { typar_il_name = tg.typar_il_name; typar_xmldoc = tg.typar_xmldoc; typar_constraints = tg.typar_constraints; typar_attribs = tg.typar_attribs; typar_is_contravariant = tg.typar_is_contravariant }) let flags = if clearStaticReq then tp.typar_flags.WithStaticReq(TyparStaticReq.None) else tp.typar_flags Typar.New { typar_id = tp.typar_id typar_flags = flags diff --git a/src/Compiler/TypedTree/TypedTreePickle.fs b/src/Compiler/TypedTree/TypedTreePickle.fs index 1b74e671a9f..6093f9cd391 100644 --- a/src/Compiler/TypedTree/TypedTreePickle.fs +++ b/src/Compiler/TypedTree/TypedTreePickle.fs @@ -1683,7 +1683,7 @@ let u_tyar_spec_data st = typar_opt_data= match g, e, c with | doc, [], [] when doc.IsEmpty -> None - | _ -> Some { typar_il_name = None; typar_xmldoc = g; typar_constraints = e; typar_attribs = c } } + | _ -> Some { typar_il_name = None; typar_xmldoc = g; typar_constraints = e; typar_attribs = c;typar_is_contravariant = false } } let u_tyar_spec st = u_osgn_decl st.itypars u_tyar_spec_data st diff --git a/tests/FSharp.Compiler.ComponentTests/Language/Nullness/NullableReferenceTypesTests.fs b/tests/FSharp.Compiler.ComponentTests/Language/Nullness/NullableReferenceTypesTests.fs index 9ee080928a7..7c57afabd98 100644 --- a/tests/FSharp.Compiler.ComponentTests/Language/Nullness/NullableReferenceTypesTests.fs +++ b/tests/FSharp.Compiler.ComponentTests/Language/Nullness/NullableReferenceTypesTests.fs @@ -849,6 +849,31 @@ let mappableFunc = |> typeCheckWithStrictNullness |> shouldSucceed +[] +let ``Importing and processing contravariant interfaces`` () = + + FSharp """module MyLibrary + +open System +open System.Collections.Concurrent +open System.Collections.Generic + + +let cmp1 : IEqualityComparer = StringComparer.Ordinal +let cmp2 : IEqualityComparer = StringComparer.Ordinal +let stringHash = cmp2.GetHashCode("abc") +let nullHash = cmp2.GetHashCode(null) +let nullEquals = cmp2.Equals("abc", null) + +let dict = ConcurrentDictionary (StringComparer.Ordinal) +dict["ok"] <- 42 + +""" + |> asLibrary + |> typeCheckWithStrictNullness + |> shouldSucceed + + [] let ``Notnull constraint and inline annotated value`` () = FSharp """module MyLibrary