diff --git a/src/Compiler/AbstractIL/il.fs b/src/Compiler/AbstractIL/il.fs index 363004b2ff6..cbc94d666f5 100644 --- a/src/Compiler/AbstractIL/il.fs +++ b/src/Compiler/AbstractIL/il.fs @@ -20,6 +20,7 @@ open System.Text open System.Threading open FSharp.Compiler.AbstractIL.Diagnostics +open FSharp.Compiler.Features open Internal.Utilities.Library open Internal.Utilities @@ -3356,7 +3357,13 @@ let tname_UIntPtr = "System.UIntPtr" let tname_TypedReference = "System.TypedReference" [] -type ILGlobals(primaryScopeRef: ILScopeRef, equivPrimaryAssemblyRefs: ILAssemblyRef list, fsharpCoreAssemblyScopeRef: ILScopeRef) = +type ILGlobals + ( + primaryScopeRef: ILScopeRef, + equivPrimaryAssemblyRefs: ILAssemblyRef list, + fsharpCoreAssemblyScopeRef: ILScopeRef, + langVersion: LanguageVersion + ) = let equivPrimaryAssemblyRefs = Array.ofList equivPrimaryAssemblyRefs @@ -3421,14 +3428,16 @@ type ILGlobals(primaryScopeRef: ILScopeRef, equivPrimaryAssemblyRefs: ILAssembly aref.EqualsIgnoringVersion x.primaryAssemblyRef || equivPrimaryAssemblyRefs |> Array.exists aref.EqualsIgnoringVersion + member _.langVersion = langVersion + /// For debugging [] member x.DebugText = x.ToString() override x.ToString() = "" -let mkILGlobals (primaryScopeRef, equivPrimaryAssemblyRefs, fsharpCoreAssemblyScopeRef) = - ILGlobals(primaryScopeRef, equivPrimaryAssemblyRefs, fsharpCoreAssemblyScopeRef) +let mkILGlobals (primaryScopeRef, equivPrimaryAssemblyRefs, fsharpCoreAssemblyScopeRef, langVersion) = + ILGlobals(primaryScopeRef, equivPrimaryAssemblyRefs, fsharpCoreAssemblyScopeRef, langVersion) let mkNormalCall mspec = I_call(Normalcall, mspec, None) @@ -4686,7 +4695,7 @@ let DummyFSharpCoreScopeRef = ILScopeRef.Assembly asmRef let PrimaryAssemblyILGlobals = - mkILGlobals (ILScopeRef.PrimaryAssembly, [], DummyFSharpCoreScopeRef) + mkILGlobals (ILScopeRef.PrimaryAssembly, [], DummyFSharpCoreScopeRef, LanguageVersion("default")) let rec decodeCustomAttrElemType bytes sigptr x = match x with diff --git a/src/Compiler/AbstractIL/il.fsi b/src/Compiler/AbstractIL/il.fsi index 13ba8e13d80..ece3099f541 100644 --- a/src/Compiler/AbstractIL/il.fsi +++ b/src/Compiler/AbstractIL/il.fsi @@ -4,6 +4,7 @@ module rec FSharp.Compiler.AbstractIL.IL +open FSharp.Compiler.Features open FSharp.Compiler.IO open System.Collections.Generic open System.Reflection @@ -1816,6 +1817,7 @@ type internal ILGlobals = member primaryAssemblyRef: ILAssemblyRef member primaryAssemblyName: string member fsharpCoreAssemblyScopeRef: ILScopeRef + member langVersion: LanguageVersion member typ_Attribute: ILType member typ_Enum: ILType @@ -1855,7 +1857,10 @@ type internal ILGlobals = /// primaryScopeRef is the primary assembly we are emitting /// equivPrimaryAssemblyRefs are ones regarded as equivalent val internal mkILGlobals: - primaryScopeRef: ILScopeRef * equivPrimaryAssemblyRefs: ILAssemblyRef list * fsharpCoreAssemblyScopeRef: ILScopeRef -> + primaryScopeRef: ILScopeRef * + equivPrimaryAssemblyRefs: ILAssemblyRef list * + fsharpCoreAssemblyScopeRef: ILScopeRef * + langVersion: LanguageVersion -> ILGlobals val internal PrimaryAssemblyILGlobals: ILGlobals @@ -1929,6 +1934,7 @@ val internal mkILNonGenericStaticMethSpecInTy: ILType * string * ILType list * I /// Construct references to constructors. val internal mkILCtorMethSpecForTy: ILType * ILType list -> ILMethodSpec +val internal mkILNonGenericCtorMethSpec: ILTypeRef * ILType list -> ILMethodSpec /// Construct references to fields. val internal mkILFieldRef: ILTypeRef * string * ILType -> ILFieldRef diff --git a/src/Compiler/Checking/AugmentTypeDefinitions.fs b/src/Compiler/Checking/AugmentTypeDefinitions.fs new file mode 100644 index 00000000000..0a21aa7ffbb --- /dev/null +++ b/src/Compiler/Checking/AugmentTypeDefinitions.fs @@ -0,0 +1,1617 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +/// Generate the hash/compare functions we add to user-defined types by default. +module internal FSharp.Compiler.AugmentTypeDefinitions + +open Internal.Utilities.Library +open FSharp.Compiler.AbstractIL.IL +open FSharp.Compiler.DiagnosticsLogger +open FSharp.Compiler.Syntax +open FSharp.Compiler.Xml +open FSharp.Compiler.TcGlobals +open FSharp.Compiler.TypedTree +open FSharp.Compiler.TypedTreeBasics +open FSharp.Compiler.TypedTreeOps +open FSharp.Compiler.TypeHierarchy + +let mkIComparableCompareToSlotSig (g: TcGlobals) = + TSlotSig("CompareTo", g.mk_IComparable_ty, [], [], [ [ TSlotParam(Some("obj"), g.obj_ty, false, false, false, []) ] ], Some g.int_ty) + +let mkGenericIComparableCompareToSlotSig (g: TcGlobals) ty = + TSlotSig( + "CompareTo", + (mkAppTy g.system_GenericIComparable_tcref [ ty ]), + [], + [], + [ [ TSlotParam(Some("obj"), ty, false, false, false, []) ] ], + Some g.int_ty + ) + +let mkIStructuralComparableCompareToSlotSig (g: TcGlobals) = + TSlotSig( + "CompareTo", + g.mk_IStructuralComparable_ty, + [], + [], + [ + [ + TSlotParam(None, (mkRefTupledTy g [ g.obj_ty; g.IComparer_ty ]), false, false, false, []) + ] + ], + Some g.int_ty + ) + +let mkGenericIEquatableEqualsSlotSig (g: TcGlobals) ty = + TSlotSig( + "Equals", + (mkAppTy g.system_GenericIEquatable_tcref [ ty ]), + [], + [], + [ [ TSlotParam(Some("obj"), ty, false, false, false, []) ] ], + Some g.bool_ty + ) + +let mkIStructuralEquatableEqualsSlotSig (g: TcGlobals) = + TSlotSig( + "Equals", + g.mk_IStructuralEquatable_ty, + [], + [], + [ + [ + TSlotParam(None, (mkRefTupledTy g [ g.obj_ty; g.IEqualityComparer_ty ]), false, false, false, []) + ] + ], + Some g.bool_ty + ) + +let mkIStructuralEquatableGetHashCodeSlotSig (g: TcGlobals) = + TSlotSig( + "GetHashCode", + g.mk_IStructuralEquatable_ty, + [], + [], + [ [ TSlotParam(None, g.IEqualityComparer_ty, false, false, false, []) ] ], + Some g.int_ty + ) + +let mkGetHashCodeSlotSig (g: TcGlobals) = + TSlotSig("GetHashCode", g.obj_ty, [], [], [ [] ], Some g.int_ty) + +let mkEqualsSlotSig (g: TcGlobals) = + TSlotSig("Equals", g.obj_ty, [], [], [ [ TSlotParam(Some("obj"), g.obj_ty, false, false, false, []) ] ], Some g.bool_ty) + +//------------------------------------------------------------------------- +// Helpers associated with code-generation of comparison/hash augmentations +//------------------------------------------------------------------------- + +let mkThisTy g ty = + if isStructTy g ty then mkByrefTy g ty else ty + +let mkCompareObjTy g ty = + mkFunTy g (mkThisTy g ty) (mkFunTy g g.obj_ty g.int_ty) + +let mkCompareTy g ty = + mkFunTy g (mkThisTy g ty) (mkFunTy g ty g.int_ty) + +let mkCompareWithComparerTy g ty = + mkFunTy g (mkThisTy g ty) (mkFunTy g (mkRefTupledTy g [ g.obj_ty; g.IComparer_ty ]) g.int_ty) + +let mkEqualsObjTy g ty = + mkFunTy g (mkThisTy g ty) (mkFunTy g g.obj_ty g.bool_ty) + +let mkEqualsTy g ty = + mkFunTy g (mkThisTy g ty) (mkFunTy g ty g.bool_ty) + +let mkEqualsWithComparerTy g ty = + mkFunTy g (mkThisTy g ty) (mkFunTy g (mkRefTupledTy g [ g.obj_ty; g.IEqualityComparer_ty ]) g.bool_ty) + +let mkHashTy g ty = + mkFunTy g (mkThisTy g ty) (mkFunTy g g.unit_ty g.int_ty) + +let mkHashWithComparerTy g ty = + mkFunTy g (mkThisTy g ty) (mkFunTy g g.IEqualityComparer_ty g.int_ty) + +let mkIsCaseTy g ty = + mkFunTy g (mkThisTy g ty) (mkFunTy g g.unit_ty g.bool_ty) + +//------------------------------------------------------------------------- +// Polymorphic comparison +//------------------------------------------------------------------------- + +let mkRelBinOp (g: TcGlobals) op m e1 e2 = + mkAsmExpr ([ op ], [], [ e1; e2 ], [ g.bool_ty ], m) + +let mkClt g m e1 e2 = mkRelBinOp g AI_clt m e1 e2 + +let mkCgt g m e1 e2 = mkRelBinOp g AI_cgt m e1 e2 + +//------------------------------------------------------------------------- +// REVIEW: make this a .constrained call, not a virtual call. +//------------------------------------------------------------------------- + +// for creating and using GenericComparer objects and for creating and using +// IStructuralComparable objects (Eg, Calling CompareTo(obj o, IComparer comp)) + +let mkILLangPrimTy (g: TcGlobals) = + mkILNonGenericBoxedTy g.tcref_LanguagePrimitives.CompiledRepresentationForNamedType + +let mkILCallGetComparer (g: TcGlobals) m = + let ty = + mkILNonGenericBoxedTy g.tcref_System_Collections_IComparer.CompiledRepresentationForNamedType + + let mspec = + mkILNonGenericStaticMethSpecInTy (mkILLangPrimTy g, "get_GenericComparer", [], ty) + + mkAsmExpr ([ mkNormalCall mspec ], [], [], [ g.IComparer_ty ], m) + +let mkILCallGetEqualityComparer (g: TcGlobals) m = + let ty = + mkILNonGenericBoxedTy g.tcref_System_Collections_IEqualityComparer.CompiledRepresentationForNamedType + + let mspec = + mkILNonGenericStaticMethSpecInTy (mkILLangPrimTy g, "get_GenericEqualityComparer", [], ty) + + mkAsmExpr ([ mkNormalCall mspec ], [], [], [ g.IEqualityComparer_ty ], m) + +let mkThisVar g m ty = mkCompGenLocal m "this" (mkThisTy g ty) + +let mkShl g m acce n = + mkAsmExpr ([ AI_shl ], [], [ acce; mkInt g m n ], [ g.int_ty ], m) + +let mkShr g m acce n = + mkAsmExpr ([ AI_shr ], [], [ acce; mkInt g m n ], [ g.int_ty ], m) + +let mkAdd (g: TcGlobals) m e1 e2 = + mkAsmExpr ([ AI_add ], [], [ e1; e2 ], [ g.int_ty ], m) + +let mkAddToHashAcc g m e accv acce = + mkValSet m accv (mkAdd g m (mkInt g m 0x9e3779b9) (mkAdd g m e (mkAdd g m (mkShl g m acce 6) (mkShr g m acce 2)))) + +let mkCombineHashGenerators g m exprs accv acce = + (acce, exprs) + ||> List.fold (fun tm e -> mkCompGenSequential m (mkAddToHashAcc g m e accv acce) tm) + +//------------------------------------------------------------------------- +// Build comparison functions for union, record and exception types. +//------------------------------------------------------------------------- + +let mkThatAddrLocal g m ty = mkCompGenLocal m "obj" (mkThisTy g ty) + +let mkThatAddrLocalIfNeeded g m tcve ty = + if isStructTy g ty then + let thataddrv, thataddre = mkCompGenLocal m "obj" (mkThisTy g ty) + Some thataddrv, thataddre + else + None, tcve + +let mkThisVarThatVar g m ty = + let thisv, thise = mkThisVar g m ty + let thataddrv, thataddre = mkThatAddrLocal g m ty + thisv, thataddrv, thise, thataddre + +let mkThatVarBind g m ty thataddrv expr = + if isStructTy g ty then + let thatv2, _ = mkMutableCompGenLocal m "obj" ty + thatv2, mkCompGenLet m thataddrv (mkValAddr m false (mkLocalValRef thatv2)) expr + else + thataddrv, expr + +let mkBindThatAddr g m ty thataddrv thatv thate expr = + if isStructTy g ty then + // let thataddrv = &thatv + mkCompGenLet m thataddrv (mkValAddr m false (mkLocalValRef thatv)) expr + else + // let thataddrv = that + mkCompGenLet m thataddrv thate expr + +let mkBindThatAddrIfNeeded m thataddrvOpt thatv expr = + match thataddrvOpt with + | None -> expr + | Some thataddrv -> + // let thataddrv = &thatv + mkCompGenLet m thataddrv (mkValAddr m false (mkLocalValRef thatv)) expr + +let mkCompareTestConjuncts g m exprs = + match List.tryFrontAndBack exprs with + | None -> mkZero g m + | Some (a, b) -> + (a, b) + ||> List.foldBack (fun e acc -> + let nv, ne = mkCompGenLocal m "n" g.int_ty + + mkCompGenLet + m + nv + e + (mkCond + DebugPointAtBinding.NoneAtSticky + m + g.int_ty + (mkClt g m ne (mkZero g m)) + ne + (mkCond DebugPointAtBinding.NoneAtSticky m g.int_ty (mkCgt g m ne (mkZero g m)) ne acc))) + +let mkEqualsTestConjuncts g m exprs = + match List.tryFrontAndBack exprs with + | None -> mkOne g m + | Some (a, b) -> List.foldBack (fun e acc -> mkCond DebugPointAtBinding.NoneAtSticky m g.bool_ty e acc (mkFalse g m)) a b + +let mkMinimalTy (g: TcGlobals) (tcref: TyconRef) = + if tcref.Deref.IsFSharpException then + [], g.exn_ty + else + generalizeTyconRef g tcref + +// check for nulls +let mkBindNullComparison g m thise thate expr = + let expr = mkNonNullCond g m g.int_ty thate expr (mkOne g m) + + let expr = + mkNonNullCond g m g.int_ty thise expr (mkNonNullCond g m g.int_ty thate (mkMinusOne g m) (mkZero g m)) + + expr + +let mkBindThisNullEquals g m thise thate expr = + let expr = + mkNonNullCond g m g.bool_ty thise expr (mkNonNullCond g m g.int_ty thate (mkFalse g m) (mkTrue g m)) + + expr + +let mkBindThatNullEquals g m thise thate expr = + let expr = mkNonNullCond g m g.bool_ty thate expr (mkFalse g m) + let expr = mkBindThisNullEquals g m thise thate expr + expr + +let mkBindNullHash g m thise expr = + let expr = mkNonNullCond g m g.int_ty thise expr (mkZero g m) + expr + +/// Build the comparison implementation for a record type +let mkRecdCompare g tcref (tycon: Tycon) = + let m = tycon.Range + let fields = tycon.AllInstanceFieldsAsList + let tinst, ty = mkMinimalTy g tcref + let thisv, thataddrv, thise, thataddre = mkThisVarThatVar g m ty + let compe = mkILCallGetComparer g m + + let mkTest (fspec: RecdField) = + let fref = tcref.MakeNestedRecdFieldRef fspec + let m = fref.Range + + mkCallGenericComparisonWithComparerOuter + g + m + fspec.FormalType + compe + (mkRecdFieldGetViaExprAddr (thise, fref, tinst, m)) + (mkRecdFieldGetViaExprAddr (thataddre, fref, tinst, m)) + + let expr = mkCompareTestConjuncts g m (List.map mkTest fields) + + let expr = + if tycon.IsStructOrEnumTycon then + expr + else + mkBindNullComparison g m thise thataddre expr + + let thatv, expr = mkThatVarBind g m ty thataddrv expr + thisv, thatv, expr + +/// Build the comparison implementation for a record type when parameterized by a comparer +let mkRecdCompareWithComparer g tcref (tycon: Tycon) (_thisv, thise) (_, thate) compe = + let m = tycon.Range + let fields = tycon.AllInstanceFieldsAsList + let tinst, ty = mkMinimalTy g tcref + let tcv, tce = mkCompGenLocal m "objTemp" ty // let tcv = thate + let thataddrv, thataddre = mkThatAddrLocal g m ty // let thataddrv = &tcv, if a struct + + let mkTest (fspec: RecdField) = + let fref = tcref.MakeNestedRecdFieldRef fspec + let m = fref.Range + + mkCallGenericComparisonWithComparerOuter + g + m + fspec.FormalType + compe + (mkRecdFieldGetViaExprAddr (thise, fref, tinst, m)) + (mkRecdFieldGetViaExprAddr (thataddre, fref, tinst, m)) + + let expr = mkCompareTestConjuncts g m (List.map mkTest fields) + + let expr = + if tycon.IsStructOrEnumTycon then + expr + else + mkBindNullComparison g m thise thate expr + + let expr = mkBindThatAddr g m ty thataddrv tcv tce expr + // will be optimized away if not necessary + let expr = mkCompGenLet m tcv thate expr + expr + +/// Build the .Equals(that) equality implementation wrapper for a record type +let mkRecdEquality g tcref (tycon: Tycon) = + let m = tycon.Range + let fields = tycon.AllInstanceFieldsAsList + let tinst, ty = mkMinimalTy g tcref + let thisv, thataddrv, thise, thataddre = mkThisVarThatVar g m ty + + let mkTest (fspec: RecdField) = + let fref = tcref.MakeNestedRecdFieldRef fspec + let m = fref.Range + + mkCallGenericEqualityEROuter + g + m + fspec.FormalType + (mkRecdFieldGetViaExprAddr (thise, fref, tinst, m)) + (mkRecdFieldGetViaExprAddr (thataddre, fref, tinst, m)) + + let expr = mkEqualsTestConjuncts g m (List.map mkTest fields) + + let expr = + if tycon.IsStructOrEnumTycon then + expr + else + mkBindThatNullEquals g m thise thataddre expr + + let thatv, expr = mkThatVarBind g m ty thataddrv expr + thisv, thatv, expr + +/// Build the equality implementation for a record type when parameterized by a comparer +let mkRecdEqualityWithComparer g tcref (tycon: Tycon) (_thisv, thise) thatobje (thatv, thate) compe = + let m = tycon.Range + let fields = tycon.AllInstanceFieldsAsList + let tinst, ty = mkMinimalTy g tcref + let thataddrv, thataddre = mkThatAddrLocal g m ty + + let mkTest (fspec: RecdField) = + let fref = tcref.MakeNestedRecdFieldRef fspec + let m = fref.Range + + mkCallGenericEqualityWithComparerOuter + g + m + fspec.FormalType + compe + (mkRecdFieldGetViaExprAddr (thise, fref, tinst, m)) + (mkRecdFieldGetViaExprAddr (thataddre, fref, tinst, m)) + + let expr = mkEqualsTestConjuncts g m (List.map mkTest fields) + + let expr = mkBindThatAddr g m ty thataddrv thatv thate expr + // will be optimized away if not necessary + let expr = mkIsInstConditional g m ty thatobje thatv expr (mkFalse g m) + + let expr = + if tycon.IsStructOrEnumTycon then + expr + else + mkBindThisNullEquals g m thise thatobje expr + + expr + +/// Build the equality implementation for an exception definition +let mkExnEquality (g: TcGlobals) exnref (exnc: Tycon) = + let m = exnc.Range + let thatv, thate = mkCompGenLocal m "obj" g.exn_ty + let thisv, thise = mkThisVar g m g.exn_ty + + let mkTest i (rfield: RecdField) = + mkCallGenericEqualityEROuter + g + m + rfield.FormalType + (mkExnCaseFieldGet (thise, exnref, i, m)) + (mkExnCaseFieldGet (thate, exnref, i, m)) + + let expr = mkEqualsTestConjuncts g m (List.mapi mkTest exnc.AllInstanceFieldsAsList) + + let expr = + let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m) + + let cases = + [ + mkCase (DecisionTreeTest.IsInst(g.exn_ty, mkAppTy exnref []), mbuilder.AddResultTarget(expr)) + ] + + let dflt = Some(mbuilder.AddResultTarget(mkFalse g m)) + let dtree = TDSwitch(thate, cases, dflt, m) + mbuilder.Close(dtree, m, g.bool_ty) + + let expr = mkBindThatNullEquals g m thise thate expr + thisv, thatv, expr + +/// Build the equality implementation for an exception definition when parameterized by a comparer +let mkExnEqualityWithComparer g exnref (exnc: Tycon) (_thisv, thise) thatobje (thatv, thate) compe = + let m = exnc.Range + let thataddrv, thataddre = mkThatAddrLocal g m g.exn_ty + + let mkTest i (rfield: RecdField) = + mkCallGenericEqualityWithComparerOuter + g + m + rfield.FormalType + compe + (mkExnCaseFieldGet (thise, exnref, i, m)) + (mkExnCaseFieldGet (thataddre, exnref, i, m)) + + let expr = mkEqualsTestConjuncts g m (List.mapi mkTest exnc.AllInstanceFieldsAsList) + + let expr = + let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m) + + let cases = + [ + mkCase (DecisionTreeTest.IsInst(g.exn_ty, mkAppTy exnref []), mbuilder.AddResultTarget(expr)) + ] + + let dflt = mbuilder.AddResultTarget(mkFalse g m) + let dtree = TDSwitch(thate, cases, Some dflt, m) + mbuilder.Close(dtree, m, g.bool_ty) + + let expr = mkBindThatAddr g m g.exn_ty thataddrv thatv thate expr + let expr = mkIsInstConditional g m g.exn_ty thatobje thatv expr (mkFalse g m) + + let expr = + if exnc.IsStructOrEnumTycon then + expr + else + mkBindThisNullEquals g m thise thatobje expr + + expr + +/// Build the comparison implementation for a union type +let mkUnionCompare g tcref (tycon: Tycon) = + let m = tycon.Range + let ucases = tycon.UnionCasesAsList + let tinst, ty = mkMinimalTy g tcref + let thisv, thataddrv, thise, thataddre = mkThisVarThatVar g m ty + let thistagv, thistage = mkCompGenLocal m "thisTag" g.int_ty + let thattagv, thattage = mkCompGenLocal m "thatTag" g.int_ty + let compe = mkILCallGetComparer g m + + let expr = + let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m) + + let mkCase ucase = + let cref = tcref.MakeNestedUnionCaseRef ucase + let m = cref.Range + let rfields = ucase.RecdFields + + if isNil rfields then + None + else + let mkTest thise thataddre j (fld: RecdField) = + mkCallGenericComparisonWithComparerOuter + g + m + fld.FormalType + compe + (mkUnionCaseFieldGetProvenViaExprAddr (thise, cref, tinst, j, m)) + (mkUnionCaseFieldGetProvenViaExprAddr (thataddre, cref, tinst, j, m)) + + let test = + if cref.Tycon.IsStructOrEnumTycon then + mkCompareTestConjuncts g m (List.mapi (mkTest thise thataddre) rfields) + else + let thisucv, thisucve = mkCompGenLocal m "thisCast" (mkProvenUnionCaseTy cref tinst) + let thatucv, thatucve = mkCompGenLocal m "objCast" (mkProvenUnionCaseTy cref tinst) + + mkCompGenLet + m + thisucv + (mkUnionCaseProof (thise, cref, tinst, m)) + (mkCompGenLet + m + thatucv + (mkUnionCaseProof (thataddre, cref, tinst, m)) + (mkCompareTestConjuncts g m (List.mapi (mkTest thisucve thatucve) rfields))) + + Some(mkCase (DecisionTreeTest.UnionCase(cref, tinst), mbuilder.AddResultTarget(test))) + + let nullary, nonNullary = List.partition Option.isNone (List.map mkCase ucases) + + if isNil nonNullary then + mkZero g m + else + let cases = + nonNullary + |> List.map (function + | Some c -> c + | None -> failwith "mkUnionCompare") + + let dflt = + if isNil nullary then + None + else + Some(mbuilder.AddResultTarget(mkZero g m)) + + let dtree = TDSwitch(thise, cases, dflt, m) + mbuilder.Close(dtree, m, g.int_ty) + + let expr = + if List.isSingleton ucases then + expr + else + + let tagsEqTested = + mkCond + DebugPointAtBinding.NoneAtSticky + m + g.int_ty + (mkILAsmCeq g m thistage thattage) + expr + (mkAsmExpr ([ AI_sub ], [], [ thistage; thattage ], [ g.int_ty ], m)) in + + mkCompGenLet + m + thistagv + (mkUnionCaseTagGetViaExprAddr (thise, tcref, tinst, m)) + (mkCompGenLet m thattagv (mkUnionCaseTagGetViaExprAddr (thataddre, tcref, tinst, m)) tagsEqTested) + + let expr = + if tycon.IsStructOrEnumTycon then + expr + else + mkBindNullComparison g m thise thataddre expr + + let thatv, expr = mkThatVarBind g m ty thataddrv expr + thisv, thatv, expr + +/// Build the comparison implementation for a union type when parameterized by a comparer +let mkUnionCompareWithComparer g tcref (tycon: Tycon) (_thisv, thise) (_thatobjv, thatcaste) compe = + let m = tycon.Range + let ucases = tycon.UnionCasesAsList + let tinst, ty = mkMinimalTy g tcref + let tcv, tce = mkCompGenLocal m "objTemp" ty // let tcv = (thatobj :?> ty) + let thataddrvOpt, thataddre = mkThatAddrLocalIfNeeded g m tce ty // let thataddrv = &tcv if struct, otherwise thataddre is just tce + let thistagv, thistage = mkCompGenLocal m "thisTag" g.int_ty + let thattagv, thattage = mkCompGenLocal m "thatTag" g.int_ty + + let expr = + let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m) + + let mkCase ucase = + let cref = tcref.MakeNestedUnionCaseRef ucase + let m = cref.Range + let rfields = ucase.RecdFields + + if isNil rfields then + None + else + + let mkTest thise thataddre j (fld: RecdField) = + mkCallGenericComparisonWithComparerOuter + g + m + fld.FormalType + compe + (mkUnionCaseFieldGetProvenViaExprAddr (thise, cref, tinst, j, m)) + (mkUnionCaseFieldGetProvenViaExprAddr (thataddre, cref, tinst, j, m)) + + let test = + if cref.Tycon.IsStructOrEnumTycon then + mkCompareTestConjuncts g m (List.mapi (mkTest thise thataddre) rfields) + else + let thisucv, thisucve = + mkCompGenLocal m "thisCastu" (mkProvenUnionCaseTy cref tinst) + + let thatucv, thatucve = + mkCompGenLocal m "thatCastu" (mkProvenUnionCaseTy cref tinst) + + mkCompGenLet + m + thisucv + (mkUnionCaseProof (thise, cref, tinst, m)) + (mkCompGenLet + m + thatucv + (mkUnionCaseProof (thataddre, cref, tinst, m)) + (mkCompareTestConjuncts g m (List.mapi (mkTest thisucve thatucve) rfields))) + + Some(mkCase (DecisionTreeTest.UnionCase(cref, tinst), mbuilder.AddResultTarget(test))) + + let nullary, nonNullary = List.partition Option.isNone (List.map mkCase ucases) + + if isNil nonNullary then + mkZero g m + else + let cases = + nonNullary + |> List.map (function + | Some c -> c + | None -> failwith "mkUnionCompare") + + let dflt = + if isNil nullary then + None + else + Some(mbuilder.AddResultTarget(mkZero g m)) + + let dtree = TDSwitch(thise, cases, dflt, m) + mbuilder.Close(dtree, m, g.int_ty) + + let expr = + if List.isSingleton ucases then + expr + else + + let tagsEqTested = + mkCond + DebugPointAtBinding.NoneAtSticky + m + g.int_ty + (mkILAsmCeq g m thistage thattage) + expr + (mkAsmExpr ([ AI_sub ], [], [ thistage; thattage ], [ g.int_ty ], m)) + + mkCompGenLet + m + thistagv + (mkUnionCaseTagGetViaExprAddr (thise, tcref, tinst, m)) + (mkCompGenLet m thattagv (mkUnionCaseTagGetViaExprAddr (thataddre, tcref, tinst, m)) tagsEqTested) + + let expr = + if tycon.IsStructOrEnumTycon then + expr + else + mkBindNullComparison g m thise thatcaste expr + + let expr = mkBindThatAddrIfNeeded m thataddrvOpt tcv expr + let expr = mkCompGenLet m tcv thatcaste expr + expr + +/// Build the equality implementation for a union type +let mkUnionEquality g tcref (tycon: Tycon) = + let m = tycon.Range + let ucases = tycon.UnionCasesAsList + let tinst, ty = mkMinimalTy g tcref + let thisv, thataddrv, thise, thataddre = mkThisVarThatVar g m ty + let thistagv, thistage = mkCompGenLocal m "thisTag" g.int_ty + let thattagv, thattage = mkCompGenLocal m "thatTag" g.int_ty + + let expr = + let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m) + + let mkCase ucase = + let cref = tcref.MakeNestedUnionCaseRef ucase + let m = cref.Range + let rfields = ucase.RecdFields + + if isNil rfields then + None + else + + let mkTest thise thataddre j (fld: RecdField) = + mkCallGenericEqualityEROuter + g + m + fld.FormalType + (mkUnionCaseFieldGetProvenViaExprAddr (thise, cref, tinst, j, m)) + (mkUnionCaseFieldGetProvenViaExprAddr (thataddre, cref, tinst, j, m)) + + let test = + if cref.Tycon.IsStructOrEnumTycon then + mkEqualsTestConjuncts g m (List.mapi (mkTest thise thataddre) rfields) + else + let thisucv, thisucve = mkCompGenLocal m "thisCast" (mkProvenUnionCaseTy cref tinst) + let thatucv, thatucve = mkCompGenLocal m "objCast" (mkProvenUnionCaseTy cref tinst) + + mkCompGenLet + m + thisucv + (mkUnionCaseProof (thise, cref, tinst, m)) + (mkCompGenLet + m + thatucv + (mkUnionCaseProof (thataddre, cref, tinst, m)) + (mkEqualsTestConjuncts g m (List.mapi (mkTest thisucve thatucve) rfields))) + + Some(mkCase (DecisionTreeTest.UnionCase(cref, tinst), mbuilder.AddResultTarget(test))) + + let nullary, nonNullary = List.partition Option.isNone (List.map mkCase ucases) + + if isNil nonNullary then + mkTrue g m + else + let cases = + List.map + (function + | Some c -> c + | None -> failwith "mkUnionEquality") + nonNullary + + let dflt = + (if isNil nullary then + None + else + Some(mbuilder.AddResultTarget(mkTrue g m))) + + let dtree = TDSwitch(thise, cases, dflt, m) + mbuilder.Close(dtree, m, g.bool_ty) + + let expr = + if List.isSingleton ucases then + expr + else + + let tagsEqTested = + mkCond DebugPointAtBinding.NoneAtSticky m g.bool_ty (mkILAsmCeq g m thistage thattage) expr (mkFalse g m) + + mkCompGenLet + m + thistagv + (mkUnionCaseTagGetViaExprAddr (thise, tcref, tinst, m)) + (mkCompGenLet m thattagv (mkUnionCaseTagGetViaExprAddr (thataddre, tcref, tinst, m)) tagsEqTested) + + let thatv, expr = mkThatVarBind g m ty thataddrv expr + + let expr = + if tycon.IsStructOrEnumTycon then + expr + else + mkBindThatNullEquals g m thise thataddre expr + + thisv, thatv, expr + +/// Build the equality implementation for a union type when parameterized by a comparer +let mkUnionEqualityWithComparer g tcref (tycon: Tycon) (_thisv, thise) thatobje (thatv, thate) compe = + let m = tycon.Range + let ucases = tycon.UnionCasesAsList + let tinst, ty = mkMinimalTy g tcref + let thistagv, thistage = mkCompGenLocal m "thisTag" g.int_ty + let thattagv, thattage = mkCompGenLocal m "thatTag" g.int_ty + let thataddrv, thataddre = mkThatAddrLocal g m ty + + let expr = + let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m) + + let mkCase ucase = + let cref = tcref.MakeNestedUnionCaseRef ucase + let m = cref.Range + + let rfields = ucase.RecdFields + + if isNil rfields then + None + else + + let mkTest thise thataddre j (fld: RecdField) = + mkCallGenericEqualityWithComparerOuter + g + m + fld.FormalType + compe + (mkUnionCaseFieldGetProvenViaExprAddr (thise, cref, tinst, j, m)) + (mkUnionCaseFieldGetProvenViaExprAddr (thataddre, cref, tinst, j, m)) + + let test = + if cref.Tycon.IsStructOrEnumTycon then + mkEqualsTestConjuncts g m (List.mapi (mkTest thise thataddre) rfields) + else + let thisucv, thisucve = + mkCompGenLocal m "thisCastu" (mkProvenUnionCaseTy cref tinst) + + let thatucv, thatucve = + mkCompGenLocal m "thatCastu" (mkProvenUnionCaseTy cref tinst) + + mkCompGenLet + m + thisucv + (mkUnionCaseProof (thise, cref, tinst, m)) + (mkCompGenLet + m + thatucv + (mkUnionCaseProof (thataddre, cref, tinst, m)) + (mkEqualsTestConjuncts g m (List.mapi (mkTest thisucve thatucve) rfields))) + + Some(mkCase (DecisionTreeTest.UnionCase(cref, tinst), mbuilder.AddResultTarget(test))) + + let nullary, nonNullary = List.partition Option.isNone (List.map mkCase ucases) + + if isNil nonNullary then + mkTrue g m + else + let cases = + List.map + (function + | Some c -> c + | None -> failwith "mkUnionEquality") + nonNullary + + let dflt = + if isNil nullary then + None + else + Some(mbuilder.AddResultTarget(mkTrue g m)) + + let dtree = TDSwitch(thise, cases, dflt, m) + mbuilder.Close(dtree, m, g.bool_ty) + + let expr = + if List.isSingleton ucases then + expr + else + + let tagsEqTested = + mkCond DebugPointAtBinding.NoneAtSticky m g.bool_ty (mkILAsmCeq g m thistage thattage) expr (mkFalse g m) + + mkCompGenLet + m + thistagv + (mkUnionCaseTagGetViaExprAddr (thise, tcref, tinst, m)) + (mkCompGenLet m thattagv (mkUnionCaseTagGetViaExprAddr (thataddre, tcref, tinst, m)) tagsEqTested) + + let expr = mkBindThatAddr g m ty thataddrv thatv thate expr + let expr = mkIsInstConditional g m ty thatobje thatv expr (mkFalse g m) + + let expr = + if tycon.IsStructOrEnumTycon then + expr + else + mkBindThisNullEquals g m thise thatobje expr + + expr + +//------------------------------------------------------------------------- +// Build hashing functions for union, record and exception types. +// Hashing functions must respect the "=" and comparison operators. +//------------------------------------------------------------------------- + +/// Structural hash implementation for record types when parameterized by a comparer +let mkRecdHashWithComparer g tcref (tycon: Tycon) compe = + let m = tycon.Range + let fields = tycon.AllInstanceFieldsAsList + let tinst, ty = mkMinimalTy g tcref + let thisv, thise = mkThisVar g m ty + + let mkFieldHash (fspec: RecdField) = + let fref = tcref.MakeNestedRecdFieldRef fspec + let m = fref.Range + let e = mkRecdFieldGetViaExprAddr (thise, fref, tinst, m) + + mkCallGenericHashWithComparerOuter g m fspec.FormalType compe e + + let accv, acce = mkMutableCompGenLocal m "i" g.int_ty + + let stmt = + mkCombineHashGenerators g m (List.map mkFieldHash fields) (mkLocalValRef accv) acce + + let expr = mkCompGenLet m accv (mkZero g m) stmt + + let expr = + if tycon.IsStructOrEnumTycon then + expr + else + mkBindNullHash g m thise expr + + thisv, expr + +/// Structural hash implementation for exception types when parameterized by a comparer +let mkExnHashWithComparer g exnref (exnc: Tycon) compe = + let m = exnc.Range + let thisv, thise = mkThisVar g m g.exn_ty + + let mkHash i (rfield: RecdField) = + let e = mkExnCaseFieldGet (thise, exnref, i, m) + + mkCallGenericHashWithComparerOuter g m rfield.FormalType compe e + + let accv, acce = mkMutableCompGenLocal m "i" g.int_ty + + let stmt = + mkCombineHashGenerators g m (List.mapi mkHash exnc.AllInstanceFieldsAsList) (mkLocalValRef accv) acce + + let expr = mkCompGenLet m accv (mkZero g m) stmt + let expr = mkBindNullHash g m thise expr + thisv, expr + +/// Structural hash implementation for union types when parameterized by a comparer +let mkUnionHashWithComparer g tcref (tycon: Tycon) compe = + let m = tycon.Range + let ucases = tycon.UnionCasesAsList + let tinst, ty = mkMinimalTy g tcref + let thisv, thise = mkThisVar g m ty + let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m) + let accv, acce = mkMutableCompGenLocal m "i" g.int_ty + + let mkCase i ucase1 = + let c1ref = tcref.MakeNestedUnionCaseRef ucase1 + let m = c1ref.Range + + if ucase1.IsNullary then + None + else + let mkHash thise j (rfield: RecdField) = + let e = mkUnionCaseFieldGetProvenViaExprAddr (thise, c1ref, tinst, j, m) + mkCallGenericHashWithComparerOuter g m rfield.FormalType compe e + + let test = + if tycon.IsStructOrEnumTycon then + mkCompGenSequential + m + (mkValSet m (mkLocalValRef accv) (mkInt g m i)) + (mkCombineHashGenerators g m (List.mapi (mkHash thise) ucase1.RecdFields) (mkLocalValRef accv) acce) + else + let ucv, ucve = mkCompGenLocal m "unionCase" (mkProvenUnionCaseTy c1ref tinst) + + mkCompGenLet + m + ucv + (mkUnionCaseProof (thise, c1ref, tinst, m)) + (mkCompGenSequential + m + (mkValSet m (mkLocalValRef accv) (mkInt g m i)) + (mkCombineHashGenerators g m (List.mapi (mkHash ucve) ucase1.RecdFields) (mkLocalValRef accv) acce)) + + Some(mkCase (DecisionTreeTest.UnionCase(c1ref, tinst), mbuilder.AddResultTarget(test))) + + let nullary, nonNullary = + ucases |> List.mapi mkCase |> List.partition (fun i -> i.IsNone) + + let cases = + nonNullary + |> List.map (function + | Some c -> c + | None -> failwith "mkUnionHash") + + let dflt = + if isNil nullary then + None + else + let tag = mkUnionCaseTagGetViaExprAddr (thise, tcref, tinst, m) + Some(mbuilder.AddResultTarget(tag)) + + let dtree = TDSwitch(thise, cases, dflt, m) + let stmt = mbuilder.Close(dtree, m, g.int_ty) + let expr = mkCompGenLet m accv (mkZero g m) stmt + + let expr = + if tycon.IsStructOrEnumTycon then + expr + else + mkBindNullHash g m thise expr + + thisv, expr + +//------------------------------------------------------------------------- +// The predicate that determines which types implement the +// pre-baked IStructuralHash and IComparable semantics associated with F# +// types. Note abstract types are not _known_ to implement these interfaces, +// though the interfaces may be discoverable via type tests. +//------------------------------------------------------------------------- + +let isNominalExnc (exnc: Tycon) = + match exnc.ExceptionInfo with + | TExnAbbrevRepr _ + | TExnNone + | TExnAsmRepr _ -> false + | TExnFresh _ -> true + +let isTrueFSharpStructTycon _g (tycon: Tycon) = + (tycon.IsFSharpStructOrEnumTycon && not tycon.IsFSharpEnumTycon) + +let canBeAugmentedWithEquals g (tycon: Tycon) = + tycon.IsUnionTycon + || tycon.IsRecordTycon + || (tycon.IsFSharpException && isNominalExnc tycon) + || isTrueFSharpStructTycon g tycon + +let canBeAugmentedWithCompare g (tycon: Tycon) = + tycon.IsUnionTycon || tycon.IsRecordTycon || isTrueFSharpStructTycon g tycon + +let getAugmentationAttribs g (tycon: Tycon) = + canBeAugmentedWithEquals g tycon, + canBeAugmentedWithCompare g tycon, + TryFindFSharpBoolAttribute g g.attrib_NoEqualityAttribute tycon.Attribs, + TryFindFSharpBoolAttribute g g.attrib_CustomEqualityAttribute tycon.Attribs, + TryFindFSharpBoolAttribute g g.attrib_ReferenceEqualityAttribute tycon.Attribs, + TryFindFSharpBoolAttribute g g.attrib_StructuralEqualityAttribute tycon.Attribs, + TryFindFSharpBoolAttribute g g.attrib_NoComparisonAttribute tycon.Attribs, + TryFindFSharpBoolAttribute g g.attrib_CustomComparisonAttribute tycon.Attribs, + TryFindFSharpBoolAttribute g g.attrib_StructuralComparisonAttribute tycon.Attribs + +let CheckAugmentationAttribs isImplementation g amap (tycon: Tycon) = + let m = tycon.Range + let attribs = getAugmentationAttribs g tycon + + match attribs with + + // THESE ARE THE LEGITIMATE CASES + + // [< >] on anything + | _, _, None, None, None, None, None, None, None + + // [] on union/record/struct + | true, _, None, Some true, None, None, None, Some true, None + + // [] on union/record/struct + | true, _, None, Some true, None, None, Some true, None, None -> () + + // [] on union/record/struct + | true, _, None, None, Some true, None, Some true, None, None + + // [] on union/record/struct + | true, _, None, None, Some true, None, None, None, None -> + if isTrueFSharpStructTycon g tycon then + errorR (Error(FSComp.SR.augNoRefEqualsOnStruct (), m)) + else + () + + // [] on union/record/struct + | true, true, None, None, None, Some true, None, None, Some true + + // [] + | true, _, None, None, None, Some true, Some true, None, None + + // [] + | true, _, None, None, None, Some true, None, Some true, None + + // [] on anything + | _, _, None, None, None, None, Some true, None, None + + // [] on anything + | _, _, Some true, None, None, None, Some true, None, None -> () + + // THESE ARE THE ERROR CASES + + // [] + | _, _, Some true, _, _, _, None, _, _ -> errorR (Error(FSComp.SR.augNoEqualityNeedsNoComparison (), m)) + + // [] + | true, true, _, _, _, None, _, _, Some true -> errorR (Error(FSComp.SR.augStructCompNeedsStructEquality (), m)) + // [] + | true, _, _, _, _, Some true, None, _, None -> errorR (Error(FSComp.SR.augStructEqNeedsNoCompOrStructComp (), m)) + + // [] + | true, _, _, Some true, _, _, None, None, _ -> errorR (Error(FSComp.SR.augCustomEqNeedsNoCompOrCustomComp (), m)) + + // [] + | true, _, _, _, Some true, Some true, _, _, _ + + // [] + | true, _, _, _, Some true, _, _, _, Some true -> errorR (Error(FSComp.SR.augTypeCantHaveRefEqAndStructAttrs (), m)) + + // non augmented type, [] + // non augmented type, [] + // non augmented type, [] + | false, _, _, _, Some true, _, _, _, _ + | false, _, _, _, _, Some true, _, _, _ + | false, _, _, _, _, _, _, _, Some true -> errorR (Error(FSComp.SR.augOnlyCertainTypesCanHaveAttrs (), m)) + // All other cases + | _ -> errorR (Error(FSComp.SR.augInvalidAttrs (), m)) + + let hasNominalInterface tcref = + let ty = generalizedTyconRef g (mkLocalTyconRef tycon) + ExistsHeadTypeInEntireHierarchy g amap tycon.Range ty tcref + + let hasExplicitICompare = + hasNominalInterface g.tcref_System_IStructuralComparable + || hasNominalInterface g.tcref_System_IComparable + + let hasExplicitIGenericCompare = + hasNominalInterface g.system_GenericIComparable_tcref + + let hasExplicitEquals = + tycon.HasOverride g "Equals" [ g.obj_ty ] + || hasNominalInterface g.tcref_System_IStructuralEquatable + + let hasExplicitGenericEquals = hasNominalInterface g.system_GenericIEquatable_tcref + + match attribs with + // [] + any equality semantics + | _, _, Some true, _, _, _, _, _, _ when (hasExplicitEquals || hasExplicitGenericEquals) -> + warning (Error(FSComp.SR.augNoEqNeedsNoObjEquals (), m)) + // [] + any comparison semantics + | _, _, _, _, _, _, Some true, _, _ when (hasExplicitICompare || hasExplicitIGenericCompare) -> + warning (Error(FSComp.SR.augNoCompCantImpIComp (), m)) + + // [] + no explicit override Object.Equals + no explicit IStructuralEquatable + | _, _, _, Some true, _, _, _, _, _ when isImplementation && not hasExplicitEquals && not hasExplicitGenericEquals -> + errorR (Error(FSComp.SR.augCustomEqNeedsObjEquals (), m)) + // [] + no explicit IComparable + no explicit IStructuralComparable + | _, _, _, _, _, _, _, Some true, _ when isImplementation && not hasExplicitICompare && not hasExplicitIGenericCompare -> + errorR (Error(FSComp.SR.augCustomCompareNeedsIComp (), m)) + + // [] + any equality semantics + | _, _, _, _, Some true, _, _, _, _ when (hasExplicitEquals || hasExplicitIGenericCompare) -> + errorR (Error(FSComp.SR.augRefEqCantHaveObjEquals (), m)) + + | _ -> () + +let TyconIsCandidateForAugmentationWithCompare (g: TcGlobals) (tycon: Tycon) = + // This type gets defined in prim-types, before we can add attributes to F# type definitions + let isUnit = g.compilingFSharpCore && tycon.DisplayName = "Unit" + + not isUnit + && not (isByrefLikeTyconRef g tycon.Range (mkLocalTyconRef tycon)) + && match getAugmentationAttribs g tycon with + // [< >] + | true, true, None, None, None, None, None, None, None + // [] + | true, true, None, None, None, Some true, None, None, Some true + // [] + | true, true, None, None, None, None, None, None, Some true -> true + // other cases + | _ -> false + +let TyconIsCandidateForAugmentationWithEquals (g: TcGlobals) (tycon: Tycon) = + // This type gets defined in prim-types, before we can add attributes to F# type definitions + let isUnit = g.compilingFSharpCore && tycon.DisplayName = "Unit" + + not isUnit + && not (isByrefLikeTyconRef g tycon.Range (mkLocalTyconRef tycon)) + && + + match getAugmentationAttribs g tycon with + // [< >] + | true, _, None, None, None, None, _, _, _ + // [] + // [] + | true, _, None, None, None, Some true, _, _, _ -> true + // other cases + | _ -> false + +let TyconIsCandidateForAugmentationWithHash g tycon = + TyconIsCandidateForAugmentationWithEquals g tycon + +//------------------------------------------------------------------------- +// Make values that represent the implementations of the +// IComparable semantics associated with F# types. +//------------------------------------------------------------------------- + +let slotImplMethod (final, c, slotsig) : ValMemberInfo = + { + ImplementedSlotSigs = [ slotsig ] + MemberFlags = + { + IsInstance = true + IsDispatchSlot = false + IsFinal = final + IsOverrideOrExplicitImpl = true + GetterOrSetterIsCompilerGenerated = false + MemberKind = SynMemberKind.Member + } + IsImplemented = false + ApparentEnclosingEntity = c + } + +let nonVirtualMethod mk c : ValMemberInfo = + { + ImplementedSlotSigs = [] + MemberFlags = + { + IsInstance = true + IsDispatchSlot = false + IsFinal = false + IsOverrideOrExplicitImpl = false + GetterOrSetterIsCompilerGenerated = false + MemberKind = mk + } + IsImplemented = false + ApparentEnclosingEntity = c + } + +let unitArg = ValReprInfo.unitArgData + +let unaryArg = [ ValReprInfo.unnamedTopArg ] + +let tupArg = [ [ ValReprInfo.unnamedTopArg1; ValReprInfo.unnamedTopArg1 ] ] + +let mkValSpecAux g m (tcref: TyconRef) ty vis slotsig methn valTy argData isGetter isCompGen = + let tps = tcref.Typars m + + let membInfo = + match slotsig with + | None -> + let mk = + if isGetter then + SynMemberKind.PropertyGet + else + SynMemberKind.Member + + nonVirtualMethod mk tcref + | Some slotsig -> + let final = isUnionTy g ty || isRecdTy g ty || isStructTy g ty + slotImplMethod (final, tcref, slotsig) + + let inl = ValInline.Optional + let args = ValReprInfo.unnamedTopArg :: argData + + let valReprInfo = + Some(ValReprInfo(ValReprInfo.InferTyparInfo tps, args, ValReprInfo.unnamedRetVal)) + + Construct.NewVal( + methn, + m, + None, + valTy, + Immutable, + isCompGen, + valReprInfo, + vis, + ValNotInRecScope, + Some membInfo, + NormalVal, + [], + inl, + XmlDoc.Empty, + true, + false, + false, + false, + false, + false, + None, + Parent tcref + ) + +let mkValSpec g (tcref: TyconRef) ty vis slotsig methn valTy argData isGetter = + mkValSpecAux g tcref.Range tcref ty vis slotsig methn valTy argData isGetter true + +// Unlike other generated items, the 'IsABC' propeties are visible, not considered compiler-generated +let mkImpliedValSpec g m tcref ty vis slotsig methn valTy argData isGetter = + let v = mkValSpecAux g m tcref ty vis slotsig methn valTy argData isGetter false + v.SetIsImplied() + v + +let MakeValsForCompareAugmentation g (tcref: TyconRef) = + let m = tcref.Range + let _, ty = mkMinimalTy g tcref + let tps = tcref.Typars m + let vis = tcref.TypeReprAccessibility + + mkValSpec g tcref ty vis (Some(mkIComparableCompareToSlotSig g)) "CompareTo" (tps +-> (mkCompareObjTy g ty)) unaryArg false, + mkValSpec g tcref ty vis (Some(mkGenericIComparableCompareToSlotSig g ty)) "CompareTo" (tps +-> (mkCompareTy g ty)) unaryArg false + +let MakeValsForCompareWithComparerAugmentation g (tcref: TyconRef) = + let m = tcref.Range + let _, ty = mkMinimalTy g tcref + let tps = tcref.Typars m + let vis = tcref.TypeReprAccessibility + + mkValSpec + g + tcref + ty + vis + (Some(mkIStructuralComparableCompareToSlotSig g)) + "CompareTo" + (tps +-> (mkCompareWithComparerTy g ty)) + tupArg + false + +let MakeValsForEqualsAugmentation g (tcref: TyconRef) = + let m = tcref.Range + let _, ty = mkMinimalTy g tcref + let vis = tcref.TypeReprAccessibility + let tps = tcref.Typars m + + let objEqualsVal = + mkValSpec g tcref ty vis (Some(mkEqualsSlotSig g)) "Equals" (tps +-> (mkEqualsObjTy g ty)) unaryArg false + + let nocEqualsVal = + mkValSpec + g + tcref + ty + vis + (if tcref.Deref.IsFSharpException then + None + else + Some(mkGenericIEquatableEqualsSlotSig g ty)) + "Equals" + (tps +-> (mkEqualsTy g ty)) + unaryArg + false + + objEqualsVal, nocEqualsVal + +let MakeValsForEqualityWithComparerAugmentation g (tcref: TyconRef) = + let _, ty = mkMinimalTy g tcref + let vis = tcref.TypeReprAccessibility + let tps = tcref.Typars tcref.Range + + let objGetHashCodeVal = + mkValSpec g tcref ty vis (Some(mkGetHashCodeSlotSig g)) "GetHashCode" (tps +-> (mkHashTy g ty)) unitArg false + + let withcGetHashCodeVal = + mkValSpec + g + tcref + ty + vis + (Some(mkIStructuralEquatableGetHashCodeSlotSig g)) + "GetHashCode" + (tps +-> (mkHashWithComparerTy g ty)) + unaryArg + false + + let withcEqualsVal = + mkValSpec g tcref ty vis (Some(mkIStructuralEquatableEqualsSlotSig g)) "Equals" (tps +-> (mkEqualsWithComparerTy g ty)) tupArg false + + objGetHashCodeVal, withcGetHashCodeVal, withcEqualsVal + +let MakeBindingsForCompareAugmentation g (tycon: Tycon) = + let tcref = mkLocalTyconRef tycon + let m = tycon.Range + let tps = tycon.Typars m + + let mkCompare comparef = + match tycon.GeneratedCompareToValues with + | None -> [] + | Some (vref1, vref2) -> + let vspec1 = vref1.Deref + let vspec2 = vref2.Deref + (* this is the body of the override *) + let rhs1 = + let tinst, ty = mkMinimalTy g tcref + + let thisv, thise = mkThisVar g m ty + let thatobjv, thatobje = mkCompGenLocal m "obj" g.obj_ty + + let comparee = + if isUnitTy g ty then + mkZero g m + else + let thate = mkCoerceExpr (thatobje, ty, m, g.obj_ty) + + mkApps g ((exprForValRef m vref2, vref2.Type), (if isNil tinst then [] else [ tinst ]), [ thise; thate ], m) + + mkLambdas g m tps [ thisv; thatobjv ] (comparee, g.int_ty) + + let rhs2 = + let thisv, thatv, comparee = comparef g tcref tycon + mkLambdas g m tps [ thisv; thatv ] (comparee, g.int_ty) + + [ // This one must come first because it may be inlined into the second + mkCompGenBind vspec2 rhs2 + mkCompGenBind vspec1 rhs1 + ] + + if tycon.IsUnionTycon then + mkCompare mkUnionCompare + elif tycon.IsRecordTycon || tycon.IsStructOrEnumTycon then + mkCompare mkRecdCompare + else + [] + +let MakeBindingsForCompareWithComparerAugmentation g (tycon: Tycon) = + let tcref = mkLocalTyconRef tycon + let m = tycon.Range + let tps = tycon.Typars m + + let mkCompare comparef = + match tycon.GeneratedCompareToWithComparerValues with + | None -> [] + | Some vref -> + let vspec = vref.Deref + let _, ty = mkMinimalTy g tcref + + let compv, compe = mkCompGenLocal m "comp" g.IComparer_ty + + let thisv, thise = mkThisVar g m ty + let thatobjv, thatobje = mkCompGenLocal m "obj" g.obj_ty + let thate = mkCoerceExpr (thatobje, ty, m, g.obj_ty) + + let rhs = + let comparee = comparef g tcref tycon (thisv, thise) (thatobjv, thate) compe + let comparee = if isUnitTy g ty then mkZero g m else comparee + mkMultiLambdas g m tps [ [ thisv ]; [ thatobjv; compv ] ] (comparee, g.int_ty) + + [ mkCompGenBind vspec rhs ] + + if tycon.IsUnionTycon then + mkCompare mkUnionCompareWithComparer + elif tycon.IsRecordTycon || tycon.IsStructOrEnumTycon then + mkCompare mkRecdCompareWithComparer + else + [] + +let MakeBindingsForEqualityWithComparerAugmentation (g: TcGlobals) (tycon: Tycon) = + let tcref = mkLocalTyconRef tycon + let m = tycon.Range + let tps = tycon.Typars m + + let mkStructuralEquatable hashf equalsf = + match tycon.GeneratedHashAndEqualsWithComparerValues with + | None -> [] + | Some (objGetHashCodeVal, withcGetHashCodeVal, withcEqualsVal) -> + + // build the hash rhs + let withcGetHashCodeExpr = + let compv, compe = mkCompGenLocal m "comp" g.IEqualityComparer_ty + + // Special case List type to avoid StackOverflow exception , call custom hash code instead + let thisv, hashe = + if + tyconRefEq g tcref g.list_tcr_canon + && tycon.HasMember g "CustomHashCode" [ g.IEqualityComparer_ty ] + then + let customCodeVal = + (tycon.TryGetMember g "CustomHashCode" [ g.IEqualityComparer_ty ]).Value + + let tinst, ty = mkMinimalTy g tcref + let thisv, thise = mkThisVar g m ty + + thisv, + mkApps + g + ((exprForValRef m customCodeVal, customCodeVal.Type), + (if isNil tinst then [] else [ tinst ]), + [ thise; compe ], + m) + else + hashf g tcref tycon compe + + mkLambdas g m tps [ thisv; compv ] (hashe, g.int_ty) + + // build the equals rhs + let withcEqualsExpr = + let _tinst, ty = mkMinimalTy g tcref + let thisv, thise = mkThisVar g m ty + let thatobjv, thatobje = mkCompGenLocal m "obj" g.obj_ty + let thatv, thate = mkCompGenLocal m "that" ty + let compv, compe = mkCompGenLocal m "comp" g.IEqualityComparer_ty + let equalse = equalsf g tcref tycon (thisv, thise) thatobje (thatv, thate) compe + mkMultiLambdas g m tps [ [ thisv ]; [ thatobjv; compv ] ] (equalse, g.bool_ty) + + let objGetHashCodeExpr = + let tinst, ty = mkMinimalTy g tcref + + let thisv, thise = mkThisVar g m ty + let unitv, _ = mkCompGenLocal m "unitArg" g.unit_ty + + let hashe = + if isUnitTy g ty then + mkZero g m + else + + let compe = mkILCallGetEqualityComparer g m + + mkApps + g + ((exprForValRef m withcGetHashCodeVal, withcGetHashCodeVal.Type), + (if isNil tinst then [] else [ tinst ]), + [ thise; compe ], + m) + + mkLambdas g m tps [ thisv; unitv ] (hashe, g.int_ty) + + [ + (mkCompGenBind withcGetHashCodeVal.Deref withcGetHashCodeExpr) + (mkCompGenBind objGetHashCodeVal.Deref objGetHashCodeExpr) + (mkCompGenBind withcEqualsVal.Deref withcEqualsExpr) + ] + + if tycon.IsUnionTycon then + mkStructuralEquatable mkUnionHashWithComparer mkUnionEqualityWithComparer + elif (tycon.IsRecordTycon || tycon.IsStructOrEnumTycon) then + mkStructuralEquatable mkRecdHashWithComparer mkRecdEqualityWithComparer + elif tycon.IsFSharpException then + mkStructuralEquatable mkExnHashWithComparer mkExnEqualityWithComparer + else + [] + +let MakeBindingsForEqualsAugmentation (g: TcGlobals) (tycon: Tycon) = + let tcref = mkLocalTyconRef tycon + let m = tycon.Range + let tps = tycon.Typars m + + let mkEquals equalsf = + match tycon.GeneratedHashAndEqualsValues with + | None -> [] + | Some (objEqualsVal, nocEqualsVal) -> + // this is the body of the real strongly typed implementation + let nocEqualsExpr = + let thisv, thatv, equalse = equalsf g tcref tycon + mkLambdas g m tps [ thisv; thatv ] (equalse, g.bool_ty) + + // this is the body of the override + let objEqualsExpr = + let tinst, ty = mkMinimalTy g tcref + + let thisv, thise = mkThisVar g m ty + let thatobjv, thatobje = mkCompGenLocal m "obj" g.obj_ty + + let equalse = + if isUnitTy g ty then + mkTrue g m + else + + let thatv, thate = mkCompGenLocal m "that" ty + + mkIsInstConditional + g + m + ty + thatobje + thatv + (mkApps + g + ((exprForValRef m nocEqualsVal, nocEqualsVal.Type), + (if isNil tinst then [] else [ tinst ]), + [ thise; thate ], + m)) + (mkFalse g m) + + mkLambdas g m tps [ thisv; thatobjv ] (equalse, g.bool_ty) + + [ + mkCompGenBind nocEqualsVal.Deref nocEqualsExpr + mkCompGenBind objEqualsVal.Deref objEqualsExpr + ] + + if tycon.IsFSharpException then + mkEquals mkExnEquality + elif tycon.IsUnionTycon then + mkEquals mkUnionEquality + elif tycon.IsRecordTycon || tycon.IsStructOrEnumTycon then + mkEquals mkRecdEquality + else + [] + +let rec TypeDefinitelyHasEquality g ty = + let appTy = tryAppTy g ty + + match appTy with + | ValueSome (tcref, _) when HasFSharpAttribute g g.attrib_NoEqualityAttribute tcref.Attribs -> false + | _ -> + if + isTyparTy g ty + && (destTyparTy g ty).Constraints + |> List.exists (function + | TyparConstraint.SupportsEquality _ -> true + | _ -> false) + then + true + else + match ty with + | SpecialEquatableHeadType g tinst -> tinst |> List.forall (TypeDefinitelyHasEquality g) + | SpecialNotEquatableHeadType g _ -> false + | _ -> + // The type is equatable because it has Object.Equals(...) + match appTy with + | ValueSome (tcref, tinst) -> + // Give a good error for structural types excluded from the equality relation because of their fields + not ( + TyconIsCandidateForAugmentationWithEquals g tcref.Deref + && Option.isNone tcref.GeneratedHashAndEqualsWithComparerValues + ) + && + // Check the (possibly inferred) structural dependencies + (tinst, tcref.TyparsNoRange) + ||> List.lengthsEqAndForall2 (fun ty tp -> not tp.EqualityConditionalOn || TypeDefinitelyHasEquality g ty) + | _ -> false + +let MakeValsForUnionAugmentation g (tcref: TyconRef) = + let m = tcref.Range + let _, tmty = mkMinimalTy g tcref + let vis = tcref.TypeReprAccessibility + let tps = tcref.Typars m + + tcref.UnionCasesAsList + |> List.map (fun uc -> + // Unlike other generated items, the 'IsABC' propeties are visible, not considered compiler-generated + let v = + mkImpliedValSpec g uc.Range tcref tmty vis None ("get_Is" + uc.CompiledName) (tps +-> (mkIsCaseTy g tmty)) unitArg true + + g.AddValGeneratedAttributes v m + v) + +let MakeBindingsForUnionAugmentation g (tycon: Tycon) (vals: ValRef list) = + let tcref = mkLocalTyconRef tycon + let m = tycon.Range + let tps = tycon.Typars m + let tinst, ty = mkMinimalTy g tcref + let thisv, thise = mkThisVar g m ty + let unitv, _ = mkCompGenLocal m "unitArg" g.unit_ty + + (tcref.UnionCasesAsRefList, vals) + ||> List.map2 (fun ucr v -> + let isdata = mkUnionCaseTest g (thise, ucr, tinst, m) + let expr = mkLambdas g m tps [ thisv; unitv ] (isdata, g.bool_ty) + mkCompGenBind v.Deref expr) diff --git a/src/Compiler/Checking/AugmentWithHashCompare.fsi b/src/Compiler/Checking/AugmentTypeDefinitions.fsi similarity index 87% rename from src/Compiler/Checking/AugmentWithHashCompare.fsi rename to src/Compiler/Checking/AugmentTypeDefinitions.fsi index ea991b0340d..5fa185c0460 100644 --- a/src/Compiler/Checking/AugmentWithHashCompare.fsi +++ b/src/Compiler/Checking/AugmentTypeDefinitions.fsi @@ -1,7 +1,7 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. /// Generate the hash/compare functions we add to user-defined types by default. -module internal FSharp.Compiler.AugmentWithHashCompare +module internal FSharp.Compiler.AugmentTypeDefinitions open FSharp.Compiler open FSharp.Compiler.TypedTree @@ -34,3 +34,7 @@ val MakeBindingsForEqualityWithComparerAugmentation: TcGlobals -> Tycon -> Bindi /// This predicate can be used once type inference is complete, before then it is an approximation /// that doesn't assert any new constraints val TypeDefinitelyHasEquality: TcGlobals -> TType -> bool + +val MakeValsForUnionAugmentation: TcGlobals -> TyconRef -> Val list + +val MakeBindingsForUnionAugmentation: TcGlobals -> Tycon -> ValRef list -> Binding list diff --git a/src/Compiler/Checking/AugmentWithHashCompare.fs b/src/Compiler/Checking/AugmentWithHashCompare.fs deleted file mode 100644 index 63ba529b220..00000000000 --- a/src/Compiler/Checking/AugmentWithHashCompare.fs +++ /dev/null @@ -1,1098 +0,0 @@ -// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. - -/// Generate the hash/compare functions we add to user-defined types by default. -module internal FSharp.Compiler.AugmentWithHashCompare - -open Internal.Utilities.Library -open FSharp.Compiler.AbstractIL.IL -open FSharp.Compiler.DiagnosticsLogger -open FSharp.Compiler.Syntax -open FSharp.Compiler.Xml -open FSharp.Compiler.TcGlobals -open FSharp.Compiler.TypedTree -open FSharp.Compiler.TypedTreeBasics -open FSharp.Compiler.TypedTreeOps -open FSharp.Compiler.TypeHierarchy - -let mkIComparableCompareToSlotSig (g: TcGlobals) = - TSlotSig("CompareTo", g.mk_IComparable_ty, [], [], [[TSlotParam(Some("obj"), g.obj_ty, false, false, false, [])]], Some g.int_ty) - -let mkGenericIComparableCompareToSlotSig (g: TcGlobals) ty = - TSlotSig("CompareTo", (mkAppTy g.system_GenericIComparable_tcref [ty]), [], [], [[TSlotParam(Some("obj"), ty, false, false, false, [])]], Some g.int_ty) - -let mkIStructuralComparableCompareToSlotSig (g: TcGlobals) = - TSlotSig("CompareTo", g.mk_IStructuralComparable_ty, [], [], [[TSlotParam(None, (mkRefTupledTy g [g.obj_ty ; g.IComparer_ty]), false, false, false, [])]], Some g.int_ty) - -let mkGenericIEquatableEqualsSlotSig (g: TcGlobals) ty = - TSlotSig("Equals", (mkAppTy g.system_GenericIEquatable_tcref [ty]), [], [], [[TSlotParam(Some("obj"), ty, false, false, false, [])]], Some g.bool_ty) - -let mkIStructuralEquatableEqualsSlotSig (g: TcGlobals) = - TSlotSig("Equals", g.mk_IStructuralEquatable_ty, [], [], [[TSlotParam(None, (mkRefTupledTy g [g.obj_ty ; g.IEqualityComparer_ty]), false, false, false, [])]], Some g.bool_ty) - -let mkIStructuralEquatableGetHashCodeSlotSig (g: TcGlobals) = - TSlotSig("GetHashCode", g.mk_IStructuralEquatable_ty, [], [], [[TSlotParam(None, g.IEqualityComparer_ty, false, false, false, [])]], Some g.int_ty) - -let mkGetHashCodeSlotSig (g: TcGlobals) = - TSlotSig("GetHashCode", g.obj_ty, [], [], [[]], Some g.int_ty) - -let mkEqualsSlotSig (g: TcGlobals) = - TSlotSig("Equals", g.obj_ty, [], [], [[TSlotParam(Some("obj"), g.obj_ty, false, false, false, [])]], Some g.bool_ty) - -//------------------------------------------------------------------------- -// Helpers associated with code-generation of comparison/hash augmentations -//------------------------------------------------------------------------- - -let mkThisTy g ty = if isStructTy g ty then mkByrefTy g ty else ty - -let mkCompareObjTy g ty = mkFunTy g (mkThisTy g ty) (mkFunTy g g.obj_ty g.int_ty) - -let mkCompareTy g ty = mkFunTy g (mkThisTy g ty) (mkFunTy g ty g.int_ty) - -let mkCompareWithComparerTy g ty = mkFunTy g (mkThisTy g ty) (mkFunTy g (mkRefTupledTy g [g.obj_ty ; g.IComparer_ty]) g.int_ty) - -let mkEqualsObjTy g ty = mkFunTy g (mkThisTy g ty) (mkFunTy g g.obj_ty g.bool_ty) - -let mkEqualsTy g ty = mkFunTy g (mkThisTy g ty) (mkFunTy g ty g.bool_ty) - -let mkEqualsWithComparerTy g ty = mkFunTy g (mkThisTy g ty) (mkFunTy g (mkRefTupledTy g [g.obj_ty ; g.IEqualityComparer_ty]) g.bool_ty) - -let mkHashTy g ty = mkFunTy g (mkThisTy g ty) (mkFunTy g g.unit_ty g.int_ty) - -let mkHashWithComparerTy g ty = mkFunTy g (mkThisTy g ty) (mkFunTy g g.IEqualityComparer_ty g.int_ty) - -//------------------------------------------------------------------------- -// Polymorphic comparison -//------------------------------------------------------------------------- - -let mkRelBinOp (g: TcGlobals) op m e1 e2 = mkAsmExpr ([ op ], [], [e1; e2], [g.bool_ty], m) - -let mkClt g m e1 e2 = mkRelBinOp g AI_clt m e1 e2 - -let mkCgt g m e1 e2 = mkRelBinOp g AI_cgt m e1 e2 - -//------------------------------------------------------------------------- -// REVIEW: make this a .constrained call, not a virtual call. -//------------------------------------------------------------------------- - -// for creating and using GenericComparer objects and for creating and using -// IStructuralComparable objects (Eg, Calling CompareTo(obj o, IComparer comp)) - -let mkILLangPrimTy (g: TcGlobals) = mkILNonGenericBoxedTy g.tcref_LanguagePrimitives.CompiledRepresentationForNamedType - -let mkILCallGetComparer (g: TcGlobals) m = - let ty = mkILNonGenericBoxedTy g.tcref_System_Collections_IComparer.CompiledRepresentationForNamedType - let mspec = mkILNonGenericStaticMethSpecInTy (mkILLangPrimTy g, "get_GenericComparer", [], ty) - mkAsmExpr ([mkNormalCall mspec], [], [], [g.IComparer_ty], m) - -let mkILCallGetEqualityComparer (g: TcGlobals) m = - let ty = mkILNonGenericBoxedTy g.tcref_System_Collections_IEqualityComparer.CompiledRepresentationForNamedType - let mspec = mkILNonGenericStaticMethSpecInTy (mkILLangPrimTy g, "get_GenericEqualityComparer", [], ty) - mkAsmExpr ([mkNormalCall mspec], [], [], [g.IEqualityComparer_ty], m) - -let mkThisVar g m ty = mkCompGenLocal m "this" (mkThisTy g ty) - -let mkShl g m acce n = mkAsmExpr ([ AI_shl ], [], [acce; mkInt g m n], [g.int_ty], m) - -let mkShr g m acce n = mkAsmExpr ([ AI_shr ], [], [acce; mkInt g m n], [g.int_ty], m) - -let mkAdd (g: TcGlobals) m e1 e2 = mkAsmExpr ([ AI_add ], [], [e1;e2], [g.int_ty], m) - -let mkAddToHashAcc g m e accv acce = - mkValSet m accv - (mkAdd g m (mkInt g m 0x9e3779b9) - (mkAdd g m e - (mkAdd g m (mkShl g m acce 6) (mkShr g m acce 2)))) - -let mkCombineHashGenerators g m exprs accv acce = - (acce, exprs) ||> List.fold (fun tm e -> mkCompGenSequential m (mkAddToHashAcc g m e accv acce) tm) - -//------------------------------------------------------------------------- -// Build comparison functions for union, record and exception types. -//------------------------------------------------------------------------- - -let mkThatAddrLocal g m ty = mkCompGenLocal m "obj" (mkThisTy g ty) - -let mkThatAddrLocalIfNeeded g m tcve ty = - if isStructTy g ty then - let thataddrv, thataddre = mkCompGenLocal m "obj" (mkThisTy g ty) - Some thataddrv, thataddre - else None, tcve - -let mkThisVarThatVar g m ty = - let thisv, thise = mkThisVar g m ty - let thataddrv, thataddre = mkThatAddrLocal g m ty - thisv, thataddrv, thise, thataddre - -let mkThatVarBind g m ty thataddrv expr = - if isStructTy g ty then - let thatv2, _ = mkMutableCompGenLocal m "obj" ty - thatv2, mkCompGenLet m thataddrv (mkValAddr m false (mkLocalValRef thatv2)) expr - else thataddrv, expr - -let mkBindThatAddr g m ty thataddrv thatv thate expr = - if isStructTy g ty then - // let thataddrv = &thatv - mkCompGenLet m thataddrv (mkValAddr m false (mkLocalValRef thatv)) expr - else - // let thataddrv = that - mkCompGenLet m thataddrv thate expr - -let mkBindThatAddrIfNeeded m thataddrvOpt thatv expr = - match thataddrvOpt with - | None -> expr - | Some thataddrv -> - // let thataddrv = &thatv - mkCompGenLet m thataddrv (mkValAddr m false (mkLocalValRef thatv)) expr - -let mkCompareTestConjuncts g m exprs = - match List.tryFrontAndBack exprs with - | None -> mkZero g m - | Some (a,b) -> - (a, b) ||> List.foldBack (fun e acc -> - let nv, ne = mkCompGenLocal m "n" g.int_ty - mkCompGenLet m nv e - (mkCond DebugPointAtBinding.NoneAtSticky m g.int_ty - (mkClt g m ne (mkZero g m)) - ne - (mkCond DebugPointAtBinding.NoneAtSticky m g.int_ty - (mkCgt g m ne (mkZero g m)) - ne - acc))) - -let mkEqualsTestConjuncts g m exprs = - match List.tryFrontAndBack exprs with - | None -> mkOne g m - | Some (a,b) -> - List.foldBack (fun e acc -> mkCond DebugPointAtBinding.NoneAtSticky m g.bool_ty e acc (mkFalse g m)) a b - -let mkMinimalTy (g: TcGlobals) (tcref: TyconRef) = - if tcref.Deref.IsFSharpException then [], g.exn_ty - else generalizeTyconRef g tcref - -// check for nulls -let mkBindNullComparison g m thise thate expr = - let expr = mkNonNullCond g m g.int_ty thate expr (mkOne g m) - let expr = mkNonNullCond g m g.int_ty thise expr (mkNonNullCond g m g.int_ty thate (mkMinusOne g m) (mkZero g m) ) - expr - -let mkBindThisNullEquals g m thise thate expr = - let expr = mkNonNullCond g m g.bool_ty thise expr (mkNonNullCond g m g.int_ty thate (mkFalse g m) (mkTrue g m) ) - expr - -let mkBindThatNullEquals g m thise thate expr = - let expr = mkNonNullCond g m g.bool_ty thate expr (mkFalse g m) - let expr = mkBindThisNullEquals g m thise thate expr - expr - -let mkBindNullHash g m thise expr = - let expr = mkNonNullCond g m g.int_ty thise expr (mkZero g m) - expr - -/// Build the comparison implementation for a record type -let mkRecdCompare g tcref (tycon: Tycon) = - let m = tycon.Range - let fields = tycon.AllInstanceFieldsAsList - let tinst, ty = mkMinimalTy g tcref - let thisv, thataddrv, thise, thataddre = mkThisVarThatVar g m ty - let compe = mkILCallGetComparer g m - let mkTest (fspec: RecdField) = - let fref = tcref.MakeNestedRecdFieldRef fspec - let m = fref.Range - mkCallGenericComparisonWithComparerOuter g m fspec.FormalType - compe - (mkRecdFieldGetViaExprAddr (thise, fref, tinst, m)) - (mkRecdFieldGetViaExprAddr (thataddre, fref, tinst, m)) - let expr = mkCompareTestConjuncts g m (List.map mkTest fields) - - let expr = if tycon.IsStructOrEnumTycon then expr else mkBindNullComparison g m thise thataddre expr - - let thatv, expr = mkThatVarBind g m ty thataddrv expr - thisv, thatv, expr - -/// Build the comparison implementation for a record type when parameterized by a comparer -let mkRecdCompareWithComparer g tcref (tycon: Tycon) (_thisv, thise) (_, thate) compe = - let m = tycon.Range - let fields = tycon.AllInstanceFieldsAsList - let tinst, ty = mkMinimalTy g tcref - let tcv, tce = mkCompGenLocal m "objTemp" ty // let tcv = thate - let thataddrv, thataddre = mkThatAddrLocal g m ty // let thataddrv = &tcv, if a struct - - let mkTest (fspec: RecdField) = - let fref = tcref.MakeNestedRecdFieldRef fspec - let m = fref.Range - mkCallGenericComparisonWithComparerOuter g m fspec.FormalType - compe - (mkRecdFieldGetViaExprAddr (thise, fref, tinst, m)) - (mkRecdFieldGetViaExprAddr (thataddre, fref, tinst, m)) - let expr = mkCompareTestConjuncts g m (List.map mkTest fields) - - let expr = if tycon.IsStructOrEnumTycon then expr else mkBindNullComparison g m thise thate expr - - let expr = mkBindThatAddr g m ty thataddrv tcv tce expr - // will be optimized away if not necessary - let expr = mkCompGenLet m tcv thate expr - expr - -/// Build the .Equals(that) equality implementation wrapper for a record type -let mkRecdEquality g tcref (tycon: Tycon) = - let m = tycon.Range - let fields = tycon.AllInstanceFieldsAsList - let tinst, ty = mkMinimalTy g tcref - let thisv, thataddrv, thise, thataddre = mkThisVarThatVar g m ty - let mkTest (fspec: RecdField) = - let fref = tcref.MakeNestedRecdFieldRef fspec - let m = fref.Range - mkCallGenericEqualityEROuter g m fspec.FormalType - (mkRecdFieldGetViaExprAddr (thise, fref, tinst, m)) - (mkRecdFieldGetViaExprAddr (thataddre, fref, tinst, m)) - let expr = mkEqualsTestConjuncts g m (List.map mkTest fields) - - let expr = if tycon.IsStructOrEnumTycon then expr else mkBindThatNullEquals g m thise thataddre expr - - let thatv, expr = mkThatVarBind g m ty thataddrv expr - thisv, thatv, expr - -/// Build the equality implementation for a record type when parameterized by a comparer -let mkRecdEqualityWithComparer g tcref (tycon: Tycon) (_thisv, thise) thatobje (thatv, thate) compe = - let m = tycon.Range - let fields = tycon.AllInstanceFieldsAsList - let tinst, ty = mkMinimalTy g tcref - let thataddrv, thataddre = mkThatAddrLocal g m ty - - let mkTest (fspec: RecdField) = - let fref = tcref.MakeNestedRecdFieldRef fspec - let m = fref.Range - - mkCallGenericEqualityWithComparerOuter g m fspec.FormalType - compe - (mkRecdFieldGetViaExprAddr (thise, fref, tinst, m)) - (mkRecdFieldGetViaExprAddr (thataddre, fref, tinst, m)) - let expr = mkEqualsTestConjuncts g m (List.map mkTest fields) - - let expr = mkBindThatAddr g m ty thataddrv thatv thate expr - // will be optimized away if not necessary - let expr = mkIsInstConditional g m ty thatobje thatv expr (mkFalse g m) - let expr = if tycon.IsStructOrEnumTycon then expr else mkBindThisNullEquals g m thise thatobje expr - - expr - -/// Build the equality implementation for an exception definition -let mkExnEquality (g: TcGlobals) exnref (exnc: Tycon) = - let m = exnc.Range - let thatv, thate = mkCompGenLocal m "obj" g.exn_ty - let thisv, thise = mkThisVar g m g.exn_ty - let mkTest i (rfield: RecdField) = - mkCallGenericEqualityEROuter g m rfield.FormalType - (mkExnCaseFieldGet(thise, exnref, i, m)) - (mkExnCaseFieldGet(thate, exnref, i, m)) - let expr = mkEqualsTestConjuncts g m (List.mapi mkTest exnc.AllInstanceFieldsAsList) - let expr = - let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m ) - let cases = - [ mkCase(DecisionTreeTest.IsInst(g.exn_ty, mkAppTy exnref []), - mbuilder.AddResultTarget(expr)) ] - let dflt = Some(mbuilder.AddResultTarget(mkFalse g m)) - let dtree = TDSwitch(thate, cases, dflt, m) - mbuilder.Close(dtree, m, g.bool_ty) - - let expr = mkBindThatNullEquals g m thise thate expr - thisv, thatv, expr - -/// Build the equality implementation for an exception definition when parameterized by a comparer -let mkExnEqualityWithComparer g exnref (exnc: Tycon) (_thisv, thise) thatobje (thatv, thate) compe = - let m = exnc.Range - let thataddrv, thataddre = mkThatAddrLocal g m g.exn_ty - let mkTest i (rfield: RecdField) = - mkCallGenericEqualityWithComparerOuter g m rfield.FormalType - compe - (mkExnCaseFieldGet(thise, exnref, i, m)) - (mkExnCaseFieldGet(thataddre, exnref, i, m)) - let expr = mkEqualsTestConjuncts g m (List.mapi mkTest exnc.AllInstanceFieldsAsList) - let expr = - let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m ) - let cases = - [ mkCase(DecisionTreeTest.IsInst(g.exn_ty, mkAppTy exnref []), - mbuilder.AddResultTarget(expr)) ] - let dflt = mbuilder.AddResultTarget(mkFalse g m) - let dtree = TDSwitch(thate, cases, Some dflt, m) - mbuilder.Close(dtree, m, g.bool_ty) - let expr = mkBindThatAddr g m g.exn_ty thataddrv thatv thate expr - let expr = mkIsInstConditional g m g.exn_ty thatobje thatv expr (mkFalse g m) - let expr = if exnc.IsStructOrEnumTycon then expr else mkBindThisNullEquals g m thise thatobje expr - expr - -/// Build the comparison implementation for a union type -let mkUnionCompare g tcref (tycon: Tycon) = - let m = tycon.Range - let ucases = tycon.UnionCasesAsList - let tinst, ty = mkMinimalTy g tcref - let thisv, thataddrv, thise, thataddre = mkThisVarThatVar g m ty - let thistagv, thistage = mkCompGenLocal m "thisTag" g.int_ty - let thattagv, thattage = mkCompGenLocal m "thatTag" g.int_ty - let compe = mkILCallGetComparer g m - - let expr = - let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m ) - let mkCase ucase = - let cref = tcref.MakeNestedUnionCaseRef ucase - let m = cref.Range - let rfields = ucase.RecdFields - if isNil rfields then None else - let mkTest thise thataddre j (fld: RecdField) = - mkCallGenericComparisonWithComparerOuter g m fld.FormalType - compe - (mkUnionCaseFieldGetProvenViaExprAddr (thise, cref, tinst, j, m)) - (mkUnionCaseFieldGetProvenViaExprAddr (thataddre, cref, tinst, j, m)) - let test = - if cref.Tycon.IsStructOrEnumTycon then - mkCompareTestConjuncts g m (List.mapi (mkTest thise thataddre) rfields) - else - let thisucv, thisucve = mkCompGenLocal m "thisCast" (mkProvenUnionCaseTy cref tinst) - let thatucv, thatucve = mkCompGenLocal m "objCast" (mkProvenUnionCaseTy cref tinst) - mkCompGenLet m thisucv (mkUnionCaseProof (thise, cref, tinst, m)) - (mkCompGenLet m thatucv (mkUnionCaseProof (thataddre, cref, tinst, m)) - (mkCompareTestConjuncts g m (List.mapi (mkTest thisucve thatucve) rfields))) - Some (mkCase(DecisionTreeTest.UnionCase(cref, tinst), mbuilder.AddResultTarget(test))) - - let nullary, nonNullary = List.partition Option.isNone (List.map mkCase ucases) - if isNil nonNullary then mkZero g m else - let cases = nonNullary |> List.map (function Some c -> c | None -> failwith "mkUnionCompare") - let dflt = if isNil nullary then None else Some (mbuilder.AddResultTarget(mkZero g m)) - let dtree = TDSwitch(thise, cases, dflt, m) - mbuilder.Close(dtree, m, g.int_ty) - - let expr = - if List.isSingleton ucases then expr else - - let tagsEqTested = - mkCond DebugPointAtBinding.NoneAtSticky m g.int_ty - (mkILAsmCeq g m thistage thattage) - expr - (mkAsmExpr ([ AI_sub ], [], [thistage; thattage], [g.int_ty], m))in - mkCompGenLet m thistagv - (mkUnionCaseTagGetViaExprAddr (thise, tcref, tinst, m)) - (mkCompGenLet m thattagv - (mkUnionCaseTagGetViaExprAddr (thataddre, tcref, tinst, m)) - tagsEqTested) - - let expr = if tycon.IsStructOrEnumTycon then expr else mkBindNullComparison g m thise thataddre expr - let thatv, expr = mkThatVarBind g m ty thataddrv expr - thisv, thatv, expr - - -/// Build the comparison implementation for a union type when parameterized by a comparer -let mkUnionCompareWithComparer g tcref (tycon: Tycon) (_thisv, thise) (_thatobjv, thatcaste) compe = - let m = tycon.Range - let ucases = tycon.UnionCasesAsList - let tinst, ty = mkMinimalTy g tcref - let tcv, tce = mkCompGenLocal m "objTemp" ty // let tcv = (thatobj :?> ty) - let thataddrvOpt, thataddre = mkThatAddrLocalIfNeeded g m tce ty // let thataddrv = &tcv if struct, otherwise thataddre is just tce - let thistagv, thistage = mkCompGenLocal m "thisTag" g.int_ty - let thattagv, thattage = mkCompGenLocal m "thatTag" g.int_ty - - let expr = - let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m ) - let mkCase ucase = - let cref = tcref.MakeNestedUnionCaseRef ucase - let m = cref.Range - let rfields = ucase.RecdFields - if isNil rfields then None else - - let mkTest thise thataddre j (fld: RecdField) = - mkCallGenericComparisonWithComparerOuter g m fld.FormalType - compe - (mkUnionCaseFieldGetProvenViaExprAddr (thise, cref, tinst, j, m)) - (mkUnionCaseFieldGetProvenViaExprAddr (thataddre, cref, tinst, j, m)) - - let test = - if cref.Tycon.IsStructOrEnumTycon then - mkCompareTestConjuncts g m (List.mapi (mkTest thise thataddre) rfields) - else - let thisucv, thisucve = mkCompGenLocal m "thisCastu" (mkProvenUnionCaseTy cref tinst) - let thatucv, thatucve = mkCompGenLocal m "thatCastu" (mkProvenUnionCaseTy cref tinst) - mkCompGenLet m thisucv (mkUnionCaseProof (thise, cref, tinst, m)) - (mkCompGenLet m thatucv (mkUnionCaseProof (thataddre, cref, tinst, m)) - (mkCompareTestConjuncts g m (List.mapi (mkTest thisucve thatucve) rfields))) - - Some (mkCase(DecisionTreeTest.UnionCase(cref, tinst), mbuilder.AddResultTarget(test))) - - let nullary, nonNullary = List.partition Option.isNone (List.map mkCase ucases) - if isNil nonNullary then mkZero g m else - let cases = nonNullary |> List.map (function Some c -> c | None -> failwith "mkUnionCompare") - let dflt = if isNil nullary then None else Some (mbuilder.AddResultTarget(mkZero g m)) - let dtree = TDSwitch(thise, cases, dflt, m) - mbuilder.Close(dtree, m, g.int_ty) - - let expr = - if List.isSingleton ucases then expr else - - let tagsEqTested = - mkCond DebugPointAtBinding.NoneAtSticky m g.int_ty - (mkILAsmCeq g m thistage thattage) - expr - (mkAsmExpr ([ AI_sub ], [], [thistage; thattage], [g.int_ty], m)) - mkCompGenLet m thistagv - (mkUnionCaseTagGetViaExprAddr (thise, tcref, tinst, m)) - (mkCompGenLet m thattagv - (mkUnionCaseTagGetViaExprAddr (thataddre, tcref, tinst, m)) - tagsEqTested) - - let expr = if tycon.IsStructOrEnumTycon then expr else mkBindNullComparison g m thise thatcaste expr - let expr = mkBindThatAddrIfNeeded m thataddrvOpt tcv expr - let expr = mkCompGenLet m tcv thatcaste expr - expr - - -/// Build the equality implementation for a union type -let mkUnionEquality g tcref (tycon: Tycon) = - let m = tycon.Range - let ucases = tycon.UnionCasesAsList - let tinst, ty = mkMinimalTy g tcref - let thisv, thataddrv, thise, thataddre = mkThisVarThatVar g m ty - let thistagv, thistage = mkCompGenLocal m "thisTag" g.int_ty - let thattagv, thattage = mkCompGenLocal m "thatTag" g.int_ty - - let expr = - let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m ) - let mkCase ucase = - let cref = tcref.MakeNestedUnionCaseRef ucase - let m = cref.Range - let rfields = ucase.RecdFields - if isNil rfields then None else - - let mkTest thise thataddre j (fld: RecdField) = - mkCallGenericEqualityEROuter g m fld.FormalType - (mkUnionCaseFieldGetProvenViaExprAddr (thise, cref, tinst, j, m)) - (mkUnionCaseFieldGetProvenViaExprAddr (thataddre, cref, tinst, j, m)) - - let test = - if cref.Tycon.IsStructOrEnumTycon then - mkEqualsTestConjuncts g m (List.mapi (mkTest thise thataddre) rfields) - else - let thisucv, thisucve = mkCompGenLocal m "thisCast" (mkProvenUnionCaseTy cref tinst) - let thatucv, thatucve = mkCompGenLocal m "objCast" (mkProvenUnionCaseTy cref tinst) - mkCompGenLet m thisucv (mkUnionCaseProof (thise, cref, tinst, m)) - (mkCompGenLet m thatucv (mkUnionCaseProof (thataddre, cref, tinst, m)) - (mkEqualsTestConjuncts g m (List.mapi (mkTest thisucve thatucve) rfields))) - - Some (mkCase(DecisionTreeTest.UnionCase(cref, tinst), mbuilder.AddResultTarget(test))) - - let nullary, nonNullary = List.partition Option.isNone (List.map mkCase ucases) - if isNil nonNullary then mkTrue g m else - let cases = List.map (function Some c -> c | None -> failwith "mkUnionEquality") nonNullary - let dflt = (if isNil nullary then None else Some (mbuilder.AddResultTarget(mkTrue g m))) - let dtree = TDSwitch(thise, cases, dflt, m) - mbuilder.Close(dtree, m, g.bool_ty) - - let expr = - if List.isSingleton ucases then expr else - - let tagsEqTested = - mkCond DebugPointAtBinding.NoneAtSticky m g.bool_ty - (mkILAsmCeq g m thistage thattage) - expr - (mkFalse g m) - - mkCompGenLet m thistagv - (mkUnionCaseTagGetViaExprAddr (thise, tcref, tinst, m)) - (mkCompGenLet m thattagv - (mkUnionCaseTagGetViaExprAddr (thataddre, tcref, tinst, m)) - tagsEqTested) - - let thatv, expr = mkThatVarBind g m ty thataddrv expr - let expr = if tycon.IsStructOrEnumTycon then expr else mkBindThatNullEquals g m thise thataddre expr - thisv, thatv, expr - -/// Build the equality implementation for a union type when parameterized by a comparer -let mkUnionEqualityWithComparer g tcref (tycon: Tycon) (_thisv, thise) thatobje (thatv, thate) compe = - let m = tycon.Range - let ucases = tycon.UnionCasesAsList - let tinst, ty = mkMinimalTy g tcref - let thistagv, thistage = mkCompGenLocal m "thisTag" g.int_ty - let thattagv, thattage = mkCompGenLocal m "thatTag" g.int_ty - let thataddrv, thataddre = mkThatAddrLocal g m ty - - let expr = - let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m ) - let mkCase ucase = - let cref = tcref.MakeNestedUnionCaseRef ucase - let m = cref.Range - - let rfields = ucase.RecdFields - if isNil rfields then None else - - let mkTest thise thataddre j (fld: RecdField) = - mkCallGenericEqualityWithComparerOuter g m fld.FormalType - compe - (mkUnionCaseFieldGetProvenViaExprAddr (thise, cref, tinst, j, m)) - (mkUnionCaseFieldGetProvenViaExprAddr (thataddre, cref, tinst, j, m)) - - let test = - if cref.Tycon.IsStructOrEnumTycon then - mkEqualsTestConjuncts g m (List.mapi (mkTest thise thataddre) rfields) - else - let thisucv, thisucve = mkCompGenLocal m "thisCastu" (mkProvenUnionCaseTy cref tinst) - let thatucv, thatucve = mkCompGenLocal m "thatCastu" (mkProvenUnionCaseTy cref tinst) - - mkCompGenLet m thisucv (mkUnionCaseProof (thise, cref, tinst, m)) - (mkCompGenLet m thatucv (mkUnionCaseProof (thataddre, cref, tinst, m)) - (mkEqualsTestConjuncts g m (List.mapi (mkTest thisucve thatucve) rfields))) - - Some (mkCase(DecisionTreeTest.UnionCase(cref, tinst), mbuilder.AddResultTarget (test))) - - let nullary, nonNullary = List.partition Option.isNone (List.map mkCase ucases) - if isNil nonNullary then mkTrue g m else - let cases = List.map (function Some c -> c | None -> failwith "mkUnionEquality") nonNullary - let dflt = if isNil nullary then None else Some (mbuilder.AddResultTarget(mkTrue g m)) - let dtree = TDSwitch(thise, cases, dflt, m) - mbuilder.Close(dtree, m, g.bool_ty) - - let expr = - if List.isSingleton ucases then expr else - - let tagsEqTested = - mkCond DebugPointAtBinding.NoneAtSticky m g.bool_ty - (mkILAsmCeq g m thistage thattage) - expr - (mkFalse g m) - - mkCompGenLet m thistagv - (mkUnionCaseTagGetViaExprAddr (thise, tcref, tinst, m)) - (mkCompGenLet m thattagv - (mkUnionCaseTagGetViaExprAddr (thataddre, tcref, tinst, m)) - tagsEqTested) - let expr = mkBindThatAddr g m ty thataddrv thatv thate expr - let expr = mkIsInstConditional g m ty thatobje thatv expr (mkFalse g m) - let expr = if tycon.IsStructOrEnumTycon then expr else mkBindThisNullEquals g m thise thatobje expr - expr - -//------------------------------------------------------------------------- -// Build hashing functions for union, record and exception types. -// Hashing functions must respect the "=" and comparison operators. -//------------------------------------------------------------------------- - -/// Structural hash implementation for record types when parameterized by a comparer -let mkRecdHashWithComparer g tcref (tycon: Tycon) compe = - let m = tycon.Range - let fields = tycon.AllInstanceFieldsAsList - let tinst, ty = mkMinimalTy g tcref - let thisv, thise = mkThisVar g m ty - let mkFieldHash (fspec: RecdField) = - let fref = tcref.MakeNestedRecdFieldRef fspec - let m = fref.Range - let e = mkRecdFieldGetViaExprAddr (thise, fref, tinst, m) - - mkCallGenericHashWithComparerOuter g m fspec.FormalType compe e - - let accv, acce = mkMutableCompGenLocal m "i" g.int_ty - let stmt = mkCombineHashGenerators g m (List.map mkFieldHash fields) (mkLocalValRef accv) acce - let expr = mkCompGenLet m accv (mkZero g m) stmt - let expr = if tycon.IsStructOrEnumTycon then expr else mkBindNullHash g m thise expr - thisv, expr - -/// Structural hash implementation for exception types when parameterized by a comparer -let mkExnHashWithComparer g exnref (exnc: Tycon) compe = - let m = exnc.Range - let thisv, thise = mkThisVar g m g.exn_ty - - let mkHash i (rfield: RecdField) = - let e = mkExnCaseFieldGet(thise, exnref, i, m) - - mkCallGenericHashWithComparerOuter g m rfield.FormalType compe e - - let accv, acce = mkMutableCompGenLocal m "i" g.int_ty - let stmt = mkCombineHashGenerators g m (List.mapi mkHash exnc.AllInstanceFieldsAsList) (mkLocalValRef accv) acce - let expr = mkCompGenLet m accv (mkZero g m) stmt - let expr = mkBindNullHash g m thise expr - thisv, expr - -/// Structural hash implementation for union types when parameterized by a comparer -let mkUnionHashWithComparer g tcref (tycon: Tycon) compe = - let m = tycon.Range - let ucases = tycon.UnionCasesAsList - let tinst, ty = mkMinimalTy g tcref - let thisv, thise = mkThisVar g m ty - let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m ) - let accv, acce = mkMutableCompGenLocal m "i" g.int_ty - let mkCase i ucase1 = - let c1ref = tcref.MakeNestedUnionCaseRef ucase1 - let m = c1ref.Range - if ucase1.IsNullary then None - else - let mkHash thise j (rfield: RecdField) = - let e = mkUnionCaseFieldGetProvenViaExprAddr (thise, c1ref, tinst, j, m) - mkCallGenericHashWithComparerOuter g m rfield.FormalType compe e - - let test = - if tycon.IsStructOrEnumTycon then - mkCompGenSequential m - (mkValSet m (mkLocalValRef accv) (mkInt g m i)) - (mkCombineHashGenerators g m (List.mapi (mkHash thise) ucase1.RecdFields) (mkLocalValRef accv) acce) - else - let ucv, ucve = mkCompGenLocal m "unionCase" (mkProvenUnionCaseTy c1ref tinst) - mkCompGenLet m ucv - (mkUnionCaseProof (thise, c1ref, tinst, m)) - (mkCompGenSequential m - (mkValSet m (mkLocalValRef accv) (mkInt g m i)) - (mkCombineHashGenerators g m (List.mapi (mkHash ucve) ucase1.RecdFields) (mkLocalValRef accv) acce)) - Some(mkCase(DecisionTreeTest.UnionCase(c1ref, tinst), mbuilder.AddResultTarget(test))) - - let nullary, nonNullary = ucases - |> List.mapi mkCase - |> List.partition (fun i -> i.IsNone) - let cases = nonNullary |> List.map (function Some c -> c | None -> failwith "mkUnionHash") - let dflt = if isNil nullary then None - else - let tag = mkUnionCaseTagGetViaExprAddr (thise, tcref, tinst, m) - Some(mbuilder.AddResultTarget(tag)) - let dtree = TDSwitch(thise, cases, dflt, m) - let stmt = mbuilder.Close(dtree, m, g.int_ty) - let expr = mkCompGenLet m accv (mkZero g m) stmt - let expr = if tycon.IsStructOrEnumTycon then expr else mkBindNullHash g m thise expr - thisv, expr - - -//------------------------------------------------------------------------- -// The predicate that determines which types implement the -// pre-baked IStructuralHash and IComparable semantics associated with F# -// types. Note abstract types are not _known_ to implement these interfaces, -// though the interfaces may be discoverable via type tests. -//------------------------------------------------------------------------- - -let isNominalExnc (exnc: Tycon) = - match exnc.ExceptionInfo with - | TExnAbbrevRepr _ | TExnNone | TExnAsmRepr _ -> false - | TExnFresh _ -> true - -let isTrueFSharpStructTycon _g (tycon: Tycon) = - (tycon.IsFSharpStructOrEnumTycon && not tycon.IsFSharpEnumTycon) - -let canBeAugmentedWithEquals g (tycon: Tycon) = - tycon.IsUnionTycon || - tycon.IsRecordTycon || - (tycon.IsFSharpException && isNominalExnc tycon) || - isTrueFSharpStructTycon g tycon - -let canBeAugmentedWithCompare g (tycon: Tycon) = - tycon.IsUnionTycon || - tycon.IsRecordTycon || - isTrueFSharpStructTycon g tycon - -let getAugmentationAttribs g (tycon: Tycon) = - canBeAugmentedWithEquals g tycon, - canBeAugmentedWithCompare g tycon, - TryFindFSharpBoolAttribute g g.attrib_NoEqualityAttribute tycon.Attribs, - TryFindFSharpBoolAttribute g g.attrib_CustomEqualityAttribute tycon.Attribs, - TryFindFSharpBoolAttribute g g.attrib_ReferenceEqualityAttribute tycon.Attribs, - TryFindFSharpBoolAttribute g g.attrib_StructuralEqualityAttribute tycon.Attribs, - TryFindFSharpBoolAttribute g g.attrib_NoComparisonAttribute tycon.Attribs, - TryFindFSharpBoolAttribute g g.attrib_CustomComparisonAttribute tycon.Attribs, - TryFindFSharpBoolAttribute g g.attrib_StructuralComparisonAttribute tycon.Attribs - -let CheckAugmentationAttribs isImplementation g amap (tycon: Tycon) = - let m = tycon.Range - let attribs = getAugmentationAttribs g tycon - match attribs with - - // THESE ARE THE LEGITIMATE CASES - - // [< >] on anything - | _, _, None, None, None, None, None, None, None - - // [] on union/record/struct - | true, _, None, Some true, None, None, None, Some true, None - - // [] on union/record/struct - | true, _, None, Some true, None, None, Some true, None, None -> - () - - // [] on union/record/struct - | true, _, None, None, Some true, None, Some true, None, None - - // [] on union/record/struct - | true, _, None, None, Some true, None, None, None, None -> - if isTrueFSharpStructTycon g tycon then - errorR(Error(FSComp.SR.augNoRefEqualsOnStruct(), m)) - else () - - // [] on union/record/struct - | true, true, None, None, None, Some true, None, None, Some true - - // [] - | true, _, None, None, None, Some true, Some true, None, None - - // [] - | true, _, None, None, None, Some true, None, Some true, None - - // [] on anything - | _, _, None, None, None, None, Some true, None, None - - // [] on anything - | _, _, Some true, None, None, None, Some true, None, None -> - () - - // THESE ARE THE ERROR CASES - - // [] - | _, _, Some true, _, _, _, None, _, _ -> - errorR(Error(FSComp.SR.augNoEqualityNeedsNoComparison(), m)) - - // [] - | true, true, _, _, _, None, _, _, Some true -> - errorR(Error(FSComp.SR.augStructCompNeedsStructEquality(), m)) - // [] - | true, _, _, _, _, Some true, None, _, None -> - errorR(Error(FSComp.SR.augStructEqNeedsNoCompOrStructComp(), m)) - - // [] - | true, _, _, Some true, _, _, None, None, _ -> - errorR(Error(FSComp.SR.augCustomEqNeedsNoCompOrCustomComp(), m)) - - // [] - | true, _, _, _, Some true, Some true, _, _, _ - - // [] - | true, _, _, _, Some true, _, _, _, Some true -> - errorR(Error(FSComp.SR.augTypeCantHaveRefEqAndStructAttrs(), m)) - - // non augmented type, [] - // non augmented type, [] - // non augmented type, [] - | false, _, _, _, Some true, _, _, _, _ - | false, _, _, _, _, Some true, _, _, _ - | false, _, _, _, _, _, _, _, Some true -> - errorR(Error(FSComp.SR.augOnlyCertainTypesCanHaveAttrs(), m)) - // All other cases - | _ -> - errorR(Error(FSComp.SR.augInvalidAttrs(), m)) - - let hasNominalInterface tcref = - let ty = generalizedTyconRef g (mkLocalTyconRef tycon) - ExistsHeadTypeInEntireHierarchy g amap tycon.Range ty tcref - - let hasExplicitICompare = - hasNominalInterface g.tcref_System_IStructuralComparable || - hasNominalInterface g.tcref_System_IComparable - - let hasExplicitIGenericCompare = - hasNominalInterface g.system_GenericIComparable_tcref - - let hasExplicitEquals = - tycon.HasOverride g "Equals" [g.obj_ty] || - hasNominalInterface g.tcref_System_IStructuralEquatable - - let hasExplicitGenericEquals = - hasNominalInterface g.system_GenericIEquatable_tcref - - match attribs with - // [] + any equality semantics - | _, _, Some true, _, _, _, _, _, _ when (hasExplicitEquals || hasExplicitGenericEquals) -> - warning(Error(FSComp.SR.augNoEqNeedsNoObjEquals(), m)) - // [] + any comparison semantics - | _, _, _, _, _, _, Some true, _, _ when (hasExplicitICompare || hasExplicitIGenericCompare) -> - warning(Error(FSComp.SR.augNoCompCantImpIComp(), m)) - - // [] + no explicit override Object.Equals + no explicit IStructuralEquatable - | _, _, _, Some true, _, _, _, _, _ when isImplementation && not hasExplicitEquals && not hasExplicitGenericEquals-> - errorR(Error(FSComp.SR.augCustomEqNeedsObjEquals(), m)) - // [] + no explicit IComparable + no explicit IStructuralComparable - | _, _, _, _, _, _, _, Some true, _ when isImplementation && not hasExplicitICompare && not hasExplicitIGenericCompare -> - errorR(Error(FSComp.SR.augCustomCompareNeedsIComp(), m)) - - // [] + any equality semantics - | _, _, _, _, Some true, _, _, _, _ when (hasExplicitEquals || hasExplicitIGenericCompare) -> - errorR(Error(FSComp.SR.augRefEqCantHaveObjEquals(), m)) - - | _ -> - () - -let TyconIsCandidateForAugmentationWithCompare (g: TcGlobals) (tycon: Tycon) = - // This type gets defined in prim-types, before we can add attributes to F# type definitions - let isUnit = g.compilingFSharpCore && tycon.DisplayName = "Unit" - not isUnit && - not (isByrefLikeTyconRef g tycon.Range (mkLocalTyconRef tycon)) && - match getAugmentationAttribs g tycon with - // [< >] - | true, true, None, None, None, None, None, None, None - // [] - | true, true, None, None, None, Some true, None, None, Some true - // [] - | true, true, None, None, None, None, None, None, Some true -> true - // other cases - | _ -> false - -let TyconIsCandidateForAugmentationWithEquals (g: TcGlobals) (tycon: Tycon) = - // This type gets defined in prim-types, before we can add attributes to F# type definitions - let isUnit = g.compilingFSharpCore && tycon.DisplayName = "Unit" - not isUnit && - not (isByrefLikeTyconRef g tycon.Range (mkLocalTyconRef tycon)) && - - match getAugmentationAttribs g tycon with - // [< >] - | true, _, None, None, None, None, _, _, _ - // [] - // [] - | true, _, None, None, None, Some true, _, _, _ -> true - // other cases - | _ -> false - -let TyconIsCandidateForAugmentationWithHash g tycon = TyconIsCandidateForAugmentationWithEquals g tycon - -//------------------------------------------------------------------------- -// Make values that represent the implementations of the -// IComparable semantics associated with F# types. -//------------------------------------------------------------------------- - -let slotImplMethod (final, c, slotsig) : ValMemberInfo = - { ImplementedSlotSigs=[slotsig] - MemberFlags= - { IsInstance=true - IsDispatchSlot=false - IsFinal=final - IsOverrideOrExplicitImpl=true - GetterOrSetterIsCompilerGenerated=false - MemberKind=SynMemberKind.Member } - IsImplemented=false - ApparentEnclosingEntity=c} - -let nonVirtualMethod c : ValMemberInfo = - { ImplementedSlotSigs=[] - MemberFlags={ IsInstance=true - IsDispatchSlot=false - IsFinal=false - IsOverrideOrExplicitImpl=false - GetterOrSetterIsCompilerGenerated=false - MemberKind=SynMemberKind.Member } - IsImplemented=false - ApparentEnclosingEntity=c} - -let unitArg = ValReprInfo.unitArgData - -let unaryArg = [ ValReprInfo.unnamedTopArg ] - -let tupArg = [ [ ValReprInfo.unnamedTopArg1; ValReprInfo.unnamedTopArg1 ] ] - -let mkValSpec g (tcref: TyconRef) ty vis slotsig methn valTy argData = - let m = tcref.Range - let tps = tcref.Typars m - let membInfo = - match slotsig with - | None -> nonVirtualMethod tcref - | Some slotsig -> - let final = isUnionTy g ty || isRecdTy g ty || isStructTy g ty - slotImplMethod(final, tcref, slotsig) - let inl = ValInline.Optional - let args = ValReprInfo.unnamedTopArg :: argData - let valReprInfo = Some (ValReprInfo (ValReprInfo.InferTyparInfo tps, args, ValReprInfo.unnamedRetVal)) - Construct.NewVal (methn, m, None, valTy, Immutable, true, valReprInfo, vis, ValNotInRecScope, Some membInfo, NormalVal, [], inl, XmlDoc.Empty, true, false, false, false, false, false, None, Parent tcref) - -let MakeValsForCompareAugmentation g (tcref: TyconRef) = - let m = tcref.Range - let _, ty = mkMinimalTy g tcref - let tps = tcref.Typars m - let vis = tcref.TypeReprAccessibility - - mkValSpec g tcref ty vis (Some(mkIComparableCompareToSlotSig g)) "CompareTo" (tps +-> (mkCompareObjTy g ty)) unaryArg, - mkValSpec g tcref ty vis (Some(mkGenericIComparableCompareToSlotSig g ty)) "CompareTo" (tps +-> (mkCompareTy g ty)) unaryArg - -let MakeValsForCompareWithComparerAugmentation g (tcref: TyconRef) = - let m = tcref.Range - let _, ty = mkMinimalTy g tcref - let tps = tcref.Typars m - let vis = tcref.TypeReprAccessibility - mkValSpec g tcref ty vis (Some(mkIStructuralComparableCompareToSlotSig g)) "CompareTo" (tps +-> (mkCompareWithComparerTy g ty)) tupArg - -let MakeValsForEqualsAugmentation g (tcref: TyconRef) = - let m = tcref.Range - let _, ty = mkMinimalTy g tcref - let vis = tcref.TypeReprAccessibility - let tps = tcref.Typars m - - let objEqualsVal = mkValSpec g tcref ty vis (Some(mkEqualsSlotSig g)) "Equals" (tps +-> (mkEqualsObjTy g ty)) unaryArg - let nocEqualsVal = mkValSpec g tcref ty vis (if tcref.Deref.IsFSharpException then None else Some(mkGenericIEquatableEqualsSlotSig g ty)) "Equals" (tps +-> (mkEqualsTy g ty)) unaryArg - objEqualsVal, nocEqualsVal - -let MakeValsForEqualityWithComparerAugmentation g (tcref: TyconRef) = - let _, ty = mkMinimalTy g tcref - let vis = tcref.TypeReprAccessibility - let tps = tcref.Typars tcref.Range - let objGetHashCodeVal = mkValSpec g tcref ty vis (Some(mkGetHashCodeSlotSig g)) "GetHashCode" (tps +-> (mkHashTy g ty)) unitArg - let withcGetHashCodeVal = mkValSpec g tcref ty vis (Some(mkIStructuralEquatableGetHashCodeSlotSig g)) "GetHashCode" (tps +-> (mkHashWithComparerTy g ty)) unaryArg - let withcEqualsVal = mkValSpec g tcref ty vis (Some(mkIStructuralEquatableEqualsSlotSig g)) "Equals" (tps +-> (mkEqualsWithComparerTy g ty)) tupArg - objGetHashCodeVal, withcGetHashCodeVal, withcEqualsVal - -let MakeBindingsForCompareAugmentation g (tycon: Tycon) = - let tcref = mkLocalTyconRef tycon - let m = tycon.Range - let tps = tycon.Typars m - let mkCompare comparef = - match tycon.GeneratedCompareToValues with - | None -> [] - | Some (vref1, vref2) -> - let vspec1 = vref1.Deref - let vspec2 = vref2.Deref - (* this is the body of the override *) - let rhs1 = - let tinst, ty = mkMinimalTy g tcref - - let thisv, thise = mkThisVar g m ty - let thatobjv, thatobje = mkCompGenLocal m "obj" g.obj_ty - let comparee = - if isUnitTy g ty then mkZero g m else - let thate = mkCoerceExpr (thatobje, ty, m, g.obj_ty) - - mkApps g ((exprForValRef m vref2, vref2.Type), (if isNil tinst then [] else [tinst]), [thise;thate], m) - - mkLambdas g m tps [thisv; thatobjv] (comparee, g.int_ty) - let rhs2 = - let thisv, thatv, comparee = comparef g tcref tycon - mkLambdas g m tps [thisv; thatv] (comparee, g.int_ty) - [ // This one must come first because it may be inlined into the second - mkCompGenBind vspec2 rhs2 - mkCompGenBind vspec1 rhs1; ] - if tycon.IsUnionTycon then mkCompare mkUnionCompare - elif tycon.IsRecordTycon || tycon.IsStructOrEnumTycon then mkCompare mkRecdCompare - else [] - -let MakeBindingsForCompareWithComparerAugmentation g (tycon: Tycon) = - let tcref = mkLocalTyconRef tycon - let m = tycon.Range - let tps = tycon.Typars m - let mkCompare comparef = - match tycon.GeneratedCompareToWithComparerValues with - | None -> [] - | Some vref -> - let vspec = vref.Deref - let _, ty = mkMinimalTy g tcref - - let compv, compe = mkCompGenLocal m "comp" g.IComparer_ty - - let thisv, thise = mkThisVar g m ty - let thatobjv, thatobje = mkCompGenLocal m "obj" g.obj_ty - let thate = mkCoerceExpr (thatobje, ty, m, g.obj_ty) - - let rhs = - let comparee = comparef g tcref tycon (thisv, thise) (thatobjv, thate) compe - let comparee = if isUnitTy g ty then mkZero g m else comparee - mkMultiLambdas g m tps [[thisv]; [thatobjv; compv]] (comparee, g.int_ty) - [mkCompGenBind vspec rhs] - if tycon.IsUnionTycon then mkCompare mkUnionCompareWithComparer - elif tycon.IsRecordTycon || tycon.IsStructOrEnumTycon then mkCompare mkRecdCompareWithComparer - else [] - -let MakeBindingsForEqualityWithComparerAugmentation (g: TcGlobals) (tycon: Tycon) = - let tcref = mkLocalTyconRef tycon - let m = tycon.Range - let tps = tycon.Typars m - let mkStructuralEquatable hashf equalsf = - match tycon.GeneratedHashAndEqualsWithComparerValues with - | None -> [] - | Some (objGetHashCodeVal, withcGetHashCodeVal, withcEqualsVal) -> - - // build the hash rhs - let withcGetHashCodeExpr = - let compv, compe = mkCompGenLocal m "comp" g.IEqualityComparer_ty - - // Special case List type to avoid StackOverflow exception , call custom hash code instead - let thisv,hashe = - if tyconRefEq g tcref g.list_tcr_canon && tycon.HasMember g "CustomHashCode" [g.IEqualityComparer_ty] then - let customCodeVal = (tycon.TryGetMember g "CustomHashCode" [g.IEqualityComparer_ty]).Value - let tinst, ty = mkMinimalTy g tcref - let thisv, thise = mkThisVar g m ty - thisv,mkApps g ((exprForValRef m customCodeVal, customCodeVal.Type), (if isNil tinst then [] else [tinst]), [thise; compe], m) - else - hashf g tcref tycon compe - mkLambdas g m tps [thisv; compv] (hashe, g.int_ty) - - // build the equals rhs - let withcEqualsExpr = - let _tinst, ty = mkMinimalTy g tcref - let thisv, thise = mkThisVar g m ty - let thatobjv, thatobje = mkCompGenLocal m "obj" g.obj_ty - let thatv, thate = mkCompGenLocal m "that" ty - let compv, compe = mkCompGenLocal m "comp" g.IEqualityComparer_ty - let equalse = equalsf g tcref tycon (thisv, thise) thatobje (thatv, thate) compe - mkMultiLambdas g m tps [[thisv];[thatobjv; compv]] (equalse, g.bool_ty) - - let objGetHashCodeExpr = - let tinst, ty = mkMinimalTy g tcref - - let thisv, thise = mkThisVar g m ty - let unitv, _ = mkCompGenLocal m "unitArg" g.unit_ty - let hashe = - if isUnitTy g ty then mkZero g m else - - let compe = mkILCallGetEqualityComparer g m - mkApps g ((exprForValRef m withcGetHashCodeVal, withcGetHashCodeVal.Type), (if isNil tinst then [] else [tinst]), [thise; compe], m) - - mkLambdas g m tps [thisv; unitv] (hashe, g.int_ty) - - [(mkCompGenBind withcGetHashCodeVal.Deref withcGetHashCodeExpr) - (mkCompGenBind objGetHashCodeVal.Deref objGetHashCodeExpr) - (mkCompGenBind withcEqualsVal.Deref withcEqualsExpr)] - if tycon.IsUnionTycon then mkStructuralEquatable mkUnionHashWithComparer mkUnionEqualityWithComparer - elif (tycon.IsRecordTycon || tycon.IsStructOrEnumTycon) then mkStructuralEquatable mkRecdHashWithComparer mkRecdEqualityWithComparer - elif tycon.IsFSharpException then mkStructuralEquatable mkExnHashWithComparer mkExnEqualityWithComparer - else [] - -let MakeBindingsForEqualsAugmentation (g: TcGlobals) (tycon: Tycon) = - let tcref = mkLocalTyconRef tycon - let m = tycon.Range - let tps = tycon.Typars m - let mkEquals equalsf = - match tycon.GeneratedHashAndEqualsValues with - | None -> [] - | Some (objEqualsVal, nocEqualsVal) -> - // this is the body of the real strongly typed implementation - let nocEqualsExpr = - let thisv, thatv, equalse = equalsf g tcref tycon - mkLambdas g m tps [thisv;thatv] (equalse, g.bool_ty) - - // this is the body of the override - let objEqualsExpr = - let tinst, ty = mkMinimalTy g tcref - - let thisv, thise = mkThisVar g m ty - let thatobjv, thatobje = mkCompGenLocal m "obj" g.obj_ty - let equalse = - if isUnitTy g ty then mkTrue g m else - - let thatv, thate = mkCompGenLocal m "that" ty - mkIsInstConditional g m ty thatobje thatv - (mkApps g ((exprForValRef m nocEqualsVal, nocEqualsVal.Type), (if isNil tinst then [] else [tinst]), [thise;thate], m)) - (mkFalse g m) - - mkLambdas g m tps [thisv;thatobjv] (equalse, g.bool_ty) - - [ mkCompGenBind nocEqualsVal.Deref nocEqualsExpr - mkCompGenBind objEqualsVal.Deref objEqualsExpr ] - if tycon.IsFSharpException then mkEquals mkExnEquality - elif tycon.IsUnionTycon then mkEquals mkUnionEquality - elif tycon.IsRecordTycon || tycon.IsStructOrEnumTycon then mkEquals mkRecdEquality - else [] - -let rec TypeDefinitelyHasEquality g ty = - let appTy = tryAppTy g ty - match appTy with - | ValueSome(tcref,_) when HasFSharpAttribute g g.attrib_NoEqualityAttribute tcref.Attribs -> - false - | _ -> - if isTyparTy g ty && - (destTyparTy g ty).Constraints |> List.exists (function TyparConstraint.SupportsEquality _ -> true | _ -> false) then - true - else - match ty with - | SpecialEquatableHeadType g tinst -> - tinst |> List.forall (TypeDefinitelyHasEquality g) - | SpecialNotEquatableHeadType g _ -> - false - | _ -> - // The type is equatable because it has Object.Equals(...) - match appTy with - | ValueSome(tcref,tinst) -> - // Give a good error for structural types excluded from the equality relation because of their fields - not (TyconIsCandidateForAugmentationWithEquals g tcref.Deref && Option.isNone tcref.GeneratedHashAndEqualsWithComparerValues) && - // Check the (possibly inferred) structural dependencies - (tinst, tcref.TyparsNoRange) - ||> List.lengthsEqAndForall2 (fun ty tp -> not tp.EqualityConditionalOn || TypeDefinitelyHasEquality g ty) - | _ -> false diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index 3c97ea8354e..6f65f46ce63 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -732,6 +732,140 @@ let MakeSafeInitField (cenv: cenv) env m isStatic = let taccess = TAccess [env.eAccessPath] Construct.NewRecdField isStatic None id false cenv.g.int_ty true true [] [] XmlDoc.Empty taccess true +//------------------------------------------------------------------------- +// Build augmentation declarations +//------------------------------------------------------------------------- + +module AddAugmentationDeclarations = + let tcaugHasNominalInterface g (tcaug: TyconAugmentation) tcref = + tcaug.tcaug_interfaces |> List.exists (fun (x, _, _) -> + match tryTcrefOfAppTy g x with + | ValueSome tcref2 when tyconRefEq g tcref2 tcref -> true + | _ -> false) + + let AddGenericCompareDeclarations (cenv: cenv) (env: TcEnv) (scSet: Set) (tycon: Tycon) = + let g = cenv.g + if AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithCompare g tycon && scSet.Contains tycon.Stamp then + let tcref = mkLocalTyconRef tycon + let tcaug = tycon.TypeContents + let ty = if tcref.Deref.IsFSharpException then g.exn_ty else generalizedTyconRef g tcref + let m = tycon.Range + let genericIComparableTy = mkAppTy g.system_GenericIComparable_tcref [ty] + + + let hasExplicitIComparable = tycon.HasInterface g g.mk_IComparable_ty + let hasExplicitGenericIComparable = tcaugHasNominalInterface g tcaug g.system_GenericIComparable_tcref + let hasExplicitIStructuralComparable = tycon.HasInterface g g.mk_IStructuralComparable_ty + + if hasExplicitIComparable then + errorR(Error(FSComp.SR.tcImplementsIComparableExplicitly(tycon.DisplayName), m)) + + elif hasExplicitGenericIComparable then + errorR(Error(FSComp.SR.tcImplementsGenericIComparableExplicitly(tycon.DisplayName), m)) + elif hasExplicitIStructuralComparable then + errorR(Error(FSComp.SR.tcImplementsIStructuralComparableExplicitly(tycon.DisplayName), m)) + else + let hasExplicitGenericIComparable = tycon.HasInterface g genericIComparableTy + let cvspec1, cvspec2 = AugmentTypeDefinitions.MakeValsForCompareAugmentation g tcref + let cvspec3 = AugmentTypeDefinitions.MakeValsForCompareWithComparerAugmentation g tcref + + PublishInterface cenv env.DisplayEnv tcref m true g.mk_IStructuralComparable_ty + PublishInterface cenv env.DisplayEnv tcref m true g.mk_IComparable_ty + if not tycon.IsFSharpException && not hasExplicitGenericIComparable then + PublishInterface cenv env.DisplayEnv tcref m true genericIComparableTy + tcaug.SetCompare (mkLocalValRef cvspec1, mkLocalValRef cvspec2) + tcaug.SetCompareWith (mkLocalValRef cvspec3) + PublishValueDefn cenv env ModuleOrMemberBinding cvspec1 + PublishValueDefn cenv env ModuleOrMemberBinding cvspec2 + PublishValueDefn cenv env ModuleOrMemberBinding cvspec3 + + let AddGenericEqualityWithComparerDeclarations (cenv: cenv) (env: TcEnv) (seSet: Set) (tycon: Tycon) = + let g = cenv.g + if AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithEquals g tycon && seSet.Contains tycon.Stamp then + let tcref = mkLocalTyconRef tycon + let tcaug = tycon.TypeContents + let m = tycon.Range + + let hasExplicitIStructuralEquatable = tycon.HasInterface g g.mk_IStructuralEquatable_ty + + if hasExplicitIStructuralEquatable then + errorR(Error(FSComp.SR.tcImplementsIStructuralEquatableExplicitly(tycon.DisplayName), m)) + else + let evspec1, evspec2, evspec3 = AugmentTypeDefinitions.MakeValsForEqualityWithComparerAugmentation g tcref + PublishInterface cenv env.DisplayEnv tcref m true g.mk_IStructuralEquatable_ty + tcaug.SetHashAndEqualsWith (mkLocalValRef evspec1, mkLocalValRef evspec2, mkLocalValRef evspec3) + PublishValueDefn cenv env ModuleOrMemberBinding evspec1 + PublishValueDefn cenv env ModuleOrMemberBinding evspec2 + PublishValueDefn cenv env ModuleOrMemberBinding evspec3 + + let AddGenericCompareBindings (cenv: cenv) (tycon: Tycon) = + if (* AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithCompare cenv.g tycon && *) Option.isSome tycon.GeneratedCompareToValues then + AugmentTypeDefinitions.MakeBindingsForCompareAugmentation cenv.g tycon + else + [] + + let AddGenericCompareWithComparerBindings (cenv: cenv) (tycon: Tycon) = + if (* AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithCompare cenv.g tycon && *) Option.isSome tycon.GeneratedCompareToWithComparerValues then + (AugmentTypeDefinitions.MakeBindingsForCompareWithComparerAugmentation cenv.g tycon) + else + [] + + let AddGenericEqualityWithComparerBindings (cenv: cenv) (tycon: Tycon) = + if AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithEquals cenv.g tycon && Option.isSome tycon.GeneratedHashAndEqualsWithComparerValues then + (AugmentTypeDefinitions.MakeBindingsForEqualityWithComparerAugmentation cenv.g tycon) + else + [] + + let AddGenericHashAndComparisonDeclarations (cenv: cenv) (env: TcEnv) scSet seSet tycon = + AddGenericCompareDeclarations cenv env scSet tycon + AddGenericEqualityWithComparerDeclarations cenv env seSet tycon + + let AddGenericHashAndComparisonBindings cenv tycon = + AddGenericCompareBindings cenv tycon @ AddGenericCompareWithComparerBindings cenv tycon @ AddGenericEqualityWithComparerBindings cenv tycon + + // We can only add the Equals override after we've done the augmentation because we have to wait until + // tycon.HasOverride can give correct results + let AddGenericEqualityBindings (cenv: cenv) (env: TcEnv) tycon = + let g = cenv.g + if AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithEquals g tycon then + let tcref = mkLocalTyconRef tycon + let tcaug = tycon.TypeContents + let ty = if tcref.Deref.IsFSharpException then g.exn_ty else generalizedTyconRef g tcref + let m = tycon.Range + + // Note: tycon.HasOverride only gives correct results after we've done the type augmentation + let hasExplicitObjectEqualsOverride = tycon.HasOverride g "Equals" [g.obj_ty] + let hasExplicitGenericIEquatable = tcaugHasNominalInterface g tcaug g.system_GenericIEquatable_tcref + + if hasExplicitGenericIEquatable then + errorR(Error(FSComp.SR.tcImplementsIEquatableExplicitly(tycon.DisplayName), m)) + + // Note: only provide the equals method if Equals is not implemented explicitly, and + // we're actually generating Hash/Equals for this type + if not hasExplicitObjectEqualsOverride && + Option.isSome tycon.GeneratedHashAndEqualsWithComparerValues then + + let vspec1, vspec2 = AugmentTypeDefinitions.MakeValsForEqualsAugmentation g tcref + tcaug.SetEquals (mkLocalValRef vspec1, mkLocalValRef vspec2) + if not tycon.IsFSharpException then + PublishInterface cenv env.DisplayEnv tcref m true (mkAppTy g.system_GenericIEquatable_tcref [ty]) + PublishValueDefn cenv env ModuleOrMemberBinding vspec1 + PublishValueDefn cenv env ModuleOrMemberBinding vspec2 + AugmentTypeDefinitions.MakeBindingsForEqualsAugmentation g tycon + else [] + else [] + + let ShouldAugmentUnion (g: TcGlobals) (tycon: Tycon) = + g.langVersion.SupportsFeature LanguageFeature.UnionIsPropertiesVisible && + HasDefaultAugmentationAttribute g (mkLocalTyconRef tycon) + + let AddUnionAugmentationValues (cenv: cenv) (env: TcEnv) tycon = + let tcref = mkLocalTyconRef tycon + let vals = AugmentTypeDefinitions.MakeValsForUnionAugmentation cenv.g tcref + for v in vals do + PublishValueDefnMaybeInclCompilerGenerated cenv env true ModuleOrMemberBinding v + vals + // Checking of mutually recursive types, members and 'let' bindings in classes // // Technique: multiple passes. @@ -1826,133 +1960,6 @@ let TcMutRecDefns_Phase2 (cenv: cenv) envInitial mBinds scopem mutRecNSInfo (env with exn -> errorRecovery exn scopem; [], envMutRec -//------------------------------------------------------------------------- -// Build augmentation declarations -//------------------------------------------------------------------------- - -module AddAugmentationDeclarations = - let tcaugHasNominalInterface g (tcaug: TyconAugmentation) tcref = - tcaug.tcaug_interfaces |> List.exists (fun (x, _, _) -> - match tryTcrefOfAppTy g x with - | ValueSome tcref2 when tyconRefEq g tcref2 tcref -> true - | _ -> false) - - let AddGenericCompareDeclarations (cenv: cenv) (env: TcEnv) (scSet: Set) (tycon: Tycon) = - let g = cenv.g - if AugmentWithHashCompare.TyconIsCandidateForAugmentationWithCompare g tycon && scSet.Contains tycon.Stamp then - let tcref = mkLocalTyconRef tycon - let tcaug = tycon.TypeContents - let ty = if tcref.Deref.IsFSharpException then g.exn_ty else generalizedTyconRef g tcref - let m = tycon.Range - let genericIComparableTy = mkAppTy g.system_GenericIComparable_tcref [ty] - - - let hasExplicitIComparable = tycon.HasInterface g g.mk_IComparable_ty - let hasExplicitGenericIComparable = tcaugHasNominalInterface g tcaug g.system_GenericIComparable_tcref - let hasExplicitIStructuralComparable = tycon.HasInterface g g.mk_IStructuralComparable_ty - - if hasExplicitIComparable then - errorR(Error(FSComp.SR.tcImplementsIComparableExplicitly(tycon.DisplayName), m)) - - elif hasExplicitGenericIComparable then - errorR(Error(FSComp.SR.tcImplementsGenericIComparableExplicitly(tycon.DisplayName), m)) - elif hasExplicitIStructuralComparable then - errorR(Error(FSComp.SR.tcImplementsIStructuralComparableExplicitly(tycon.DisplayName), m)) - else - let hasExplicitGenericIComparable = tycon.HasInterface g genericIComparableTy - let cvspec1, cvspec2 = AugmentWithHashCompare.MakeValsForCompareAugmentation g tcref - let cvspec3 = AugmentWithHashCompare.MakeValsForCompareWithComparerAugmentation g tcref - - PublishInterface cenv env.DisplayEnv tcref m true g.mk_IStructuralComparable_ty - PublishInterface cenv env.DisplayEnv tcref m true g.mk_IComparable_ty - if not tycon.IsFSharpException && not hasExplicitGenericIComparable then - PublishInterface cenv env.DisplayEnv tcref m true genericIComparableTy - tcaug.SetCompare (mkLocalValRef cvspec1, mkLocalValRef cvspec2) - tcaug.SetCompareWith (mkLocalValRef cvspec3) - PublishValueDefn cenv env ModuleOrMemberBinding cvspec1 - PublishValueDefn cenv env ModuleOrMemberBinding cvspec2 - PublishValueDefn cenv env ModuleOrMemberBinding cvspec3 - - let AddGenericEqualityWithComparerDeclarations (cenv: cenv) (env: TcEnv) (seSet: Set) (tycon: Tycon) = - let g = cenv.g - if AugmentWithHashCompare.TyconIsCandidateForAugmentationWithEquals g tycon && seSet.Contains tycon.Stamp then - let tcref = mkLocalTyconRef tycon - let tcaug = tycon.TypeContents - let m = tycon.Range - - let hasExplicitIStructuralEquatable = tycon.HasInterface g g.mk_IStructuralEquatable_ty - - if hasExplicitIStructuralEquatable then - errorR(Error(FSComp.SR.tcImplementsIStructuralEquatableExplicitly(tycon.DisplayName), m)) - else - let evspec1, evspec2, evspec3 = AugmentWithHashCompare.MakeValsForEqualityWithComparerAugmentation g tcref - PublishInterface cenv env.DisplayEnv tcref m true g.mk_IStructuralEquatable_ty - tcaug.SetHashAndEqualsWith (mkLocalValRef evspec1, mkLocalValRef evspec2, mkLocalValRef evspec3) - PublishValueDefn cenv env ModuleOrMemberBinding evspec1 - PublishValueDefn cenv env ModuleOrMemberBinding evspec2 - PublishValueDefn cenv env ModuleOrMemberBinding evspec3 - - let AddGenericCompareBindings (cenv: cenv) (tycon: Tycon) = - if (* AugmentWithHashCompare.TyconIsCandidateForAugmentationWithCompare g tycon && *) Option.isSome tycon.GeneratedCompareToValues then - AugmentWithHashCompare.MakeBindingsForCompareAugmentation cenv.g tycon - else - [] - - let AddGenericCompareWithComparerBindings (cenv: cenv) (tycon: Tycon) = - let g = cenv.g - if Option.isSome tycon.GeneratedCompareToWithComparerValues then - AugmentWithHashCompare.MakeBindingsForCompareWithComparerAugmentation g tycon - else - [] - - let AddGenericEqualityWithComparerBindings (cenv: cenv) (tycon: Tycon) = - let g = cenv.g - if AugmentWithHashCompare.TyconIsCandidateForAugmentationWithEquals g tycon && Option.isSome tycon.GeneratedHashAndEqualsWithComparerValues then - (AugmentWithHashCompare.MakeBindingsForEqualityWithComparerAugmentation g tycon) - else - [] - - let AddGenericHashAndComparisonDeclarations (cenv: cenv) (env: TcEnv) scSet seSet tycon = - AddGenericCompareDeclarations cenv env scSet tycon - AddGenericEqualityWithComparerDeclarations cenv env seSet tycon - - let AddGenericHashAndComparisonBindings cenv tycon = - AddGenericCompareBindings cenv tycon @ AddGenericCompareWithComparerBindings cenv tycon @ AddGenericEqualityWithComparerBindings cenv tycon - - // We can only add the Equals override after we've done the augmentation because we have to wait until - // tycon.HasOverride can give correct results - let AddGenericEqualityBindings (cenv: cenv) (env: TcEnv) tycon = - let g = cenv.g - if AugmentWithHashCompare.TyconIsCandidateForAugmentationWithEquals g tycon then - let tcref = mkLocalTyconRef tycon - let tcaug = tycon.TypeContents - let ty = if tcref.Deref.IsFSharpException then g.exn_ty else generalizedTyconRef g tcref - let m = tycon.Range - - // Note: tycon.HasOverride only gives correct results after we've done the type augmentation - let hasExplicitObjectEqualsOverride = tycon.HasOverride g "Equals" [g.obj_ty] - let hasExplicitGenericIEquatable = tcaugHasNominalInterface g tcaug g.system_GenericIEquatable_tcref - - if hasExplicitGenericIEquatable then - errorR(Error(FSComp.SR.tcImplementsIEquatableExplicitly(tycon.DisplayName), m)) - - // Note: only provide the equals method if Equals is not implemented explicitly, and - // we're actually generating Hash/Equals for this type - if not hasExplicitObjectEqualsOverride && - Option.isSome tycon.GeneratedHashAndEqualsWithComparerValues then - - let vspec1, vspec2 = AugmentWithHashCompare.MakeValsForEqualsAugmentation g tcref - tcaug.SetEquals (mkLocalValRef vspec1, mkLocalValRef vspec2) - if not tycon.IsFSharpException then - PublishInterface cenv env.DisplayEnv tcref m true (mkAppTy g.system_GenericIEquatable_tcref [ty]) - PublishValueDefn cenv env ModuleOrMemberBinding vspec1 - PublishValueDefn cenv env ModuleOrMemberBinding vspec2 - AugmentWithHashCompare.MakeBindingsForEqualsAugmentation g tycon - else [] - else [] - - - /// Infer 'comparison' and 'equality' constraints from type definitions module TyconConstraintInference = @@ -1965,7 +1972,7 @@ module TyconConstraintInference = // Initially, assume the equality relation is available for all structural type definitions let initialAssumedTycons = set [ for tycon, _ in tyconsWithStructuralTypes do - if AugmentWithHashCompare.TyconIsCandidateForAugmentationWithCompare g tycon then + if AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithCompare g tycon then yield tycon.Stamp ] // Initially, don't assume that the equality relation is dependent on any type variables @@ -2029,8 +2036,8 @@ module TyconConstraintInference = assumedTycons |> Set.filter (fun tyconStamp -> let tycon, structuralTypes = tab[tyconStamp] - if g.compilingFSharpCore && - AugmentWithHashCompare.TyconIsCandidateForAugmentationWithCompare g tycon && + if cenv.g.compilingFSharpCore && + AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithCompare g tycon && not (HasFSharpAttribute g g.attrib_StructuralComparisonAttribute tycon.Attribs) && not (HasFSharpAttribute g g.attrib_NoComparisonAttribute tycon.Attribs) then errorR(Error(FSComp.SR.tcFSharpCoreRequiresExplicit(), tycon.Range)) @@ -2096,7 +2103,7 @@ module TyconConstraintInference = // Initially, assume the equality relation is available for all structural type definitions let initialAssumedTycons = set [ for tycon, _ in tyconsWithStructuralTypes do - if AugmentWithHashCompare.TyconIsCandidateForAugmentationWithEquals g tycon then + if AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithEquals g tycon then yield tycon.Stamp ] // Initially, don't assume that the equality relation is dependent on any type variables @@ -2135,7 +2142,7 @@ module TyconConstraintInference = | AppTy g (tcref, tinst) -> (if initialAssumedTycons.Contains tcref.Stamp then assumedTycons.Contains tcref.Stamp - elif AugmentWithHashCompare.TyconIsCandidateForAugmentationWithEquals g tcref.Deref then + elif AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithEquals g tcref.Deref then Option.isSome tcref.GeneratedHashAndEqualsWithComparerValues else true) @@ -2157,8 +2164,8 @@ module TyconConstraintInference = let tycon, structuralTypes = tab[tyconStamp] - if g.compilingFSharpCore && - AugmentWithHashCompare.TyconIsCandidateForAugmentationWithEquals g tycon && + if cenv.g.compilingFSharpCore && + AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithEquals g tycon && not (HasFSharpAttribute g g.attrib_StructuralEqualityAttribute tycon.Attribs) && not (HasFSharpAttribute g g.attrib_NoEqualityAttribute tycon.Attribs) then errorR(Error(FSComp.SR.tcFSharpCoreRequiresExplicit(), tycon.Range)) @@ -2170,7 +2177,7 @@ module TyconConstraintInference = if not res then match TryFindFSharpBoolAttribute g g.attrib_StructuralEqualityAttribute tycon.Attribs with | Some true -> - if AugmentWithHashCompare.TyconIsCandidateForAugmentationWithEquals g tycon then + if AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithEquals g tycon then match structuralTypes |> List.tryFind (fst >> checkIfFieldTypeSupportsEquality tycon >> not) with | None -> assert false @@ -2185,7 +2192,7 @@ module TyconConstraintInference = | Some false -> () | None -> - if AugmentWithHashCompare.TyconIsCandidateForAugmentationWithEquals g tycon then + if AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithEquals g tycon then match structuralTypes |> List.tryFind (fst >> checkIfFieldTypeSupportsEquality tycon >> not) with | None -> assert false @@ -3785,7 +3792,7 @@ module EstablishTypeDefinitionCores = // Build the initial Tycon for each type definition (fun (innerParent, _, envForDecls) (typeDefCore, tyconMemberInfo) -> - let (MutRecDefnsPhase1DataForTycon(_, _, _, _, _, isAtOriginalTyconDefn)) = typeDefCore + let (MutRecDefnsPhase1DataForTycon(isAtOriginalTyconDefn=isAtOriginalTyconDefn)) = typeDefCore let tyconOpt = if isAtOriginalTyconDefn then Some (TcTyconDefnCore_Phase1A_BuildInitialTycon cenv envForDecls innerParent typeDefCore) @@ -3920,8 +3927,22 @@ module EstablishTypeDefinitionCores = // REVIEW: checking for cyclic inheritance is happening too late. See note above. TcTyconDefnCore_CheckForCyclicStructsAndInheritance cenv tycons + // Generate the union augmentation values for all tycons. + let withBaseValsAndSafeInitInfosAndUnionValues = + (envMutRecPrelim, withBaseValsAndSafeInitInfos) ||> MutRecShapes.mapTyconsWithEnv (fun envForDecls (origInfo, tyconOpt, fixupFinalAttrs, info) -> + let (tyconCore, _, _) = origInfo + let (MutRecDefnsPhase1DataForTycon (isAtOriginalTyconDefn=isAtOriginalTyconDefn)) = tyconCore + let vspecs = + match tyconOpt with + | Some tycon when isAtOriginalTyconDefn -> + if tycon.IsUnionTycon && AddAugmentationDeclarations.ShouldAugmentUnion cenv.g tycon then + AddAugmentationDeclarations.AddUnionAugmentationValues cenv envForDecls tycon + else + [] + | _ -> [] + (origInfo, tyconOpt, fixupFinalAttrs, info, vspecs)) - (tycons, envMutRecPrelim, withBaseValsAndSafeInitInfos) + (tycons, envMutRecPrelim, withBaseValsAndSafeInitInfosAndUnionValues) /// Bind declarations in implementation and signature files @@ -4277,9 +4298,14 @@ module TcDeclarations = cenv envInitial parent typeNames false tpenv m scopem mutRecNSInfo mutRecDefnsAfterSplit // Package up the phase two information for processing members. - let mutRecDefnsAfterPrep = + let unionValsLookup = Dictionary() + let mutRecDefnsAfterPrep = (envMutRecPrelim, mutRecDefnsAfterCore) - ||> MutRecShapes.mapTyconsWithEnv (fun envForDecls ((typeDefnCore, members, innerParent), tyconOpt, fixupFinalAttrs, (baseValOpt, safeInitInfo)) -> + ||> MutRecShapes.mapTyconsWithEnv (fun envForDecls ((typeDefnCore, members, innerParent), tyconOpt, fixupFinalAttrs, (baseValOpt, safeInitInfo), unionVals) -> + match tyconOpt with + | Some tycon when not unionVals.IsEmpty -> unionValsLookup.Add(tycon.Stamp, unionVals) + | _ -> () + let (MutRecDefnsPhase1DataForTycon(synTyconInfo, _, _, _, _, isAtOriginalTyconDefn)) = typeDefnCore let tyDeclRange = synTyconInfo.Range let (SynComponentInfo(_, TyparsAndConstraints (typars, cs1), cs2, longPath, _, _, _, _)) = synTyconInfo @@ -4376,7 +4402,16 @@ module TcDeclarations = // in, and there are code generation tests to check that. let binds = AddAugmentationDeclarations.AddGenericHashAndComparisonBindings cenv tycon let binds3 = AddAugmentationDeclarations.AddGenericEqualityBindings cenv envForDecls tycon - binds, binds3) + let binds4 = + if tycon.IsUnionTycon && AddAugmentationDeclarations.ShouldAugmentUnion g tycon then + let unionVals = + match unionValsLookup.TryGetValue(tycon.Stamp) with + | false, _ -> [] + | true, vs -> vs + AugmentTypeDefinitions.MakeBindingsForUnionAugmentation g tycon (List.map mkLocalValRef unionVals) + else + [] + binds@binds4, binds3) // Check for cyclic structs and inheritance all over again, since we may have added some fields to the struct when generating the implicit construction syntax EstablishTypeDefinitionCores.TcTyconDefnCore_CheckForCyclicStructsAndInheritance cenv tycons @@ -4431,19 +4466,20 @@ module TcDeclarations = // 'type X with ...' in a signature is always interpreted as an extrinsic extension. // Representation-hidden types with members and interfaces are written 'type X = ...' - | SynTypeDefnSigRepr.Simple(SynTypeDefnSimpleRepr.None _ as r, _) when not (isNil extraMembers) -> + | SynTypeDefnSigRepr.Simple(SynTypeDefnSimpleRepr.None _ as repr, _) when not (isNil extraMembers) -> let isAtOriginalTyconDefn = false - let tyconCore = MutRecDefnsPhase1DataForTycon (synTyconInfo, r, implements1, false, false, isAtOriginalTyconDefn) + let tyconCore = MutRecDefnsPhase1DataForTycon (synTyconInfo, repr, implements1, false, false, isAtOriginalTyconDefn) tyconCore, (synTyconInfo, extraMembers) - - | SynTypeDefnSigRepr.Exception r -> + + | SynTypeDefnSigRepr.Exception exnRepr -> let isAtOriginalTyconDefn = true - let core = MutRecDefnsPhase1DataForTycon(synTyconInfo, SynTypeDefnSimpleRepr.Exception r, implements1, false, false, isAtOriginalTyconDefn) + let repr = SynTypeDefnSimpleRepr.Exception exnRepr + let core = MutRecDefnsPhase1DataForTycon(synTyconInfo, repr, implements1, false, false, isAtOriginalTyconDefn) core, (synTyconInfo, extraMembers) - | SynTypeDefnSigRepr.Simple(r, _) -> + | SynTypeDefnSigRepr.Simple(repr, _) -> let isAtOriginalTyconDefn = true - let tyconCore = MutRecDefnsPhase1DataForTycon (synTyconInfo, r, implements1, false, false, isAtOriginalTyconDefn) + let tyconCore = MutRecDefnsPhase1DataForTycon (synTyconInfo, repr, implements1, false, false, isAtOriginalTyconDefn) tyconCore, (synTyconInfo, extraMembers) @@ -4451,9 +4487,9 @@ module TcDeclarations = let g = cenv.g (envMutRec, mutRecDefns) ||> MutRecShapes.mapWithEnv // Do this for the members in each 'type' declaration - (fun envForDecls ((tyconCore, (synTyconInfo, members), innerParent), tyconOpt, _fixupFinalAttrs, _) -> + (fun envForDecls ((tyconCore, (synTyconInfo, members), innerParent), tyconOpt, _fixupFinalAttrs, _, _extraValSpecs) -> let tpenv = emptyUnscopedTyparEnv - let (MutRecDefnsPhase1DataForTycon (_, _, _, _, _, isAtOriginalTyconDefn)) = tyconCore + let (MutRecDefnsPhase1DataForTycon (isAtOriginalTyconDefn=isAtOriginalTyconDefn)) = tyconCore let (SynComponentInfo(_, TyparsAndConstraints (typars, cs1), cs2, longPath, _, _, _, m)) = synTyconInfo let cs = cs1 @ cs2 let declKind, tcref, declaredTyconTypars = ComputeTyconDeclKind cenv envForDecls tyconOpt isAtOriginalTyconDefn true m typars cs longPath @@ -4462,7 +4498,7 @@ module TcDeclarations = let envForTycon = MakeInnerEnvForTyconRef envForTycon tcref (declKind = ExtrinsicExtensionBinding) TcTyconMemberSpecs cenv envForTycon (TyconContainerInfo(innerParent, tcref, declaredTyconTypars, NoSafeInitInfo)) declKind tpenv members) - + // Do this for each 'val' declaration in a module (fun envForDecls (containerInfo, valSpec) -> let tpenv = emptyUnscopedTyparEnv @@ -4493,7 +4529,7 @@ module TcDeclarations = let envMutRecPrelimWithReprs, withEnvs = (envInitial, MutRecShapes.dropEnvs mutRecDefnsAfterCore) ||> MutRecBindingChecking.TcMutRecDefns_ComputeEnvs - (fun (_, tyconOpt, _, _) -> tyconOpt) + (fun (_, tyconOpt, _, _, _) -> tyconOpt) (fun _binds -> [ (* no values are available yet *) ]) cenv true scopem m @@ -4502,6 +4538,16 @@ module TcDeclarations = // Updates the types of the modules to contain the contents so far, which now includes values and members MutRecBindingChecking.TcMutRecDefns_UpdateModuleContents mutRecNSInfo mutRecDefnsAfterVals + // Generate the union augmentation values for all tycons. + (envMutRec, mutRecDefnsAfterCore) ||> MutRecShapes.iterTyconsWithEnv (fun envForDecls ((tyconCore, _, _), tyconOpt, _, _, _) -> + let (MutRecDefnsPhase1DataForTycon (isAtOriginalTyconDefn=isAtOriginalTyconDefn)) = tyconCore + match tyconOpt with + | Some tycon when isAtOriginalTyconDefn -> + if tycon.IsUnionTycon && AddAugmentationDeclarations.ShouldAugmentUnion cenv.g tycon then + let vspecs = AddAugmentationDeclarations.AddUnionAugmentationValues cenv envForDecls tycon + ignore vspecs + | _ -> ()) + envMutRec //------------------------------------------------------------------------- diff --git a/src/Compiler/Checking/CheckExpressions.fs b/src/Compiler/Checking/CheckExpressions.fs index 3dd87b80b87..ce0918f732e 100644 --- a/src/Compiler/Checking/CheckExpressions.fs +++ b/src/Compiler/Checking/CheckExpressions.fs @@ -1084,14 +1084,14 @@ let PublishValueDefnPrim (cenv: cenv) env (vspec: Val) = UpdateAccModuleOrNamespaceType cenv env (fun _ mty -> mty.AddVal vspec) -let PublishValueDefn (cenv: cenv) env declKind (vspec: Val) = +let PublishValueDefnMaybeInclCompilerGenerated (cenv: cenv) env inclCompilerGenerated declKind (vspec: Val) = let g = cenv.g let isNamespace = let kind = (GetCurrAccumulatedModuleOrNamespaceType env).ModuleOrNamespaceKind match kind with | Namespace _ -> true | _ -> false - + if (declKind = ModuleOrMemberBinding) && isNamespace && (Option.isNone vspec.MemberInfo) then @@ -1110,7 +1110,7 @@ let PublishValueDefn (cenv: cenv) env declKind (vspec: Val) = match vspec.MemberInfo with | Some _ when - (not vspec.IsCompilerGenerated && + ((not vspec.IsCompilerGenerated || inclCompilerGenerated) && // Extrinsic extensions don't get added to the tcaug not (declKind = ExtrinsicExtensionBinding)) -> // // Static initializers don't get published to the tcaug @@ -1122,6 +1122,9 @@ let PublishValueDefn (cenv: cenv) env declKind (vspec: Val) = tcaug.tcaug_adhoc_list.Add (ValRefIsExplicitImpl g vref, vref) | _ -> () +let PublishValueDefn cenv env declKind vspec = + PublishValueDefnMaybeInclCompilerGenerated cenv env false declKind vspec + let CombineVisibilityAttribs vis1 vis2 m = match vis1 with | Some _ -> diff --git a/src/Compiler/Checking/CheckExpressions.fsi b/src/Compiler/Checking/CheckExpressions.fsi index 0d02f07a223..e2b792068f8 100644 --- a/src/Compiler/Checking/CheckExpressions.fsi +++ b/src/Compiler/Checking/CheckExpressions.fsi @@ -578,6 +578,10 @@ val PublishTypeDefn: cenv: TcFileState -> env: TcEnv -> mspec: Tycon -> unit /// Publish a value definition to the module/namespace type accumulator. val PublishValueDefn: cenv: TcFileState -> env: TcEnv -> declKind: DeclKind -> vspec: Val -> unit +/// Publish a value definition to the module/namespace type accumulator. +val PublishValueDefnMaybeInclCompilerGenerated: + cenv: TcFileState -> env: TcEnv -> inclCompilerGenerated: bool -> declKind: DeclKind -> vspec: Val -> unit + /// Mark a typar as no longer being an inference type variable val SetTyparRigid: DisplayEnv -> range -> Typar -> unit diff --git a/src/Compiler/Checking/ConstraintSolver.fs b/src/Compiler/Checking/ConstraintSolver.fs index 22ebc3ca4df..e2a16606cb5 100644 --- a/src/Compiler/Checking/ConstraintSolver.fs +++ b/src/Compiler/Checking/ConstraintSolver.fs @@ -2347,7 +2347,7 @@ and SolveTypeSupportsComparison (csenv: ConstraintSolverEnv) ndeep m2 trace ty = // Give a good error for structural types excluded from the comparison relation because of their fields elif (isAppTy g ty && let tcref = tcrefOfAppTy g ty - AugmentWithHashCompare.TyconIsCandidateForAugmentationWithCompare g tcref.Deref && + AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithCompare g tcref.Deref && Option.isNone tcref.GeneratedCompareToWithComparerValues) then ErrorD (ConstraintSolverError(FSComp.SR.csTypeDoesNotSupportComparison3(NicePrint.minimalStringOfType denv ty), m, m2)) @@ -2377,7 +2377,7 @@ and SolveTypeSupportsEquality (csenv: ConstraintSolverEnv) ndeep m2 trace ty = match ty with | AppTy g (tcref, tinst) -> // Give a good error for structural types excluded from the equality relation because of their fields - if AugmentWithHashCompare.TyconIsCandidateForAugmentationWithEquals g tcref.Deref && + if AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithEquals g tcref.Deref && Option.isNone tcref.GeneratedHashAndEqualsWithComparerValues then ErrorD (ConstraintSolverError(FSComp.SR.csTypeDoesNotSupportEquality3(NicePrint.minimalStringOfType denv ty), m, m2)) diff --git a/src/Compiler/Checking/MethodOverrides.fs b/src/Compiler/Checking/MethodOverrides.fs index 314c2d4dd12..071a113a60e 100644 --- a/src/Compiler/Checking/MethodOverrides.fs +++ b/src/Compiler/Checking/MethodOverrides.fs @@ -886,12 +886,12 @@ let FinalTypeDefinitionChecksAtEndOfInferenceScope (infoReader: InfoReader, nenv not tycon.IsFSharpInterfaceTycon then (* Warn when we're doing this for class types *) - if AugmentWithHashCompare.TyconIsCandidateForAugmentationWithEquals g tycon then + if AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithEquals g tycon then warning(Error(FSComp.SR.typrelTypeImplementsIComparableShouldOverrideObjectEquals(tycon.DisplayName), tycon.Range)) else warning(Error(FSComp.SR.typrelTypeImplementsIComparableDefaultObjectEqualsProvided(tycon.DisplayName), tycon.Range)) - AugmentWithHashCompare.CheckAugmentationAttribs isImplementation g amap tycon + AugmentTypeDefinitions.CheckAugmentationAttribs isImplementation g amap tycon // Check some conditions about generic comparison and hashing. We can only check this condition after we've done the augmentation if isImplementation #if !NO_TYPEPROVIDERS diff --git a/src/Compiler/Checking/NameResolution.fs b/src/Compiler/Checking/NameResolution.fs index 6fa70c26fc7..7b3f1970721 100644 --- a/src/Compiler/Checking/NameResolution.fs +++ b/src/Compiler/Checking/NameResolution.fs @@ -4229,7 +4229,7 @@ let ResolveCompletionsInType (ncenv: NameResolver) nenv (completionTargets: Reso not minfo.IsExtensionMember && match minfo.LogicalName with | "GetType" -> false - | "GetHashCode" -> isObjTy g minfo.ApparentEnclosingType && not (AugmentWithHashCompare.TypeDefinitelyHasEquality g ty) + | "GetHashCode" -> isObjTy g minfo.ApparentEnclosingType && not (AugmentTypeDefinitions.TypeDefinitelyHasEquality g ty) | "ToString" -> false | "Equals" -> if not (isObjTy g minfo.ApparentEnclosingType) then @@ -4237,7 +4237,7 @@ let ResolveCompletionsInType (ncenv: NameResolver) nenv (completionTargets: Reso false elif minfo.IsInstance then // System.Object has only one instance Equals method and we want to suppress it unless Augment.TypeDefinitelyHasEquality is true - not (AugmentWithHashCompare.TypeDefinitelyHasEquality g ty) + not (AugmentTypeDefinitions.TypeDefinitelyHasEquality g ty) else // System.Object has only one static Equals method and we always want to suppress it true @@ -4929,7 +4929,7 @@ let ResolveCompletionsInTypeForItem (ncenv: NameResolver) nenv m ad statics ty ( not minfo.IsExtensionMember && match minfo.LogicalName with | "GetType" -> false - | "GetHashCode" -> isObjTy g minfo.ApparentEnclosingType && not (AugmentWithHashCompare.TypeDefinitelyHasEquality g ty) + | "GetHashCode" -> isObjTy g minfo.ApparentEnclosingType && not (AugmentTypeDefinitions.TypeDefinitelyHasEquality g ty) | "ToString" -> false | "Equals" -> if not (isObjTy g minfo.ApparentEnclosingType) then @@ -4937,7 +4937,7 @@ let ResolveCompletionsInTypeForItem (ncenv: NameResolver) nenv m ad statics ty ( false elif minfo.IsInstance then // System.Object has only one instance Equals method and we want to suppress it unless Augment.TypeDefinitelyHasEquality is true - not (AugmentWithHashCompare.TypeDefinitelyHasEquality g ty) + not (AugmentTypeDefinitions.TypeDefinitelyHasEquality g ty) else // System.Object has only one static Equals method and we always want to suppress it true diff --git a/src/Compiler/Checking/NicePrint.fs b/src/Compiler/Checking/NicePrint.fs index 2ab993e369a..f3ed2dc25cb 100644 --- a/src/Compiler/Checking/NicePrint.fs +++ b/src/Compiler/Checking/NicePrint.fs @@ -1832,6 +1832,9 @@ module TastDefinitionPrinting = let props = GetImmediateIntrinsicPropInfosOfType (None, ad) g amap m ty |> List.filter (fun pinfo -> shouldShow pinfo.ArbitraryValRef) + // Filter out 'IsA' properties which are implied by the union cases since they don't need to be displayed + // in any printed outputs + |> List.filter (fun prop -> not prop.IsUnionCaseTester) let events = infoReader.GetEventInfosOfType(None, ad, m, ty) @@ -1859,7 +1862,8 @@ module TastDefinitionPrinting = IsMethInfoAccessible amap m ad minfo && // Discard method impls such as System.IConvertible.ToBoolean not (minfo.IsILMethod && minfo.DisplayName.Contains(".")) && - not (minfo.DisplayName.Split('.') |> Array.exists (fun part -> isDiscard part))) + not (minfo.DisplayName.Split('.') |> Array.exists (fun part -> isDiscard part)) && + not minfo.IsUnionCaseTester) let ilFields = infoReader.GetILFieldInfosOfType (None, ad, m, ty) @@ -1916,7 +1920,7 @@ module TastDefinitionPrinting = let instanceValLs = instanceVals |> List.map (fun f -> layoutRecdField (fun l -> WordL.keywordVal ^^ l) true denv infoReader tcref f) - + let propLs = props |> List.map (fun x -> (true, x.IsStatic, x.PropertyName, 0, 0), layoutPropInfo denv infoReader m x) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 145c7e0799c..e0cc07f825a 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -2178,7 +2178,7 @@ let CheckModuleBinding cenv env (TBind(v, e, _) as bind) = // Default augmentation contains the nasty 'Is' etc. let prefix = "Is" - if nm.StartsWithOrdinal prefix && hasDefaultAugmentation then + if not v.IsImplied && nm.StartsWithOrdinal prefix && hasDefaultAugmentation then match tcref.GetUnionCaseByName(nm[prefix.Length ..]) with | Some uc -> error(NameClash(nm, kind, v.DisplayName, v.Range, FSComp.SR.chkUnionCaseDefaultAugmentation(), uc.DisplayName, uc.Range)) | None -> () diff --git a/src/Compiler/Checking/infos.fs b/src/Compiler/Checking/infos.fs index 2fe6031aeae..cff8212f1b0 100644 --- a/src/Compiler/Checking/infos.fs +++ b/src/Compiler/Checking/infos.fs @@ -808,6 +808,15 @@ type MethInfo = | ProvidedMeth(_, mi, _, m) -> [mi.PUntaint((fun mi -> mi.GetParameters().Length), m)] // Why is this a list? Answer: because the method might be curried #endif + /// Indicates if the property is a IsABC union case tester implied by a union case definition + member x.IsUnionCaseTester = + let tcref = x.ApparentEnclosingTyconRef + tcref.IsUnionTycon && + x.LogicalName.StartsWith("get_Is") && + match x.ArbitraryValRef with + | Some v -> v.IsImplied + | None -> false + member x.IsCurried = x.NumArgs.Length > 1 /// Does the method appear to the user as an instance method? @@ -1996,6 +2005,11 @@ type PropInfo = #endif | _ -> false + /// Indicates if the property is a IsABC union case tester implied by a union case definition + member x.IsUnionCaseTester = + x.HasGetter && + x.GetterMethod.IsUnionCaseTester + /// Calculates a hash code of property info. Must be compatible with ItemsAreEffectivelyEqual relation. member pi.ComputeHashCode() = match pi with diff --git a/src/Compiler/Checking/infos.fsi b/src/Compiler/Checking/infos.fsi index 550c7860b34..a9ff96174be 100644 --- a/src/Compiler/Checking/infos.fsi +++ b/src/Compiler/Checking/infos.fsi @@ -420,6 +420,9 @@ type MethInfo = /// Indicates if this is an IL method. member IsILMethod: bool + /// Indicates if the method is a get_IsABC union case tester implied by a union case definition + member IsUnionCaseTester: bool + /// Does the method appear to the user as an instance method? member IsInstance: bool @@ -818,6 +821,9 @@ type PropInfo = member ImplementedSlotSignatures: SlotSig list + /// Indicates if the property is a IsABC union case tester implied by a union case definition + member IsUnionCaseTester: bool + /// Indicates if this property is marked 'override' and thus definitely overrides another property. member IsDefiniteFSharpOverride: bool diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index 5dcd60c9a14..35ca89b367f 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -8,6 +8,7 @@ open FSharp.Compiler.IlxGenSupport open System.Collections.Generic open System.Reflection open Internal.Utilities.Library +open FSharp.Compiler.Features open FSharp.Compiler.TcGlobals open FSharp.Compiler.AbstractIL.IL open FSharp.Compiler.AbstractIL.ILX.Types @@ -827,7 +828,12 @@ let convAlternativeDef | SpecialFSharpListHelpers -> let baseTesterMeths, baseTesterProps = - if cud.UnionCases.Length <= 1 then + if + g.langVersion.SupportsFeature LanguageFeature.UnionIsPropertiesVisible + && cud.HasHelpers = AllHelpers + then + [], [] + elif cud.UnionCases.Length <= 1 then [], [] elif repr.RepresentOneAlternativeAsNull info then [], [] diff --git a/src/Compiler/CodeGen/IlxGen.fs b/src/Compiler/CodeGen/IlxGen.fs index 7e14c215a2e..a1d47a63744 100644 --- a/src/Compiler/CodeGen/IlxGen.fs +++ b/src/Compiler/CodeGen/IlxGen.fs @@ -2133,15 +2133,15 @@ type AnonTypeGenerationTable() = (mkAppTy g.system_GenericIEquatable_tcref [ ty ], true, m) ] - let vspec1, vspec2 = AugmentWithHashCompare.MakeValsForEqualsAugmentation g tcref + let vspec1, vspec2 = AugmentTypeDefinitions.MakeValsForEqualsAugmentation g tcref let evspec1, evspec2, evspec3 = - AugmentWithHashCompare.MakeValsForEqualityWithComparerAugmentation g tcref + AugmentTypeDefinitions.MakeValsForEqualityWithComparerAugmentation g tcref - let cvspec1, cvspec2 = AugmentWithHashCompare.MakeValsForCompareAugmentation g tcref + let cvspec1, cvspec2 = AugmentTypeDefinitions.MakeValsForCompareAugmentation g tcref let cvspec3 = - AugmentWithHashCompare.MakeValsForCompareWithComparerAugmentation g tcref + AugmentTypeDefinitions.MakeValsForCompareWithComparerAugmentation g tcref tcaug.SetCompare(mkLocalValRef cvspec1, mkLocalValRef cvspec2) tcaug.SetCompareWith(mkLocalValRef cvspec3) @@ -2184,10 +2184,10 @@ type AnonTypeGenerationTable() = let extraBindings = [| - yield! AugmentWithHashCompare.MakeBindingsForCompareAugmentation g tycon - yield! AugmentWithHashCompare.MakeBindingsForCompareWithComparerAugmentation g tycon - yield! AugmentWithHashCompare.MakeBindingsForEqualityWithComparerAugmentation g tycon - yield! AugmentWithHashCompare.MakeBindingsForEqualsAugmentation g tycon + yield! AugmentTypeDefinitions.MakeBindingsForCompareAugmentation g tycon + yield! AugmentTypeDefinitions.MakeBindingsForCompareWithComparerAugmentation g tycon + yield! AugmentTypeDefinitions.MakeBindingsForEqualityWithComparerAugmentation g tycon + yield! AugmentTypeDefinitions.MakeBindingsForEqualsAugmentation g tycon |] let optimizedExtraBindings = diff --git a/src/Compiler/Driver/CompilerImports.fs b/src/Compiler/Driver/CompilerImports.fs index d182a8d8ebf..0bda6e0c0f8 100644 --- a/src/Compiler/Driver/CompilerImports.fs +++ b/src/Compiler/Driver/CompilerImports.fs @@ -2483,7 +2483,7 @@ and [] TcImports sysCcus |> Array.tryFind (fun ccu -> ccuHasType ccu path typeName publicOnly) let ilGlobals = - mkILGlobals (primaryScopeRef, equivPrimaryAssemblyRefs, fsharpCoreAssemblyScopeRef) + mkILGlobals (primaryScopeRef, equivPrimaryAssemblyRefs, fsharpCoreAssemblyScopeRef, tcConfig.langVersion) // OK, now we have both mscorlib.dll and FSharp.Core.dll we can create TcGlobals let tcGlobals = diff --git a/src/Compiler/FSComp.txt b/src/Compiler/FSComp.txt index 0da140f884d..20e67885695 100644 --- a/src/Compiler/FSComp.txt +++ b/src/Compiler/FSComp.txt @@ -1246,6 +1246,7 @@ featurePrintfBinaryFormat,"binary formatting for integers" featureIndexerNotationWithoutDot,"expr[idx] notation for indexing and slicing" featureRefCellNotationInformationals,"informational messages related to reference cells" featureDiscardUseValue,"discard pattern in use binding" +featureUnionIsPropertiesVisible,"visible union case test properties" featureNonVariablePatternsToRightOfAsPatterns,"non-variable patterns to the right of 'as' patterns" featureAttributesToRightOfModuleKeyword,"attributes to the right of the 'module' keyword" featureMLCompatRevisions,"ML compatibility revisions" diff --git a/src/Compiler/FSharp.Compiler.Service.fsproj b/src/Compiler/FSharp.Compiler.Service.fsproj index 54f68ef21d1..36d1b81a523 100644 --- a/src/Compiler/FSharp.Compiler.Service.fsproj +++ b/src/Compiler/FSharp.Compiler.Service.fsproj @@ -314,8 +314,8 @@ - - + + diff --git a/src/Compiler/Facilities/LanguageFeatures.fs b/src/Compiler/Facilities/LanguageFeatures.fs index f46b0dbeee1..da4b7ac3b0a 100644 --- a/src/Compiler/Facilities/LanguageFeatures.fs +++ b/src/Compiler/Facilities/LanguageFeatures.fs @@ -42,6 +42,7 @@ type LanguageFeature = | IndexerNotationWithoutDot | RefCellNotationInformationals | UseBindingValueDiscard + | UnionIsPropertiesVisible | NonVariablePatternsToRightOfAsPatterns | AttributesToRightOfModuleKeyword | MLCompatRevisions @@ -157,6 +158,7 @@ type LanguageVersion(versionText) = LanguageFeature.NonInlineLiteralsAsPrintfFormat, previewVersion LanguageFeature.NestedCopyAndUpdate, previewVersion LanguageFeature.ExtendedStringInterpolation, previewVersion + LanguageFeature.UnionIsPropertiesVisible, previewVersion ] @@ -252,6 +254,7 @@ type LanguageVersion(versionText) = | LanguageFeature.IndexerNotationWithoutDot -> FSComp.SR.featureIndexerNotationWithoutDot () | LanguageFeature.RefCellNotationInformationals -> FSComp.SR.featureRefCellNotationInformationals () | LanguageFeature.UseBindingValueDiscard -> FSComp.SR.featureDiscardUseValue () + | LanguageFeature.UnionIsPropertiesVisible -> FSComp.SR.featureUnionIsPropertiesVisible () | LanguageFeature.NonVariablePatternsToRightOfAsPatterns -> FSComp.SR.featureNonVariablePatternsToRightOfAsPatterns () | LanguageFeature.AttributesToRightOfModuleKeyword -> FSComp.SR.featureAttributesToRightOfModuleKeyword () | LanguageFeature.MLCompatRevisions -> FSComp.SR.featureMLCompatRevisions () diff --git a/src/Compiler/Facilities/LanguageFeatures.fsi b/src/Compiler/Facilities/LanguageFeatures.fsi index d12c77fdcbe..af5120a9c72 100644 --- a/src/Compiler/Facilities/LanguageFeatures.fsi +++ b/src/Compiler/Facilities/LanguageFeatures.fsi @@ -32,6 +32,7 @@ type LanguageFeature = | IndexerNotationWithoutDot | RefCellNotationInformationals | UseBindingValueDiscard + | UnionIsPropertiesVisible | NonVariablePatternsToRightOfAsPatterns | AttributesToRightOfModuleKeyword | MLCompatRevisions diff --git a/src/Compiler/Symbols/Symbols.fs b/src/Compiler/Symbols/Symbols.fs index 8595d61bf1b..3192d360791 100644 --- a/src/Compiler/Symbols/Symbols.fs +++ b/src/Compiler/Symbols/Symbols.fs @@ -1762,6 +1762,13 @@ type FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = | P p -> mkMethSym p.SetterMethod | E _ | M _ | C _ | V _ -> invalidOp "the value or member doesn't have an associated setter method" + member _.IsUnionCaseTester = + checkIsResolved() + match d with + | P p -> p.IsUnionCaseTester + | M m -> m.IsUnionCaseTester + | E _ | C _ | V _ -> invalidOp "the value or member is not a property" + member _.EventAddMethod = checkIsResolved() match d with diff --git a/src/Compiler/Symbols/Symbols.fsi b/src/Compiler/Symbols/Symbols.fsi index 44e215e5214..feded36812b 100644 --- a/src/Compiler/Symbols/Symbols.fsi +++ b/src/Compiler/Symbols/Symbols.fsi @@ -831,6 +831,9 @@ type FSharpMemberOrFunctionOrValue = /// Get an associated setter method of the property member SetterMethod: FSharpMemberOrFunctionOrValue + /// Indicates if the property or getter method is part of a IsABC union case tester implied by a union case definition + member IsUnionCaseTester: bool + /// Get an associated add method of an event member EventAddMethod: FSharpMemberOrFunctionOrValue diff --git a/src/Compiler/TypedTree/TcGlobals.fs b/src/Compiler/TypedTree/TcGlobals.fs index 4174d567a6e..ab0eea03544 100755 --- a/src/Compiler/TypedTree/TcGlobals.fs +++ b/src/Compiler/TypedTree/TcGlobals.fs @@ -874,13 +874,17 @@ type TcGlobals( let v_check_this_info = makeIntrinsicValRef(fslib_MFIntrinsicFunctions_nleref, "CheckThis" , None , None , [vara], ([[varaTy]], varaTy)) let v_quote_to_linq_lambda_info = makeIntrinsicValRef(fslib_MFLinqRuntimeHelpersQuotationConverter_nleref, "QuotationToLambdaExpression" , None , None , [vara], ([[mkQuotedExprTy varaTy]], mkLinqExpressionTy varaTy)) + let tref_DebuggerNonUserCodeAttribute = findSysILTypeRef tname_DebuggerNonUserCodeAttribute + let v_DebuggerNonUserCodeAttribute_tcr = splitILTypeName tname_DebuggerNonUserCodeAttribute ||> findSysTyconRef + let tref_DebuggableAttribute = findSysILTypeRef tname_DebuggableAttribute - let tref_CompilerGeneratedAttribute = findSysILTypeRef tname_CompilerGeneratedAttribute + let tref_CompilerGeneratedAttribute = findSysILTypeRef tname_CompilerGeneratedAttribute + let v_CompilerGeneratedAttribute_tcr = splitILTypeName tname_CompilerGeneratedAttribute ||> findSysTyconRef let tref_InternalsVisibleToAttribute = findSysILTypeRef tname_InternalsVisibleToAttribute let mutable generatedAttribsCache = [] let mutable debuggerBrowsableNeverAttributeCache = None - let mkDebuggerNonUserCodeAttribute() = mkILCustomAttribute (findSysILTypeRef tname_DebuggerNonUserCodeAttribute, [], [], []) + let mkDebuggerNonUserCodeAttribute() = mkILCustomAttribute (tref_DebuggerNonUserCodeAttribute, [], [], []) let mkCompilerGeneratedAttribute () = mkILCustomAttribute (tref_CompilerGeneratedAttribute, [], [], []) let compilerGlobalState = CompilerGlobalState() @@ -899,6 +903,14 @@ type TcGlobals( | res -> res mkILCustomAttrs (attrs.AsList() @ attribs) + let addValGeneratedAttrs (v: Val) m = + if not noDebugAttributes then + v.SetAttribs ([ + Attrib(v_CompilerGeneratedAttribute_tcr, ILAttrib ((mkILNonGenericCtorMethSpec (tref_CompilerGeneratedAttribute, [])).MethodRef), [], [], false, None, m) + Attrib(v_DebuggerNonUserCodeAttribute_tcr, ILAttrib ((mkILNonGenericCtorMethSpec (tref_DebuggerNonUserCodeAttribute, [])).MethodRef), [], [], false, None, m) + Attrib(v_DebuggerNonUserCodeAttribute_tcr, ILAttrib ((mkILNonGenericCtorMethSpec (tref_DebuggerNonUserCodeAttribute, [])).MethodRef), [], [], true, None, m) + ] @ v.Attribs) + let addMethodGeneratedAttrs (mdef:ILMethodDef) = mdef.With(customAttrs = addGeneratedAttrs mdef.CustomAttrs) let addPropertyGeneratedAttrs (pdef:ILPropertyDef) = pdef.With(customAttrs = addGeneratedAttrs pdef.CustomAttrs) @@ -1823,6 +1835,8 @@ type TcGlobals( member _.AddGeneratedAttributes attrs = addGeneratedAttrs attrs + member _.AddValGeneratedAttributes v = addValGeneratedAttrs v + member _.AddMethodGeneratedAttributes mdef = addMethodGeneratedAttrs mdef member _.AddPropertyGeneratedAttributes mdef = addPropertyGeneratedAttrs mdef diff --git a/src/Compiler/TypedTree/TypedTree.fs b/src/Compiler/TypedTree/TypedTree.fs index b18cdd1d2a9..38d19a8b8ad 100644 --- a/src/Compiler/TypedTree/TypedTree.fs +++ b/src/Compiler/TypedTree/TypedTree.fs @@ -232,9 +232,13 @@ type ValFlags(flags: int64) = member x.WithIgnoresByrefScope = ValFlags(flags ||| 0b10000000000000000000L) member x.InlineIfLambda = (flags &&& 0b100000000000000000000L) <> 0L - + member x.WithInlineIfLambda = ValFlags(flags ||| 0b100000000000000000000L) + member x.IsImplied = (flags &&& 0b1000000000000000000000L) <> 0L + + member x.WithIsImplied = ValFlags(flags ||| 0b1000000000000000000000L) + /// Get the flags as included in the F# binary metadata member x.PickledBits = // Clear the RecursiveValInfo, only used during inference and irrelevant across assembly boundaries @@ -2868,6 +2872,9 @@ type Val = /// Get the inline declaration on a parameter or other non-function-declaration value, used for optimization member x.InlineIfLambda = x.val_flags.InlineIfLambda + /// Determines if the values is implied by another construct, e.g. a `IsA` property is implied by the union case for A + member x.IsImplied = x.val_flags.IsImplied + /// Indicates whether the inline declaration for the value indicate that the value must be inlined? member x.MustInline = x.InlineInfo.MustInline @@ -2879,7 +2886,7 @@ type Val = /// Indicates that this value's getter or setter are generated by the compiler member x.GetterOrSetterIsCompilerGenerated = x.MemberInfo |> Option.exists (fun m -> m.MemberFlags.GetterOrSetterIsCompilerGenerated = true) - + /// Get the declared attributes for the value member x.Attribs = match x.val_opt_data with @@ -3108,6 +3115,8 @@ type Val = member x.SetInlineIfLambda() = x.val_flags <- x.val_flags.WithInlineIfLambda + member x.SetIsImplied() = x.val_flags <- x.val_flags.WithIsImplied + member x.SetValReprInfo info = match x.val_opt_data with | Some optData -> optData.val_repr_info <- info @@ -4020,6 +4029,9 @@ type ValRef = /// Get the inline declaration on the value member x.InlineInfo = x.Deref.InlineInfo + /// Determines if the values is implied by another construct, e.g. a `IsA` property is implied by the union case for A + member x.IsImplied = x.Deref.IsImplied + /// Get the inline declaration on a parameter or other non-function-declaration value, used for optimization member x.InlineIfLambda = x.Deref.InlineIfLambda diff --git a/src/Compiler/TypedTree/TypedTree.fsi b/src/Compiler/TypedTree/TypedTree.fsi index bcc951ecc4d..b6730e5d1c8 100644 --- a/src/Compiler/TypedTree/TypedTree.fsi +++ b/src/Compiler/TypedTree/TypedTree.fsi @@ -109,6 +109,8 @@ type ValFlags = member InlineInfo: ValInline + member IsImplied: bool + member IsCompiledAsStaticPropertyWithoutField: bool member IsCompilerGenerated: bool @@ -142,6 +144,8 @@ type ValFlags = member WithInlineIfLambda: ValFlags + member WithIsImplied: ValFlags + member WithIsCompiledAsStaticPropertyWithoutField: ValFlags member WithIsFixed: ValFlags @@ -1921,6 +1925,8 @@ type Val = member SetInlineIfLambda: unit -> unit + member SetIsImplied: unit -> unit + member SetIsCompiledAsStaticPropertyWithoutField: unit -> unit member SetIsCompilerGenerated: v: bool -> unit @@ -2033,6 +2039,9 @@ type Val = /// Get the inline declaration on the value member InlineInfo: ValInline + /// Determines if the values is implied by another construct, e.g. a `IsA` property is implied by the union case for A + member IsImplied: bool + /// Indicates if this is a 'base' value? member IsBaseVal: bool @@ -2769,6 +2778,9 @@ type ValRef = /// Get the inline declaration on a parameter or other non-function-declaration value, used for optimization member InlineIfLambda: bool + /// Determines if the values is implied by another construct, e.g. a `IsA` property is implied by the union case for A + member IsImplied: bool + /// Get the inline declaration on the value member InlineInfo: ValInline diff --git a/src/Compiler/TypedTree/TypedTreeOps.fs b/src/Compiler/TypedTree/TypedTreeOps.fs index 702f7292429..d59ef3493a6 100644 --- a/src/Compiler/TypedTree/TypedTreeOps.fs +++ b/src/Compiler/TypedTree/TypedTreeOps.fs @@ -3474,6 +3474,14 @@ let TyconRefHasAttribute g m attribSpec tcref = (fun _ -> Some ()) |> Option.isSome +let HasDefaultAugmentationAttribute g (tcref: TyconRef) = + match TryFindFSharpAttribute g g.attrib_DefaultAugmentationAttribute tcref.Attribs with + | Some(Attrib(_, _, [ AttribBoolArg b ], _, _, _, _)) -> b + | Some (Attrib(_, _, _, _, _, _, m)) -> + errorR(Error(FSComp.SR.ilDefaultAugmentationAttributeCouldNotBeDecoded(), m)) + true + | _ -> true + /// Check if a type definition has an attribute with a specific full name let TyconRefHasAttributeByName (m: range) attrFullName (tcref: TyconRef) = ignore m @@ -8985,6 +8993,18 @@ let mkIsInstConditional g m tgtTy vinputExpr v e2 e3 = let expr = mbuilder.Close(dtree, m, tyOfExpr g e2) expr +(* match inp with DU(_) -> true | _ -> false *) +let mkUnionCaseTest (g: TcGlobals) (e1, cref: UnionCaseRef, tinst, m) = + let mbuilder = new MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m) + let tg2 = mbuilder.AddResultTarget(Expr.Const(Const.Bool true, m, g.bool_ty)) + let tg3 = mbuilder.AddResultTarget(Expr.Const(Const.Bool false, m, g.bool_ty)) + let dtree = TDSwitch(e1, [TCase(DecisionTreeTest.UnionCase(cref, tinst), tg2)], Some tg3, m) + let expr = mbuilder.Close(dtree, m, g.bool_ty) + expr + +// Null tests are generated by +// 1. The compilation of array patterns in the pattern match compiler +// 2. The compilation of string patterns in the pattern match compiler // Called for when creating compiled form of 'let fixed ...'. // // No sequence point is generated for this expression form as this function is only diff --git a/src/Compiler/TypedTree/TypedTreeOps.fsi b/src/Compiler/TypedTree/TypedTreeOps.fsi index 8582edaa5fc..182db2dfc9f 100755 --- a/src/Compiler/TypedTree/TypedTreeOps.fsi +++ b/src/Compiler/TypedTree/TypedTreeOps.fsi @@ -312,6 +312,9 @@ val mkRecdFieldSetViaExprAddr: Expr * RecdFieldRef * TypeInst * Expr * range -> /// Make an expression that gets the tag of a union value (via the address of the value if it is a struct) val mkUnionCaseTagGetViaExprAddr: Expr * TyconRef * TypeInst * range -> Expr +/// Make an expression which tests that a union value is of a particular union case. +val mkUnionCaseTest: TcGlobals -> Expr * UnionCaseRef * TypeInst * range -> Expr + /// Make a 'TOp.UnionCaseProof' expression, which proves a union value is over a particular case (used only for ref-unions, not struct-unions) val mkUnionCaseProof: Expr * UnionCaseRef * TypeInst * range -> Expr @@ -2624,6 +2627,8 @@ val TryBindTyconRefAttribute: f3: (obj option list * (string * obj option) list -> 'a option) -> 'a option +val HasDefaultAugmentationAttribute: g: TcGlobals -> tcref: TyconRef -> bool + val (|ResumableCodeInvoke|_|): g: TcGlobals -> expr: Expr -> (Expr * Expr * Expr list * range * (Expr * Expr list -> Expr)) option diff --git a/src/Compiler/xlf/FSComp.txt.cs.xlf b/src/Compiler/xlf/FSComp.txt.cs.xlf index 68d321a7cdf..cf002681bd3 100644 --- a/src/Compiler/xlf/FSComp.txt.cs.xlf +++ b/src/Compiler/xlf/FSComp.txt.cs.xlf @@ -407,6 +407,11 @@ reprezentace struktury aktivních vzorů + + visible union case test properties + visible union case test properties + + Support for try-with in sequence expressions Podpora try-with ve výrazech pořadí diff --git a/src/Compiler/xlf/FSComp.txt.de.xlf b/src/Compiler/xlf/FSComp.txt.de.xlf index ee52b662d1d..856c44cc1a5 100644 --- a/src/Compiler/xlf/FSComp.txt.de.xlf +++ b/src/Compiler/xlf/FSComp.txt.de.xlf @@ -407,6 +407,11 @@ Strukturdarstellung für aktive Muster + + visible union case test properties + visible union case test properties + + Support for try-with in sequence expressions Unterstützung für "try-with" in Sequenzausdrücken diff --git a/src/Compiler/xlf/FSComp.txt.es.xlf b/src/Compiler/xlf/FSComp.txt.es.xlf index 9748064eb19..8fb8d3d0755 100644 --- a/src/Compiler/xlf/FSComp.txt.es.xlf +++ b/src/Compiler/xlf/FSComp.txt.es.xlf @@ -407,6 +407,11 @@ representación de struct para modelos activos + + visible union case test properties + visible union case test properties + + Support for try-with in sequence expressions Compatibilidad con try-with en expresiones secuenciales diff --git a/src/Compiler/xlf/FSComp.txt.fr.xlf b/src/Compiler/xlf/FSComp.txt.fr.xlf index d0eb8a412f3..9f918f6e04a 100644 --- a/src/Compiler/xlf/FSComp.txt.fr.xlf +++ b/src/Compiler/xlf/FSComp.txt.fr.xlf @@ -407,6 +407,11 @@ représentation de structure pour les modèles actifs + + visible union case test properties + visible union case test properties + + Support for try-with in sequence expressions Prise en charge de try-with dans les expressions de séquence diff --git a/src/Compiler/xlf/FSComp.txt.it.xlf b/src/Compiler/xlf/FSComp.txt.it.xlf index a1c4c79cf5a..a6a036fc8db 100644 --- a/src/Compiler/xlf/FSComp.txt.it.xlf +++ b/src/Compiler/xlf/FSComp.txt.it.xlf @@ -407,6 +407,11 @@ rappresentazione struct per criteri attivi + + visible union case test properties + visible union case test properties + + Support for try-with in sequence expressions Supporto per try-with nelle espressioni di sequenza diff --git a/src/Compiler/xlf/FSComp.txt.ja.xlf b/src/Compiler/xlf/FSComp.txt.ja.xlf index a1e4157a4de..e49fd904555 100644 --- a/src/Compiler/xlf/FSComp.txt.ja.xlf +++ b/src/Compiler/xlf/FSComp.txt.ja.xlf @@ -407,6 +407,11 @@ アクティブなパターンの構造体表現 + + visible union case test properties + visible union case test properties + + Support for try-with in sequence expressions シーケンス式内の try-with のサポート diff --git a/src/Compiler/xlf/FSComp.txt.ko.xlf b/src/Compiler/xlf/FSComp.txt.ko.xlf index 7c4f481d2a2..43c22e4b436 100644 --- a/src/Compiler/xlf/FSComp.txt.ko.xlf +++ b/src/Compiler/xlf/FSComp.txt.ko.xlf @@ -407,6 +407,11 @@ 활성 패턴에 대한 구조체 표현 + + visible union case test properties + visible union case test properties + + Support for try-with in sequence expressions 시퀀스 식에서 try-with 지원 diff --git a/src/Compiler/xlf/FSComp.txt.pl.xlf b/src/Compiler/xlf/FSComp.txt.pl.xlf index cea66cde2e9..ec22b8e59f8 100644 --- a/src/Compiler/xlf/FSComp.txt.pl.xlf +++ b/src/Compiler/xlf/FSComp.txt.pl.xlf @@ -407,6 +407,11 @@ reprezentacja struktury aktywnych wzorców + + visible union case test properties + visible union case test properties + + Support for try-with in sequence expressions Obsługa instrukcji try-with w wyrażeniach sekwencji diff --git a/src/Compiler/xlf/FSComp.txt.pt-BR.xlf b/src/Compiler/xlf/FSComp.txt.pt-BR.xlf index 79c864480fd..eff49c8b8f1 100644 --- a/src/Compiler/xlf/FSComp.txt.pt-BR.xlf +++ b/src/Compiler/xlf/FSComp.txt.pt-BR.xlf @@ -407,6 +407,11 @@ representação estrutural para padrões ativos + + visible union case test properties + visible union case test properties + + Support for try-with in sequence expressions Suporte para try-with em expressões de sequência diff --git a/src/Compiler/xlf/FSComp.txt.ru.xlf b/src/Compiler/xlf/FSComp.txt.ru.xlf index 831c7891388..83d959aa1de 100644 --- a/src/Compiler/xlf/FSComp.txt.ru.xlf +++ b/src/Compiler/xlf/FSComp.txt.ru.xlf @@ -407,6 +407,11 @@ представление структуры для активных шаблонов + + visible union case test properties + visible union case test properties + + Support for try-with in sequence expressions Поддержка try-with в выражениях последовательности diff --git a/src/Compiler/xlf/FSComp.txt.tr.xlf b/src/Compiler/xlf/FSComp.txt.tr.xlf index 9e455903428..31fe6584285 100644 --- a/src/Compiler/xlf/FSComp.txt.tr.xlf +++ b/src/Compiler/xlf/FSComp.txt.tr.xlf @@ -407,6 +407,11 @@ etkin desenler için yapı gösterimi + + visible union case test properties + visible union case test properties + + Support for try-with in sequence expressions Dizi ifadelerinde try-with desteği diff --git a/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf b/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf index 8338b0da896..3134ab3447a 100644 --- a/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf +++ b/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf @@ -407,6 +407,11 @@ 活动模式的结构表示形式 + + visible union case test properties + visible union case test properties + + Support for try-with in sequence expressions 支持在序列表达式中试用 diff --git a/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf b/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf index 5fbdf0f332c..84853d8b252 100644 --- a/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf +++ b/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf @@ -407,6 +407,11 @@ 現用模式的結構表示法 + + visible union case test properties + visible union case test properties + + Support for try-with in sequence expressions 支援循序運算式中的 try-with diff --git a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj index a83d57f55a5..158658af622 100644 --- a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj +++ b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj @@ -181,6 +181,7 @@ + diff --git a/tests/FSharp.Compiler.ComponentTests/Language/DiscriminatedUnionTests.fs b/tests/FSharp.Compiler.ComponentTests/Language/DiscriminatedUnionTests.fs new file mode 100644 index 00000000000..41988c5559c --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/Language/DiscriminatedUnionTests.fs @@ -0,0 +1,73 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +namespace FSharp.Compiler.ComponentTests.Language + +open Xunit +open FSharp.Test.Compiler + +#if NETCOREAPP +module DiscriminatedUnionTests = + + [] + let ``Simple Is* discriminated union properties are visible, proper values are returned`` () = + Fsx """ +type Foo = | Foo of string | Bar +let foo = Foo.Foo "hi" +if not foo.IsFoo then failwith "Should be Foo" +if foo.IsBar then failwith "Should not be Bar" + """ + |> withLangVersionPreview + |> compileExeAndRun + |> shouldSucceed + + [] + let ``Is* discriminated union properties are visible, proper values are returned in recursive namespace, before the definition`` () = + FSharp """ +namespace rec Hello + +module Main = + [] + let main _ = + let foo = Foo.Foo "hi" + if not foo.IsFoo then failwith "Should be Foo" + if foo.IsBar then failwith "Should not be Bar" + 0 + +[] +type Foo = + | Foo of string + | Bar + """ + |> withLangVersionPreview + |> compileExeAndRun + |> shouldSucceed + + + [] + let ``Is* discriminated union properties are visible, proper values are returned in recursive namespace, in SRTP`` () = + FSharp """ +namespace Hello + +[] +type Foo = + | Foo of string + | Bar + +module Main = + + let inline (|HasIsFoo|) x = fun () -> (^a : (member IsFoo: bool) x) + let inline (|HasIsBar|) x = fun () -> (^a : (member IsBar: bool) x) + let getIsFooIsBar (HasIsFoo isFoo & HasIsBar isBar) = (isFoo(), isBar()) + + [] + let main _ = + let foo = Foo.Foo "hi" + let (isFoo, isBar) = getIsFooIsBar foo + if not isFoo then failwith "Should be Foo" + if isBar then failwith "Should not be Bar" + 0 + """ + |> withLangVersionPreview + |> compileExeAndRun + |> shouldSucceed +#endif \ No newline at end of file diff --git a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.debug.bsl b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.debug.bsl index 0faf9512f36..c7b3cf0aa73 100644 --- a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.debug.bsl +++ b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.debug.bsl @@ -4852,6 +4852,7 @@ FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsPropertySetterM FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsRefCell FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsReferencedValue FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsTypeFunction +FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsUnionCaseTester FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsUnresolved FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsValCompiledAsMethod FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean IsValue @@ -4886,6 +4887,7 @@ FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsPropertySet FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsRefCell() FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsReferencedValue() FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsTypeFunction() +FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsUnionCaseTester() FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsUnresolved() FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsValCompiledAsMethod() FSharp.Compiler.Symbols.FSharpMemberOrFunctionOrValue: Boolean get_IsValue() diff --git a/tests/benchmarks/FCSBenchmarks/FCSSourceFiles/Program.fs b/tests/benchmarks/FCSBenchmarks/FCSSourceFiles/Program.fs index 8c21e2dafc3..136897e081b 100644 --- a/tests/benchmarks/FCSBenchmarks/FCSSourceFiles/Program.fs +++ b/tests/benchmarks/FCSBenchmarks/FCSSourceFiles/Program.fs @@ -618,8 +618,8 @@ module Project = __SOURCE_DIRECTORY__ + @"\..\..\..\..\src\Compiler\Checking\InfoReader.fs" __SOURCE_DIRECTORY__ + @"\..\..\..\..\src\Compiler\Checking\NicePrint.fsi" __SOURCE_DIRECTORY__ + @"\..\..\..\..\src\Compiler\Checking\NicePrint.fs" - __SOURCE_DIRECTORY__ + @"\..\..\..\..\src\Compiler\Checking\AugmentWithHashCompare.fsi" - __SOURCE_DIRECTORY__ + @"\..\..\..\..\src\Compiler\Checking\AugmentWithHashCompare.fs" + __SOURCE_DIRECTORY__ + @"\..\..\..\..\src\Compiler\Checking\AugmentTypeDefinitions.fsi" + __SOURCE_DIRECTORY__ + @"\..\..\..\..\src\Compiler\Checking\AugmentTypeDefinitions.fs" __SOURCE_DIRECTORY__ + @"\..\..\..\..\src\Compiler\Checking\NameResolution.fsi" __SOURCE_DIRECTORY__ + @"\..\..\..\..\src\Compiler\Checking\NameResolution.fs" __SOURCE_DIRECTORY__ + @"\..\..\..\..\src\Compiler\Checking\SignatureConformance.fsi" diff --git a/tests/fsharp/core/namespaces/test.fs b/tests/fsharp/core/namespaces/test.fs index 39ab9b066b4..8ef39158533 100644 --- a/tests/fsharp/core/namespaces/test.fs +++ b/tests/fsharp/core/namespaces/test.fs @@ -23,7 +23,17 @@ namespace Hello.Goodbye module X = let x = 1 - + type UnionTypeHiddenWithDiscriminatorsPartlyRevealed = + | A1 + | B1 + | C1 + + module M = + let v = A1.IsA1 + type UnionTypeHiddenWithDiscriminatorsFullyRevealed = + | A1 + | B1 + | C1 namespace Hello.Beatles @@ -135,6 +145,13 @@ namespace rec CheckRecursiveNameResolution4 do Hello.Goodbye.Utils.test "test292jwf" (Test.N.x.V = 4) + module UnionTestsWithSignature = + // Check accessing the *.Is* properties of unions not through a signature + let a = Hello.Goodbye.A + + Hello.Goodbye.Utils.test "vwehlevw1a" a.IsA + Hello.Goodbye.Utils.test "vwehlevw2a" (not a.IsB) + Hello.Goodbye.Utils.test "vwehlevw3a" (not a.IsC) namespace rec CheckRecursiveNameResolution5 diff --git a/tests/fsharp/core/namespaces/test.fsi b/tests/fsharp/core/namespaces/test.fsi index b5c691f5b9e..18e379d8525 100644 --- a/tests/fsharp/core/namespaces/test.fsi +++ b/tests/fsharp/core/namespaces/test.fsi @@ -4,6 +4,16 @@ namespace Hello.Goodbye type A = A | B | C +[] +type UnionTypeHiddenWithDiscriminatorsPartlyRevealed = + member IsA1: bool + +[] +type UnionTypeHiddenWithDiscriminatorsFullyRevealed = + member IsA1: bool + member IsB1: bool + member IsC1: bool + module Utils = begin val failures : string list ref val report_failure : string -> unit diff --git a/tests/fsharp/core/namespaces/test2.fs b/tests/fsharp/core/namespaces/test2.fs index 230ffcca48b..4ad843fb442 100644 --- a/tests/fsharp/core/namespaces/test2.fs +++ b/tests/fsharp/core/namespaces/test2.fs @@ -11,6 +11,13 @@ module M = type C() = member x.P = C() +module UnionTestsWithSignature = + // Check accessing the *.Is* properties of unions through a signature + let a = Hello.Goodbye.A + + Hello.Goodbye.Utils.test "vwehlevw1" a.IsA + Hello.Goodbye.Utils.test "vwehlevw2" (not a.IsB) + Hello.Goodbye.Utils.test "vwehlevw3" (not a.IsC) #if TESTS_AS_APP let RUN() = !Hello.Goodbye.Utils.failures diff --git a/tests/service/Common.fs b/tests/service/Common.fs index 4f24b831d2c..a8d4782de0d 100644 --- a/tests/service/Common.fs +++ b/tests/service/Common.fs @@ -85,8 +85,8 @@ let mkProjectCommandLineArgsSilent (dllName, fileNames) = yield "--define:DEBUG" #if NETCOREAPP yield "--targetprofile:netcore" - yield "--langversion:preview" #endif + yield "--langversion:preview" yield "--optimize-" yield "--out:" + dllName yield "--doc:test.xml" diff --git a/tests/service/ExprTests.fs b/tests/service/ExprTests.fs index b2679c8863c..4c5ffb7c829 100644 --- a/tests/service/ExprTests.fs +++ b/tests/service/ExprTests.fs @@ -781,7 +781,11 @@ let ``Test Unoptimized Declarations Project1`` () = "let downwardForLoop(unitVar0) = let mutable a: Microsoft.FSharp.Core.int = 1 in (for-loop; a) @ (79,16--79,17)"; "let quotationTest1(unitVar0) = quote(Operators.op_Addition (fun arg0_0 -> fun arg1_0 -> LanguagePrimitives.AdditionDynamic (arg0_0,arg1_0),1,1)) @ (83,24--83,35)"; "let quotationTest2(v) = quote(Operators.op_Addition (fun arg0_0 -> fun arg1_0 -> LanguagePrimitives.AdditionDynamic (arg0_0,arg1_0),ExtraTopLevelOperators.SpliceExpression (v),1)) @ (84,24--84,36)"; - "type RecdType"; "type UnionType"; "type ClassWithEventsAndProperties"; + "type RecdType"; "type UnionType"; + "member get_IsCase1(this) (unitArg) = (if this.IsCase1 then True else False) @ (87,5--87,14)"; + "member get_IsCase2(this) (unitArg) = (if this.IsCase2 then True else False) @ (87,5--87,14)"; + "member get_IsCase3(this) (unitArg) = (if this.IsCase3 then True else False) @ (87,5--87,14)"; + "type ClassWithEventsAndProperties"; "member .ctor(unitVar0) = (new Object(); (this.ev <- new FSharpEvent`1(()); ())) @ (89,5--89,33)"; "member .cctor(unitVar) = (sev <- new FSharpEvent`1(()); ()) @ (91,11--91,35)"; "member get_InstanceProperty(x) (unitVar1) = (x.ev.Trigger(1); 1) @ (92,32--92,48)"; @@ -916,7 +920,11 @@ let ``Test Optimized Declarations Project1`` () = "let downwardForLoop(unitVar0) = let mutable a: Microsoft.FSharp.Core.int = 1 in (for-loop; a) @ (79,16--79,17)"; "let quotationTest1(unitVar0) = quote(Operators.op_Addition (fun arg0_0 -> fun arg1_0 -> LanguagePrimitives.AdditionDynamic (arg0_0,arg1_0),1,1)) @ (83,24--83,35)"; "let quotationTest2(v) = quote(Operators.op_Addition (fun arg0_0 -> fun arg1_0 -> LanguagePrimitives.AdditionDynamic (arg0_0,arg1_0),ExtraTopLevelOperators.SpliceExpression (v),1)) @ (84,24--84,36)"; - "type RecdType"; "type UnionType"; "type ClassWithEventsAndProperties"; + "type RecdType"; "type UnionType"; + "member get_IsCase1(this) (unitArg) = (if this.IsCase1 then True else False) @ (87,5--87,14)"; + "member get_IsCase2(this) (unitArg) = (if this.IsCase2 then True else False) @ (87,5--87,14)"; + "member get_IsCase3(this) (unitArg) = (if this.IsCase3 then True else False) @ (87,5--87,14)"; + "type ClassWithEventsAndProperties"; "member .ctor(unitVar0) = (new Object(); (this.ev <- new FSharpEvent`1(()); ())) @ (89,5--89,33)"; "member .cctor(unitVar) = (sev <- new FSharpEvent`1(()); ()) @ (91,11--91,35)"; "member get_InstanceProperty(x) (unitVar1) = (x.ev.Trigger(1); 1) @ (92,32--92,48)"; @@ -3417,7 +3425,9 @@ let ``Test ProjectForWitnesses2`` () = "member get_Zero(unitVar0) = {x = 0; y = 0} @ (6,25--6,37)"; "member Neg(p) = {x = Operators.op_UnaryNegation (fun arg0_0 -> LanguagePrimitives.UnaryNegationDynamic (arg0_0),p.x); y = Operators.op_UnaryNegation (fun arg0_0 -> LanguagePrimitives.UnaryNegationDynamic (arg0_0),p.y)} @ (7,34--7,56)"; "member op_Addition(p1,p2) = {x = Operators.op_Addition (fun arg0_0 -> fun arg1_0 -> LanguagePrimitives.AdditionDynamic (arg0_0,arg1_0),p1.x,p2.x); y = Operators.op_Addition (fun arg0_0 -> fun arg1_0 -> LanguagePrimitives.AdditionDynamic (arg0_0,arg1_0),p1.y,p2.y)} @ (8,33--8,68)"; - "type MyNumber"; "member get_Zero(unitVar0) = MyNumber(0) @ (12,25--12,35)"; + "type MyNumber"; + "member get_IsMyNumber(this) (unitArg) = (if this.IsMyNumber then True else False) @ (10,5--10,13)"; + "member get_Zero(unitVar0) = MyNumber(0) @ (12,25--12,35)"; "member op_Addition(_arg1,_arg2) = let x: Microsoft.FSharp.Core.int = _arg1.Item in let y: Microsoft.FSharp.Core.int = _arg2.Item in MyNumber(Operators.op_Addition (fun arg0_0 -> fun arg1_0 -> LanguagePrimitives.AdditionDynamic (arg0_0,arg1_0),x,y)) @ (13,23--13,33)"; "member DivideByInt(_arg3,i) = let x: Microsoft.FSharp.Core.int = _arg3.Item in MyNumber(Operators.op_Division (fun arg0_0 -> fun arg1_0 -> LanguagePrimitives.DivisionDynamic (arg0_0,arg1_0),x,i)) @ (15,31--15,41)"; "type MyNumberWrapper"] diff --git a/tests/service/ProjectAnalysisTests.fs b/tests/service/ProjectAnalysisTests.fs index 0ee58b1898f..902e6126fe0 100644 --- a/tests/service/ProjectAnalysisTests.fs +++ b/tests/service/ProjectAnalysisTests.fs @@ -707,14 +707,17 @@ let ``Test project2 all symbols in signature`` () = let wholeProjectResults = checker.ParseAndCheckProject(Project2.options) |> Async.RunImmediate let allSymbols = allSymbolsInEntities true wholeProjectResults.AssemblySignature.Entities - [ for x in allSymbols -> x.ToString() ] - |> shouldEqual - ["M"; "val c"; "val GenericFunction"; "generic parameter T"; - "DUWithNormalFields"; "DU1"; "field Item1"; "field Item2"; "DU2"; - "field Item1"; "field Item2"; "D"; "field Item1"; "field Item2"; - "DUWithNamedFields"; "DU"; "field x"; "field y"; "GenericClass`1"; - "generic parameter T"; "member .ctor"; "member GenericMethod"; - "generic parameter U"] + let r = [ for x in allSymbols -> x.ToString() ] |> List.sort + + let e = ["M"; "val c"; "val GenericFunction"; "generic parameter T"; + "DUWithNormalFields"; "member get_IsD"; "member get_IsDU1"; "member get_IsDU2"; + "property IsD"; "property IsDU1"; "property IsDU2"; "DU1"; "field Item1"; + "field Item2"; "DU2"; "field Item1"; "field Item2"; "D"; "field Item1"; + "field Item2"; "DUWithNamedFields"; "member get_IsDU"; "property IsDU"; "DU"; + "field x"; "field y"; "GenericClass`1"; "generic parameter T"; "member .ctor"; + "member GenericMethod"; "generic parameter U"] |> List.sort + + shouldEqual e r [] let ``Test project2 all uses of all signature symbols`` () = @@ -732,6 +735,14 @@ let ``Test project2 all uses of all signature symbols`` () = ("generic parameter T", [("file1", ((22, 23), (22, 25))); ("file1", ((22, 30), (22, 32))); ("file1", ((22, 45), (22, 47))); ("file1", ((22, 50), (22, 52)))]); + ("member get_IsD", []); + ("member get_IsDU", []); + ("member get_IsDU1", []); + ("member get_IsDU2", []); + ("property IsD", []); + ("property IsDU", []); + ("property IsDU1", []); + ("property IsDU2", []); ("DUWithNormalFields", [("file1", ((3, 5), (3, 23)))]); ("DU1", [("file1", ((4, 6), (4, 9))); ("file1", ((8, 8), (8, 11)))]); ("field Item1", []); ("field Item2", []);