From 0ce37522989795f0d206a1e923db01fd8d68d3f2 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Tue, 5 Jun 2018 16:42:01 +1000 Subject: [PATCH 01/92] Helper function for FastGenericEqualityComparerTable --- src/fsharp/FSharp.Core/prim-types.fs | 42 ++++++++++++++++------------ 1 file changed, 24 insertions(+), 18 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index d04a8f8b45c..08e74cda169 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -2112,27 +2112,33 @@ namespace Microsoft.FSharp.Core let Float32IEquality = MakeGenericEqualityComparer() let DecimalIEquality = MakeGenericEqualityComparer() + let tryGetFastGenericEqualityComparerTable (ty:Type) = + match ty with + | ty when ty.Equals typeof -> box BoolIEquality + | ty when ty.Equals typeof -> box ByteIEquality + | ty when ty.Equals typeof -> box Int32IEquality + | ty when ty.Equals typeof -> box UInt32IEquality + | ty when ty.Equals typeof -> box CharIEquality + | ty when ty.Equals typeof -> box SByteIEquality + | ty when ty.Equals typeof -> box Int16IEquality + | ty when ty.Equals typeof -> box Int64IEquality + | ty when ty.Equals typeof -> box IntPtrIEquality + | ty when ty.Equals typeof -> box UInt16IEquality + | ty when ty.Equals typeof -> box UInt64IEquality + | ty when ty.Equals typeof -> box UIntPtrIEquality + | ty when ty.Equals typeof -> box FloatIEquality + | ty when ty.Equals typeof -> box Float32IEquality + | ty when ty.Equals typeof -> box DecimalIEquality + | ty when ty.Equals typeof -> box StringIEquality + | _ -> null + [] - type FastGenericEqualityComparerTable<'T>() = + type FastGenericEqualityComparerTable<'T>() = static let f : System.Collections.Generic.IEqualityComparer<'T> = - match typeof<'T> with - | ty when ty.Equals(typeof) -> unboxPrim (box BoolIEquality) - | ty when ty.Equals(typeof) -> unboxPrim (box ByteIEquality) - | ty when ty.Equals(typeof) -> unboxPrim (box Int32IEquality) - | ty when ty.Equals(typeof) -> unboxPrim (box UInt32IEquality) - | ty when ty.Equals(typeof) -> unboxPrim (box CharIEquality) - | ty when ty.Equals(typeof) -> unboxPrim (box SByteIEquality) - | ty when ty.Equals(typeof) -> unboxPrim (box Int16IEquality) - | ty when ty.Equals(typeof) -> unboxPrim (box Int64IEquality) - | ty when ty.Equals(typeof) -> unboxPrim (box IntPtrIEquality) - | ty when ty.Equals(typeof) -> unboxPrim (box UInt16IEquality) - | ty when ty.Equals(typeof) -> unboxPrim (box UInt64IEquality) - | ty when ty.Equals(typeof) -> unboxPrim (box UIntPtrIEquality) - | ty when ty.Equals(typeof) -> unboxPrim (box FloatIEquality) - | ty when ty.Equals(typeof) -> unboxPrim (box Float32IEquality) - | ty when ty.Equals(typeof) -> unboxPrim (box DecimalIEquality) - | ty when ty.Equals(typeof) -> unboxPrim (box StringIEquality) + match tryGetFastGenericEqualityComparerTable typeof<'T> with + | :? System.Collections.Generic.IEqualityComparer<'T> as comp -> comp | _ -> MakeGenericEqualityComparer<'T>() + static member Function : System.Collections.Generic.IEqualityComparer<'T> = f let FastGenericEqualityComparerFromTable<'T> = FastGenericEqualityComparerTable<'T>.Function From 9921f457db99e73dc2d88218ee0fec42adc44d53 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Tue, 5 Jun 2018 17:37:55 +1000 Subject: [PATCH 02/92] Use the default equality comparer where applicable --- src/fsharp/FSharp.Core/prim-types.fs | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index 08e74cda169..418adde82b6 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -2132,12 +2132,23 @@ namespace Microsoft.FSharp.Core | ty when ty.Equals typeof -> box StringIEquality | _ -> null + let canUseDefaultEqualityComparer (ty:Type) = + // avoid any types that need special handling in GenericEqualityObj + true + && ty.IsSealed // covers enum and value types + && not (typeof.IsAssignableFrom ty) + && not ty.IsArray + [] type FastGenericEqualityComparerTable<'T>() = static let f : System.Collections.Generic.IEqualityComparer<'T> = - match tryGetFastGenericEqualityComparerTable typeof<'T> with + let ty = typeof<'T> + match tryGetFastGenericEqualityComparerTable ty with | :? System.Collections.Generic.IEqualityComparer<'T> as comp -> comp - | _ -> MakeGenericEqualityComparer<'T>() + | _ -> + if canUseDefaultEqualityComparer ty + then unboxPrim (box System.Collections.Generic.EqualityComparer<'T>.Default) + else MakeGenericEqualityComparer<'T>() static member Function : System.Collections.Generic.IEqualityComparer<'T> = f From 20401589d6aeb5577cfde9aa3b6dcbce3e4c1ed3 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Tue, 5 Jun 2018 19:29:58 +1000 Subject: [PATCH 03/92] Avoid calls to GenericEqualityObj for known types --- src/fsharp/FSharp.Core/prim-types.fs | 56 +++++++++++++++++++++++++++- 1 file changed, 54 insertions(+), 2 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index 418adde82b6..0e70a304037 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -1532,12 +1532,63 @@ namespace Microsoft.FSharp.Core override iec.Equals(x:obj,y:obj) = GenericEqualityObj true iec (x,y) // ER Semantics override iec.GetHashCode(x:obj) = raise (InvalidOperationException (SR.GetString(SR.notUsedForHashing))) } + type IERorPER = interface end + type ER = inherit IERorPER + type PER = inherit IERorPER + + type GenericEqualityTCall<'T> = delegate of 'T * 'T -> bool + + let tryGetGenericEqualityTCall (er:bool) (ty:Type) : obj = + match er, ty with + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> System.String.Equals((# "" x : string #),(# "" y : string #)))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> System.Decimal.op_Equality((# "" x:decimal #), (# "" y:decimal #)))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall(fun x y -> (# "ceq" x y : bool #))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | false, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | false, ty when ty.Equals typeof-> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | true, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> + if not (# "ceq" x x : bool #) && not (# "ceq" y y : bool #) then + true + else + (# "ceq" x y : bool #))) + | true, ty when ty.Equals typeof -> box (GenericEqualityTCall(fun x y -> + if not (# "ceq" x x : bool #) && not (# "ceq" y y : bool #) then + true + else + (# "ceq" x y : bool #))) + | _ -> null + + type GenericEqualityT<'T, 'ERorPER when 'ERorPER :> IERorPER> private () = + static let f : GenericEqualityTCall<'T> = + let er = + if typeof<'ERorPER>.Equals typeof then true + elif typeof<'ERorPER>.Equals typeof then false + else raise (Exception "logic error") + match tryGetGenericEqualityTCall er typeof<'T> with + | :? GenericEqualityTCall<'T> as call -> call + | _ -> + if er + then GenericEqualityTCall<'T>(fun x y -> GenericEqualityObj true fsEqualityComparerNoHashingER (box x, box y)) + else GenericEqualityTCall<'T>(fun x y -> GenericEqualityObj false fsEqualityComparerNoHashingPER (box x, box y)) + + static member Function = f + /// Implements generic equality between two values, with PER semantics for NaN (so equality on two NaN values returns false) // // The compiler optimizer is aware of this function (see use of generic_equality_per_inner_vref in opt.fs) // and devirtualizes calls to it based on "T". let GenericEqualityIntrinsic (x : 'T) (y : 'T) : bool = - GenericEqualityObj false fsEqualityComparerNoHashingPER ((box x), (box y)) + GenericEqualityT<'T, PER>.Function.Invoke (x, y) /// Implements generic equality between two values, with ER semantics for NaN (so equality on two NaN values returns true) // @@ -1546,7 +1597,7 @@ namespace Microsoft.FSharp.Core // The compiler optimizer is aware of this function (see use of generic_equality_er_inner_vref in opt.fs) // and devirtualizes calls to it based on "T". let GenericEqualityERIntrinsic (x : 'T) (y : 'T) : bool = - GenericEqualityObj true fsEqualityComparerNoHashingER ((box x), (box y)) + GenericEqualityT<'T, ER>.Function.Invoke (x, y) /// Implements generic equality between two values using "comp" for recursive calls. // @@ -2113,6 +2164,7 @@ namespace Microsoft.FSharp.Core let DecimalIEquality = MakeGenericEqualityComparer() let tryGetFastGenericEqualityComparerTable (ty:Type) = + // TODO: Remove the ones that don't have special handling and thus just used default match ty with | ty when ty.Equals typeof -> box BoolIEquality | ty when ty.Equals typeof -> box ByteIEquality From de7b48486ca90baa0fe570d0f2e312269488ab6a Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Wed, 6 Jun 2018 15:54:12 +1000 Subject: [PATCH 04/92] Avoid boxing in the "standard" use of GenericEqualityWithComparerIntrinsic --- src/fsharp/FSharp.Core/prim-types.fs | 66 ++++++++++++++-------------- 1 file changed, 33 insertions(+), 33 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index 0e70a304037..ab5dc099a4a 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -771,6 +771,35 @@ namespace Microsoft.FSharp.Core let anyToStringShowingNull x = anyToString "null" x module HashCompare = + let defaultHashNodes = 18 + + /// The implementation of IEqualityComparer, using depth-limited for hashing and PER semantics for NaN equality. + type CountLimitedHasherPER(sz:int) = + [] + val mutable nodeCount : int + + member x.Fresh() = + if (System.Threading.Interlocked.CompareExchange(&(x.nodeCount), sz, 0) = 0) then + x + else + new CountLimitedHasherPER(sz) + + interface IEqualityComparer + + /// The implementation of IEqualityComparer, using unlimited depth for hashing and ER semantics for NaN equality. + type UnlimitedHasherER() = + interface IEqualityComparer + + /// The implementation of IEqualityComparer, using unlimited depth for hashing and PER semantics for NaN equality. + type UnlimitedHasherPER() = + interface IEqualityComparer + + + /// The unique object for unlimited depth for hashing and ER semantics for equality. + let fsEqualityComparerUnlimitedHashingER = UnlimitedHasherER() + + /// The unique object for unlimited depth for hashing and PER semantics for equality. + let fsEqualityComparerUnlimitedHashingPER = UnlimitedHasherPER() //------------------------------------------------------------------------- // LanguagePrimitives.HashCompare: Physical Equality @@ -1605,7 +1634,10 @@ namespace Microsoft.FSharp.Core // and devirtualizes calls to it based on "T", and under the assumption that "comp" // is either fsEqualityComparerNoHashingER or fsEqualityComparerNoHashingPER. let GenericEqualityWithComparerIntrinsic (comp : System.Collections.IEqualityComparer) (x : 'T) (y : 'T) : bool = - comp.Equals((box x),(box y)) + if obj.ReferenceEquals (comp, fsEqualityComparerUnlimitedHashingPER) then + GenericEqualityT<'T, PER>.Function.Invoke (x, y) + else + comp.Equals (box x, box y) /// Implements generic equality between two values, with ER semantics for NaN (so equality on two NaN values returns true) @@ -1696,38 +1728,6 @@ namespace Microsoft.FSharp.Core //------------------------------------------------------------------------- // LanguagePrimitives.HashCompare: HASHING. //------------------------------------------------------------------------- - - - - let defaultHashNodes = 18 - - /// The implementation of IEqualityComparer, using depth-limited for hashing and PER semantics for NaN equality. - type CountLimitedHasherPER(sz:int) = - [] - val mutable nodeCount : int - - member x.Fresh() = - if (System.Threading.Interlocked.CompareExchange(&(x.nodeCount), sz, 0) = 0) then - x - else - new CountLimitedHasherPER(sz) - - interface IEqualityComparer - - /// The implementation of IEqualityComparer, using unlimited depth for hashing and ER semantics for NaN equality. - type UnlimitedHasherER() = - interface IEqualityComparer - - /// The implementation of IEqualityComparer, using unlimited depth for hashing and PER semantics for NaN equality. - type UnlimitedHasherPER() = - interface IEqualityComparer - - - /// The unique object for unlimited depth for hashing and ER semantics for equality. - let fsEqualityComparerUnlimitedHashingER = UnlimitedHasherER() - - /// The unique object for unlimited depth for hashing and PER semantics for equality. - let fsEqualityComparerUnlimitedHashingPER = UnlimitedHasherPER() let inline HashCombine nr x y = (x <<< 1) + y + 631 * nr From 0f1f3e896798689cdf7d1b5074cce0ce7a917704 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Wed, 6 Jun 2018 16:21:18 +1000 Subject: [PATCH 05/92] Added method to avoid tail calls --- src/fsharp/FSharp.Core/prim-types.fs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index ab5dc099a4a..d275ef1f10a 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -1612,12 +1612,16 @@ namespace Microsoft.FSharp.Core static member Function = f + // The FSharp compiler will not insert a tail call when this is used (this might be "fixed" + // in a future release) + let inline avoid_tail_call f = match f () with true -> true | _ -> false + /// Implements generic equality between two values, with PER semantics for NaN (so equality on two NaN values returns false) // // The compiler optimizer is aware of this function (see use of generic_equality_per_inner_vref in opt.fs) // and devirtualizes calls to it based on "T". let GenericEqualityIntrinsic (x : 'T) (y : 'T) : bool = - GenericEqualityT<'T, PER>.Function.Invoke (x, y) + avoid_tail_call (fun () -> GenericEqualityT<'T, PER>.Function.Invoke (x, y)) /// Implements generic equality between two values, with ER semantics for NaN (so equality on two NaN values returns true) // @@ -1626,7 +1630,7 @@ namespace Microsoft.FSharp.Core // The compiler optimizer is aware of this function (see use of generic_equality_er_inner_vref in opt.fs) // and devirtualizes calls to it based on "T". let GenericEqualityERIntrinsic (x : 'T) (y : 'T) : bool = - GenericEqualityT<'T, ER>.Function.Invoke (x, y) + avoid_tail_call (fun () -> GenericEqualityT<'T, ER>.Function.Invoke (x, y)) /// Implements generic equality between two values using "comp" for recursive calls. // @@ -1635,7 +1639,7 @@ namespace Microsoft.FSharp.Core // is either fsEqualityComparerNoHashingER or fsEqualityComparerNoHashingPER. let GenericEqualityWithComparerIntrinsic (comp : System.Collections.IEqualityComparer) (x : 'T) (y : 'T) : bool = if obj.ReferenceEquals (comp, fsEqualityComparerUnlimitedHashingPER) then - GenericEqualityT<'T, PER>.Function.Invoke (x, y) + avoid_tail_call (fun () -> GenericEqualityT<'T, PER>.Function.Invoke (x, y)) else comp.Equals (box x, box y) From 24325dd44fab0fc907fafe5c95bdb0f1a32cd067 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Wed, 6 Jun 2018 17:03:57 +1000 Subject: [PATCH 06/92] Implemented hashing --- src/fsharp/FSharp.Core/prim-types.fs | 66 ++++++++++++++++++++-------- 1 file changed, 48 insertions(+), 18 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index d275ef1f10a..7af39de7969 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -1642,7 +1642,6 @@ namespace Microsoft.FSharp.Core avoid_tail_call (fun () -> GenericEqualityT<'T, PER>.Function.Invoke (x, y)) else comp.Equals (box x, box y) - /// Implements generic equality between two values, with ER semantics for NaN (so equality on two NaN values returns true) // @@ -1843,11 +1842,54 @@ namespace Microsoft.FSharp.Core override iec.Equals(x:obj,y:obj) = GenericEqualityObj false iec (x,y) override iec.GetHashCode(x:obj) = GenericHashParamObj iec x + /// Direct call to GetHashCode on the string type + let inline HashString (s:string) = + match s with + | null -> 0 + | _ -> (# "call instance int32 [mscorlib]System.String::GetHashCode()" s : int #) + + // from mscorlib v4.0.30319 + let inline HashChar (x:char) = (# "or" (# "shl" x 16 : int #) x : int #) + let inline HashSByte (x:sbyte) = (# "xor" (# "shl" x 8 : int #) x : int #) + let inline HashInt16 (x:int16) = (# "or" (# "conv.u2" x : int #) (# "shl" x 16 : int #) : int #) + let inline HashInt64 (x:int64) = (# "xor" (# "conv.i4" x : int #) (# "conv.i4" (# "shr" x 32 : int #) : int #) : int #) + let inline HashUInt64 (x:uint64) = (# "xor" (# "conv.i4" x : int #) (# "conv.i4" (# "shr.un" x 32 : int #) : int #) : int #) + let inline HashIntPtr (x:nativeint) = (# "conv.i4" (# "conv.u8" x : uint64 #) : int #) + let inline HashUIntPtr (x:unativeint) = (# "and" (# "conv.i4" (# "conv.u8" x : uint64 #) : int #) 0x7fffffff : int #) + + type GenericHashTCall<'T> = delegate of 'T -> int + + let tryGetGenericHashTCall (ty:Type) : obj = + match ty with + | ty when ty.Equals typeof -> box (GenericHashTCall (fun x -> (# "" x : int #))) + | ty when ty.Equals typeof -> box (GenericHashTCall (fun x -> (# "" x : int #))) + | ty when ty.Equals typeof -> box (GenericHashTCall (fun x -> (# "" x : int #))) + | ty when ty.Equals typeof -> box (GenericHashTCall (fun x -> (# "" x : int #))) + | ty when ty.Equals typeof -> box (GenericHashTCall HashChar) + | ty when ty.Equals typeof -> box (GenericHashTCall HashSByte) + | ty when ty.Equals typeof -> box (GenericHashTCall HashInt16) + | ty when ty.Equals typeof -> box (GenericHashTCall HashInt64) + | ty when ty.Equals typeof -> box (GenericHashTCall HashUInt64) + | ty when ty.Equals typeof -> box (GenericHashTCall HashIntPtr) + | ty when ty.Equals typeof -> box (GenericHashTCallHashUIntPtr) + | ty when ty.Equals typeof -> box (GenericHashTCall (fun x -> (# "" x : int #))) + | ty when ty.Equals typeof -> box (GenericHashTCall HashString) + | _ -> null + + type GenericHashT<'T> private () = + static let f : GenericHashTCall<'T> = + match tryGetGenericHashTCall typeof<'T> with + | :? GenericHashTCall<'T> as call -> call + | _ -> GenericHashTCall<'T>(fun x -> GenericHashParamObj fsEqualityComparerUnlimitedHashingPER (box x)) + + static member Function = f + /// Intrinsic for calls to depth-unlimited structural hashing that were not optimized by static conditionals. // // NOTE: The compiler optimizer is aware of this function (see uses of generic_hash_inner_vref in opt.fs) // and devirtualizes calls to it based on type "T". - let GenericHashIntrinsic input = GenericHashParamObj fsEqualityComparerUnlimitedHashingPER (box input) + let GenericHashIntrinsic input = + GenericHashT<'T>.Function.Invoke input /// Intrinsic for calls to depth-limited structural hashing that were not optimized by static conditionals. let LimitedGenericHashIntrinsic limit input = GenericHashParamObj (CountLimitedHasherPER(limit)) (box input) @@ -1860,23 +1902,11 @@ namespace Microsoft.FSharp.Core // NOTE: The compiler optimizer is aware of this function (see uses of generic_hash_withc_inner_vref in opt.fs) // and devirtualizes calls to it based on type "T". let GenericHashWithComparerIntrinsic<'T> (comp : System.Collections.IEqualityComparer) (input : 'T) : int = - GenericHashParamObj comp (box input) + if obj.ReferenceEquals (comp, fsEqualityComparerUnlimitedHashingPER) then + GenericHashT<'T>.Function.Invoke input + else + GenericHashParamObj comp (box input) - /// Direct call to GetHashCode on the string type - let inline HashString (s:string) = - match s with - | null -> 0 - | _ -> (# "call instance int32 [mscorlib]System.String::GetHashCode()" s : int #) - - // from mscorlib v4.0.30319 - let inline HashChar (x:char) = (# "or" (# "shl" x 16 : int #) x : int #) - let inline HashSByte (x:sbyte) = (# "xor" (# "shl" x 8 : int #) x : int #) - let inline HashInt16 (x:int16) = (# "or" (# "conv.u2" x : int #) (# "shl" x 16 : int #) : int #) - let inline HashInt64 (x:int64) = (# "xor" (# "conv.i4" x : int #) (# "conv.i4" (# "shr" x 32 : int #) : int #) : int #) - let inline HashUInt64 (x:uint64) = (# "xor" (# "conv.i4" x : int #) (# "conv.i4" (# "shr.un" x 32 : int #) : int #) : int #) - let inline HashIntPtr (x:nativeint) = (# "conv.i4" (# "conv.u8" x : uint64 #) : int #) - let inline HashUIntPtr (x:unativeint) = (# "and" (# "conv.i4" (# "conv.u8" x : uint64 #) : int #) 0x7fffffff : int #) - /// Core entry into structural hashing for either limited or unlimited hashing. // // "iec" is assumed to be either fsEqualityComparerUnlimitedHashingER, fsEqualityComparerUnlimitedHashingPER or From 178497e6c366277c3ba19172401c1eb132d52f55 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Wed, 6 Jun 2018 17:24:41 +1000 Subject: [PATCH 07/92] Additional use of EqualityComparer.Default --- src/fsharp/FSharp.Core/prim-types.fs | 39 ++++++++++++++++------------ 1 file changed, 23 insertions(+), 16 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index 7af39de7969..57379a4e536 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -1565,6 +1565,18 @@ namespace Microsoft.FSharp.Core type ER = inherit IERorPER type PER = inherit IERorPER + let canUseDefaultEqualityComparer (ty:Type) = + // avoid any types that need special handling in GenericEqualityObj + true + && ty.IsSealed // covers enum and value types + && not (typeof.IsAssignableFrom ty) + && not ty.IsArray + + // The FSharp compiler will not insert a tail call when this is used (this might be "fixed" + // in a future release) + let inline avoid_tail_call f = + match f () with true -> true | _ -> false + type GenericEqualityTCall<'T> = delegate of 'T * 'T -> bool let tryGetGenericEqualityTCall (er:bool) (ty:Type) : obj = @@ -1605,17 +1617,16 @@ namespace Microsoft.FSharp.Core else raise (Exception "logic error") match tryGetGenericEqualityTCall er typeof<'T> with | :? GenericEqualityTCall<'T> as call -> call - | _ -> - if er - then GenericEqualityTCall<'T>(fun x y -> GenericEqualityObj true fsEqualityComparerNoHashingER (box x, box y)) - else GenericEqualityTCall<'T>(fun x y -> GenericEqualityObj false fsEqualityComparerNoHashingPER (box x, box y)) + | _ when canUseDefaultEqualityComparer typeof<'T> -> + let comparer = System.Collections.Generic.EqualityComparer<'T>.Default + GenericEqualityTCall<'T>(fun x y -> avoid_tail_call (fun () -> comparer.Equals (x, y))) + | _ when er -> + GenericEqualityTCall<'T>(fun x y -> GenericEqualityObj true fsEqualityComparerNoHashingER (box x, box y)) + | _ -> + GenericEqualityTCall<'T>(fun x y -> GenericEqualityObj false fsEqualityComparerNoHashingPER (box x, box y)) static member Function = f - // The FSharp compiler will not insert a tail call when this is used (this might be "fixed" - // in a future release) - let inline avoid_tail_call f = match f () with true -> true | _ -> false - /// Implements generic equality between two values, with PER semantics for NaN (so equality on two NaN values returns false) // // The compiler optimizer is aware of this function (see use of generic_equality_per_inner_vref in opt.fs) @@ -1880,6 +1891,9 @@ namespace Microsoft.FSharp.Core static let f : GenericHashTCall<'T> = match tryGetGenericHashTCall typeof<'T> with | :? GenericHashTCall<'T> as call -> call + | _ when canUseDefaultEqualityComparer typeof<'T> -> + let comparer = System.Collections.Generic.EqualityComparer<'T>.Default + GenericHashTCall<'T> comparer.GetHashCode | _ -> GenericHashTCall<'T>(fun x -> GenericHashParamObj fsEqualityComparerUnlimitedHashingPER (box x)) static member Function = f @@ -2218,13 +2232,6 @@ namespace Microsoft.FSharp.Core | ty when ty.Equals typeof -> box StringIEquality | _ -> null - let canUseDefaultEqualityComparer (ty:Type) = - // avoid any types that need special handling in GenericEqualityObj - true - && ty.IsSealed // covers enum and value types - && not (typeof.IsAssignableFrom ty) - && not ty.IsArray - [] type FastGenericEqualityComparerTable<'T>() = static let f : System.Collections.Generic.IEqualityComparer<'T> = @@ -2232,7 +2239,7 @@ namespace Microsoft.FSharp.Core match tryGetFastGenericEqualityComparerTable ty with | :? System.Collections.Generic.IEqualityComparer<'T> as comp -> comp | _ -> - if canUseDefaultEqualityComparer ty + if HashCompare.canUseDefaultEqualityComparer ty then unboxPrim (box System.Collections.Generic.EqualityComparer<'T>.Default) else MakeGenericEqualityComparer<'T>() From 7630841fac83e133c7af4ff6810125a0fab67c90 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Wed, 6 Jun 2018 17:46:52 +1000 Subject: [PATCH 08/92] Consistent naming --- src/fsharp/FSharp.Core/prim-types.fs | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index 57379a4e536..6c9e5f6a859 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -1574,8 +1574,9 @@ namespace Microsoft.FSharp.Core // The FSharp compiler will not insert a tail call when this is used (this might be "fixed" // in a future release) - let inline avoid_tail_call f = - match f () with true -> true | _ -> false + let inline avoid_tail_call_bool f = match f () with true -> true | _ -> false + let inline avoid_tail_call_int f = 0 + f () + type GenericEqualityTCall<'T> = delegate of 'T * 'T -> bool @@ -1619,7 +1620,7 @@ namespace Microsoft.FSharp.Core | :? GenericEqualityTCall<'T> as call -> call | _ when canUseDefaultEqualityComparer typeof<'T> -> let comparer = System.Collections.Generic.EqualityComparer<'T>.Default - GenericEqualityTCall<'T>(fun x y -> avoid_tail_call (fun () -> comparer.Equals (x, y))) + GenericEqualityTCall<'T>(fun x y -> avoid_tail_call_bool (fun () -> comparer.Equals (x, y))) | _ when er -> GenericEqualityTCall<'T>(fun x y -> GenericEqualityObj true fsEqualityComparerNoHashingER (box x, box y)) | _ -> @@ -1632,7 +1633,7 @@ namespace Microsoft.FSharp.Core // The compiler optimizer is aware of this function (see use of generic_equality_per_inner_vref in opt.fs) // and devirtualizes calls to it based on "T". let GenericEqualityIntrinsic (x : 'T) (y : 'T) : bool = - avoid_tail_call (fun () -> GenericEqualityT<'T, PER>.Function.Invoke (x, y)) + avoid_tail_call_bool (fun () -> GenericEqualityT<'T, PER>.Function.Invoke (x, y)) /// Implements generic equality between two values, with ER semantics for NaN (so equality on two NaN values returns true) // @@ -1641,7 +1642,7 @@ namespace Microsoft.FSharp.Core // The compiler optimizer is aware of this function (see use of generic_equality_er_inner_vref in opt.fs) // and devirtualizes calls to it based on "T". let GenericEqualityERIntrinsic (x : 'T) (y : 'T) : bool = - avoid_tail_call (fun () -> GenericEqualityT<'T, ER>.Function.Invoke (x, y)) + avoid_tail_call_bool (fun () -> GenericEqualityT<'T, ER>.Function.Invoke (x, y)) /// Implements generic equality between two values using "comp" for recursive calls. // @@ -1650,7 +1651,7 @@ namespace Microsoft.FSharp.Core // is either fsEqualityComparerNoHashingER or fsEqualityComparerNoHashingPER. let GenericEqualityWithComparerIntrinsic (comp : System.Collections.IEqualityComparer) (x : 'T) (y : 'T) : bool = if obj.ReferenceEquals (comp, fsEqualityComparerUnlimitedHashingPER) then - avoid_tail_call (fun () -> GenericEqualityT<'T, PER>.Function.Invoke (x, y)) + avoid_tail_call_bool (fun () -> GenericEqualityT<'T, PER>.Function.Invoke (x, y)) else comp.Equals (box x, box y) @@ -1893,8 +1894,9 @@ namespace Microsoft.FSharp.Core | :? GenericHashTCall<'T> as call -> call | _ when canUseDefaultEqualityComparer typeof<'T> -> let comparer = System.Collections.Generic.EqualityComparer<'T>.Default - GenericHashTCall<'T> comparer.GetHashCode - | _ -> GenericHashTCall<'T>(fun x -> GenericHashParamObj fsEqualityComparerUnlimitedHashingPER (box x)) + GenericHashTCall<'T> (fun x -> avoid_tail_call_int (fun () -> comparer.GetHashCode x)) + | _ -> + GenericHashTCall<'T> (fun x -> GenericHashParamObj fsEqualityComparerUnlimitedHashingPER (box x)) static member Function = f @@ -1903,7 +1905,7 @@ namespace Microsoft.FSharp.Core // NOTE: The compiler optimizer is aware of this function (see uses of generic_hash_inner_vref in opt.fs) // and devirtualizes calls to it based on type "T". let GenericHashIntrinsic input = - GenericHashT<'T>.Function.Invoke input + avoid_tail_call_int (fun () -> GenericHashT<'T>.Function.Invoke input) /// Intrinsic for calls to depth-limited structural hashing that were not optimized by static conditionals. let LimitedGenericHashIntrinsic limit input = GenericHashParamObj (CountLimitedHasherPER(limit)) (box input) @@ -1917,7 +1919,7 @@ namespace Microsoft.FSharp.Core // and devirtualizes calls to it based on type "T". let GenericHashWithComparerIntrinsic<'T> (comp : System.Collections.IEqualityComparer) (input : 'T) : int = if obj.ReferenceEquals (comp, fsEqualityComparerUnlimitedHashingPER) then - GenericHashT<'T>.Function.Invoke input + avoid_tail_call_int (fun () -> GenericHashT<'T>.Function.Invoke input) else GenericHashParamObj comp (box input) From eceabbaa4ade8738ba08cbaf801fade7a4c2a6e3 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Thu, 7 Jun 2018 19:33:43 +1000 Subject: [PATCH 09/92] Fixed up by mix up my ERs with my PERs! --- src/fsharp/FSharp.Core/prim-types.fs | 36 ++++++++++++++-------------- 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index 6c9e5f6a859..3b3a59ac3c6 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -1582,28 +1582,28 @@ namespace Microsoft.FSharp.Core let tryGetGenericEqualityTCall (er:bool) (ty:Type) : obj = match er, ty with - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> System.String.Equals((# "" x : string #),(# "" y : string #)))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> System.Decimal.op_Equality((# "" x:decimal #), (# "" y:decimal #)))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall(fun x y -> (# "ceq" x y : bool #))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | false, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | false, ty when ty.Equals typeof-> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | true, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> System.String.Equals((# "" x : string #),(# "" y : string #)))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> System.Decimal.op_Equality((# "" x:decimal #), (# "" y:decimal #)))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | true, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | true, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | false, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> if not (# "ceq" x x : bool #) && not (# "ceq" y y : bool #) then true else (# "ceq" x y : bool #))) - | true, ty when ty.Equals typeof -> box (GenericEqualityTCall(fun x y -> + | false, ty when ty.Equals typeof -> box (GenericEqualityTCall(fun x y -> if not (# "ceq" x x : bool #) && not (# "ceq" y y : bool #) then true else From e8092168f158e7cc4040ef1b8b9d5f660d4188a0 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Thu, 7 Jun 2018 19:36:27 +1000 Subject: [PATCH 10/92] Apply De Morgan's law to make it a bit cleaner --- src/fsharp/FSharp.Core/prim-types.fs | 44 ++++++++++++---------------- 1 file changed, 18 insertions(+), 26 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index 3b3a59ac3c6..7706b6a9d3c 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -1582,32 +1582,24 @@ namespace Microsoft.FSharp.Core let tryGetGenericEqualityTCall (er:bool) (ty:Type) : obj = match er, ty with - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> System.String.Equals((# "" x : string #),(# "" y : string #)))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> System.Decimal.op_Equality((# "" x:decimal #), (# "" y:decimal #)))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | true, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | true, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | false, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> - if not (# "ceq" x x : bool #) && not (# "ceq" y y : bool #) then - true - else - (# "ceq" x y : bool #))) - | false, ty when ty.Equals typeof -> box (GenericEqualityTCall(fun x y -> - if not (# "ceq" x x : bool #) && not (# "ceq" y y : bool #) then - true - else - (# "ceq" x y : bool #))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> System.String.Equals((# "" x : string #),(# "" y : string #)))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> System.Decimal.op_Equality((# "" x:decimal #), (# "" y:decimal #)))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | true, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | true, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | false, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #) || (not ((# "ceq" x x : bool #) || (# "ceq" y y : bool #))))) + | false, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #) || (not ((# "ceq" x x : bool #) || (# "ceq" y y : bool #))))) | _ -> null type GenericEqualityT<'T, 'ERorPER when 'ERorPER :> IERorPER> private () = From 29c2d5172c69e700eb088bcb86f3cd578b97e558 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Fri, 8 Jun 2018 16:50:18 +1000 Subject: [PATCH 11/92] Argh, got the PER and ER mixed up even when I tried to fix. Now good (hopefully!) --- src/fsharp/FSharp.Core/prim-types.fs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index 7706b6a9d3c..f95fc99afe9 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -1577,7 +1577,6 @@ namespace Microsoft.FSharp.Core let inline avoid_tail_call_bool f = match f () with true -> true | _ -> false let inline avoid_tail_call_int f = 0 + f () - type GenericEqualityTCall<'T> = delegate of 'T * 'T -> bool let tryGetGenericEqualityTCall (er:bool) (ty:Type) : obj = @@ -1596,10 +1595,10 @@ namespace Microsoft.FSharp.Core | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | true, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | true, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | false, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #) || (not ((# "ceq" x x : bool #) || (# "ceq" y y : bool #))))) - | false, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #) || (not ((# "ceq" x x : bool #) || (# "ceq" y y : bool #))))) + | false, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | false, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) + | true, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #) || (not ((# "ceq" x x : bool #) || (# "ceq" y y : bool #))))) + | true, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #) || (not ((# "ceq" x x : bool #) || (# "ceq" y y : bool #))))) | _ -> null type GenericEqualityT<'T, 'ERorPER when 'ERorPER :> IERorPER> private () = @@ -1642,8 +1641,10 @@ namespace Microsoft.FSharp.Core // and devirtualizes calls to it based on "T", and under the assumption that "comp" // is either fsEqualityComparerNoHashingER or fsEqualityComparerNoHashingPER. let GenericEqualityWithComparerIntrinsic (comp : System.Collections.IEqualityComparer) (x : 'T) (y : 'T) : bool = - if obj.ReferenceEquals (comp, fsEqualityComparerUnlimitedHashingPER) then + if obj.ReferenceEquals (comp, fsEqualityComparerUnlimitedHashingPER) || obj.ReferenceEquals (comp, fsEqualityComparerNoHashingPER) then avoid_tail_call_bool (fun () -> GenericEqualityT<'T, PER>.Function.Invoke (x, y)) + elif obj.ReferenceEquals (comp, fsEqualityComparerNoHashingER) then + avoid_tail_call_bool (fun () -> GenericEqualityT<'T, ER>.Function.Invoke (x, y)) else comp.Equals (box x, box y) From d9d5a41ac8de78cf8eb2f9d947e2600c2754a7b9 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Fri, 8 Jun 2018 17:11:34 +1000 Subject: [PATCH 12/92] Removed custom delegates by using System.Func --- src/fsharp/FSharp.Core/prim-types.fs | 102 ++++++++++++++------------- 1 file changed, 53 insertions(+), 49 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index f95fc99afe9..d0bc1a5920d 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -1577,7 +1577,7 @@ namespace Microsoft.FSharp.Core let inline avoid_tail_call_bool f = match f () with true -> true | _ -> false let inline avoid_tail_call_int f = 0 + f () - type GenericEqualityTCall<'T> = delegate of 'T * 'T -> bool + type GenericEqualityTCall<'T> = Func<'T, 'T, bool> let tryGetGenericEqualityTCall (er:bool) (ty:Type) : obj = match er, ty with @@ -1601,22 +1601,24 @@ namespace Microsoft.FSharp.Core | true, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #) || (not ((# "ceq" x x : bool #) || (# "ceq" y y : bool #))))) | _ -> null - type GenericEqualityT<'T, 'ERorPER when 'ERorPER :> IERorPER> private () = - static let f : GenericEqualityTCall<'T> = - let er = - if typeof<'ERorPER>.Equals typeof then true - elif typeof<'ERorPER>.Equals typeof then false - else raise (Exception "logic error") - match tryGetGenericEqualityTCall er typeof<'T> with - | :? GenericEqualityTCall<'T> as call -> call - | _ when canUseDefaultEqualityComparer typeof<'T> -> - let comparer = System.Collections.Generic.EqualityComparer<'T>.Default - GenericEqualityTCall<'T>(fun x y -> avoid_tail_call_bool (fun () -> comparer.Equals (x, y))) - | _ when er -> - GenericEqualityTCall<'T>(fun x y -> GenericEqualityObj true fsEqualityComparerNoHashingER (box x, box y)) - | _ -> - GenericEqualityTCall<'T>(fun x y -> GenericEqualityObj false fsEqualityComparerNoHashingPER (box x, box y)) + let getGenericEquality<'T, 'ERorPER when 'ERorPER :> IERorPER> () = + let er = + if typeof<'ERorPER>.Equals typeof then true + elif typeof<'ERorPER>.Equals typeof then false + else raise (Exception "logic error") + + match tryGetGenericEqualityTCall er typeof<'T> with + | :? GenericEqualityTCall<'T> as call -> call + | _ when canUseDefaultEqualityComparer typeof<'T> -> + let comparer = System.Collections.Generic.EqualityComparer<'T>.Default + GenericEqualityTCall<'T> (fun x y -> avoid_tail_call_bool (fun () -> comparer.Equals (x, y))) + | _ when er -> + GenericEqualityTCall<'T> (fun x y -> GenericEqualityObj true fsEqualityComparerNoHashingER (box x, box y)) + | _ -> + GenericEqualityTCall<'T> (fun x y -> GenericEqualityObj false fsEqualityComparerNoHashingPER (box x, box y)) + type GenericEqualityT<'T, 'ERorPER when 'ERorPER :> IERorPER> private () = + static let f = getGenericEquality<'T, 'ERorPER> () static member Function = f /// Implements generic equality between two values, with PER semantics for NaN (so equality on two NaN values returns false) @@ -1862,35 +1864,36 @@ namespace Microsoft.FSharp.Core let inline HashIntPtr (x:nativeint) = (# "conv.i4" (# "conv.u8" x : uint64 #) : int #) let inline HashUIntPtr (x:unativeint) = (# "and" (# "conv.i4" (# "conv.u8" x : uint64 #) : int #) 0x7fffffff : int #) - type GenericHashTCall<'T> = delegate of 'T -> int + type GenericHashTCall<'T> = Func<'T, int> let tryGetGenericHashTCall (ty:Type) : obj = match ty with - | ty when ty.Equals typeof -> box (GenericHashTCall (fun x -> (# "" x : int #))) - | ty when ty.Equals typeof -> box (GenericHashTCall (fun x -> (# "" x : int #))) - | ty when ty.Equals typeof -> box (GenericHashTCall (fun x -> (# "" x : int #))) - | ty when ty.Equals typeof -> box (GenericHashTCall (fun x -> (# "" x : int #))) - | ty when ty.Equals typeof -> box (GenericHashTCall HashChar) - | ty when ty.Equals typeof -> box (GenericHashTCall HashSByte) - | ty when ty.Equals typeof -> box (GenericHashTCall HashInt16) - | ty when ty.Equals typeof -> box (GenericHashTCall HashInt64) - | ty when ty.Equals typeof -> box (GenericHashTCall HashUInt64) - | ty when ty.Equals typeof -> box (GenericHashTCall HashIntPtr) - | ty when ty.Equals typeof -> box (GenericHashTCallHashUIntPtr) - | ty when ty.Equals typeof -> box (GenericHashTCall (fun x -> (# "" x : int #))) - | ty when ty.Equals typeof -> box (GenericHashTCall HashString) + | ty when ty.Equals typeof -> box (GenericHashTCall (fun x -> (# "" x : int #))) + | ty when ty.Equals typeof -> box (GenericHashTCall (fun x -> (# "" x : int #))) + | ty when ty.Equals typeof -> box (GenericHashTCall (fun x -> (# "" x : int #))) + | ty when ty.Equals typeof -> box (GenericHashTCall (fun x -> (# "" x : int #))) + | ty when ty.Equals typeof -> box (GenericHashTCall HashChar) + | ty when ty.Equals typeof -> box (GenericHashTCall HashSByte) + | ty when ty.Equals typeof -> box (GenericHashTCall HashInt16) + | ty when ty.Equals typeof -> box (GenericHashTCall HashInt64) + | ty when ty.Equals typeof -> box (GenericHashTCall HashUInt64) + | ty when ty.Equals typeof -> box (GenericHashTCall HashIntPtr) + | ty when ty.Equals typeof -> box (GenericHashTCall HashUIntPtr) + | ty when ty.Equals typeof -> box (GenericHashTCall (fun x -> (# "" x : int #))) + | ty when ty.Equals typeof -> box (GenericHashTCall HashString) | _ -> null - type GenericHashT<'T> private () = - static let f : GenericHashTCall<'T> = - match tryGetGenericHashTCall typeof<'T> with - | :? GenericHashTCall<'T> as call -> call - | _ when canUseDefaultEqualityComparer typeof<'T> -> - let comparer = System.Collections.Generic.EqualityComparer<'T>.Default - GenericHashTCall<'T> (fun x -> avoid_tail_call_int (fun () -> comparer.GetHashCode x)) - | _ -> - GenericHashTCall<'T> (fun x -> GenericHashParamObj fsEqualityComparerUnlimitedHashingPER (box x)) + let getGenericHashTCall<'T> () = + match tryGetGenericHashTCall typeof<'T> with + | :? GenericHashTCall<'T> as call -> call + | _ when canUseDefaultEqualityComparer typeof<'T> -> + let comparer = System.Collections.Generic.EqualityComparer<'T>.Default + GenericHashTCall<'T> (fun x -> avoid_tail_call_int (fun () -> comparer.GetHashCode x)) + | _ -> + GenericHashTCall<'T> (fun x -> GenericHashParamObj fsEqualityComparerUnlimitedHashingPER (box x)) + type GenericHashT<'T> private () = + static let f = getGenericHashTCall<'T> () static member Function = f /// Intrinsic for calls to depth-unlimited structural hashing that were not optimized by static conditionals. @@ -2227,18 +2230,19 @@ namespace Microsoft.FSharp.Core | ty when ty.Equals typeof -> box StringIEquality | _ -> null + let getFastGenericEqualityComparerTable<'T> () = + let ty = typeof<'T> + match tryGetFastGenericEqualityComparerTable ty with + | :? System.Collections.Generic.IEqualityComparer<'T> as comp -> comp + | _ when HashCompare.canUseDefaultEqualityComparer ty-> + unboxPrim (box System.Collections.Generic.EqualityComparer<'T>.Default) + | _ -> + MakeGenericEqualityComparer<'T>() + [] type FastGenericEqualityComparerTable<'T>() = - static let f : System.Collections.Generic.IEqualityComparer<'T> = - let ty = typeof<'T> - match tryGetFastGenericEqualityComparerTable ty with - | :? System.Collections.Generic.IEqualityComparer<'T> as comp -> comp - | _ -> - if HashCompare.canUseDefaultEqualityComparer ty - then unboxPrim (box System.Collections.Generic.EqualityComparer<'T>.Default) - else MakeGenericEqualityComparer<'T>() - - static member Function : System.Collections.Generic.IEqualityComparer<'T> = f + static let f = getFastGenericEqualityComparerTable<'T> () + static member Function = f let FastGenericEqualityComparerFromTable<'T> = FastGenericEqualityComparerTable<'T>.Function From aeb3b23b1fb686dde10c0649269c3a0c029e9d68 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Fri, 8 Jun 2018 19:18:03 +1000 Subject: [PATCH 13/92] Disallow optimization on Nullable types --- src/fsharp/FSharp.Core/prim-types.fs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index d0bc1a5920d..9a89450fced 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -1571,6 +1571,7 @@ namespace Microsoft.FSharp.Core && ty.IsSealed // covers enum and value types && not (typeof.IsAssignableFrom ty) && not ty.IsArray + && not (ty.IsGenericType && ty.GetGenericTypeDefinition().Equals (typedefof>)) // The FSharp compiler will not insert a tail call when this is used (this might be "fixed" // in a future release) From f3360c7712f607777c0ed32c678da08042ab7604 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sat, 9 Jun 2018 13:22:10 +1000 Subject: [PATCH 14/92] More inclusive check for canUseDefaultEqualityComparer --- src/fsharp/FSharp.Core/prim-types.fs | 40 +++++++++++++++++++++++----- 1 file changed, 34 insertions(+), 6 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index 9a89450fced..c07f59dd6bd 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -1566,12 +1566,40 @@ namespace Microsoft.FSharp.Core type PER = inherit IERorPER let canUseDefaultEqualityComparer (ty:Type) = - // avoid any types that need special handling in GenericEqualityObj - true - && ty.IsSealed // covers enum and value types - && not (typeof.IsAssignableFrom ty) - && not ty.IsArray - && not (ty.IsGenericType && ty.GetGenericTypeDefinition().Equals (typedefof>)) + let processed = System.Collections.Generic.HashSet () + + let rec recurse idx (types:array) = + if idx = types.Length then true + else + let ty = get types idx + if not (processed.Add ty) then + recurse (idx+1) types + else + let isValidGenericType ifNotType fullname = + if not (ty.IsGenericType && ty.GetGenericTypeDefinition().FullName.Equals fullname) + then ifNotType + else recurse 0 (ty.GetGenericArguments ()) + + // avoid any types that need special handling in GenericEqualityObj + true + && ty.IsSealed // covers enum and value types + && not ty.IsArray + && not (ty.Equals typeof) + && not (ty.Equals typeof) + && isValidGenericType true "System.Nullable`1" + && not (typeof.IsAssignableFrom ty + && not (false + || isValidGenericType false "System.ValueTuple`1" + || isValidGenericType false "System.ValueTuple`2" + || isValidGenericType false "System.ValueTuple`3" + || isValidGenericType false "System.ValueTuple`4" + || isValidGenericType false "System.ValueTuple`5" + || isValidGenericType false "System.ValueTuple`6" + || isValidGenericType false "System.ValueTuple`7" + || isValidGenericType false "System.ValueTuple`8")) + && recurse (idx+1) types + + recurse 0 [|ty|] // The FSharp compiler will not insert a tail call when this is used (this might be "fixed" // in a future release) From 4be30d13ed485dee61f76de8eac48814b3d263e1 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sat, 9 Jun 2018 16:28:52 +1000 Subject: [PATCH 15/92] Updated il output files --- .../GenericComparison/Compare07.il.bsl | 25 +++++++++---------- .../GenericComparison/Compare10.il.bsl | 25 +++++++++---------- .../GenericComparison/Equals06.il.bsl | 25 +++++++++---------- .../GenericComparison/Equals09.il.bsl | 23 ++++++++--------- .../GenericComparison/Hash09.il.bsl | 25 +++++++++---------- .../GenericComparison/Hash12.il.bsl | 23 ++++++++--------- 6 files changed, 70 insertions(+), 76 deletions(-) diff --git a/tests/fsharpqa/Source/Optimizations/GenericComparison/Compare07.il.bsl b/tests/fsharpqa/Source/Optimizations/GenericComparison/Compare07.il.bsl index 70335b05d20..b4c8337b1c2 100644 --- a/tests/fsharpqa/Source/Optimizations/GenericComparison/Compare07.il.bsl +++ b/tests/fsharpqa/Source/Optimizations/GenericComparison/Compare07.il.bsl @@ -13,7 +13,7 @@ .assembly extern FSharp.Core { .publickeytoken = (B0 3F 5F 7F 11 D5 0A 3A ) // .?_....: - .ver 4:4:1:0 + .ver 4:4:3:0 } .assembly Compare07 { @@ -29,20 +29,20 @@ } .mresource public FSharpSignatureData.Compare07 { - // Offset: 0x00000000 Length: 0x0000089A + // Offset: 0x00000000 Length: 0x0000089E } .mresource public FSharpOptimizationData.Compare07 { - // Offset: 0x000008A0 Length: 0x00000692 + // Offset: 0x000008A8 Length: 0x0000069A } .module Compare07.dll -// MVID: {59B18AEE-05DE-F88E-A745-0383EE8AB159} +// MVID: {5B1B6346-05DE-F88E-A745-038346631B5B} .imagebase 0x00400000 .file alignment 0x00000200 .stackreserve 0x00100000 .subsystem 0x0003 // WINDOWS_CUI .corflags 0x00000001 // ILONLY -// Image base: 0x02BA0000 +// Image base: 0x02B60000 // =============== CLASS MEMBERS DECLARATION =================== @@ -187,7 +187,7 @@ [4] !a V_4, [5] !a V_5) .language '{AB4F38C9-B6E6-43BA-BE3B-58080B2CCCE3}', '{994B45C4-E6E9-11D2-903F-00C04FA302A1}', '{5A869D0B-6611-11D3-BD2A-0000F80849BD}' - .line 16707566,16707566 : 0,0 'C:\\GitHub\\dsyme\\visualfsharp\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Compare07.fsx' + .line 16707566,16707566 : 0,0 'C:\\src\\manofstick\\visualfsharp-nobox\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Compare07.fsx' IL_0000: ldarg.0 IL_0001: ldnull IL_0002: cgt.un @@ -633,7 +633,7 @@ instance bool Equals(object obj) cil managed { .custom instance void [mscorlib]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) - // Code size 22 (0x16) + // Code size 20 (0x14) .maxstack 4 .locals init ([0] class Compare07/CompareMicroPerfAndCodeGenerationTests/GenericKey`1 V_0) .line 4,4 : 10,20 '' @@ -641,18 +641,17 @@ IL_0001: isinst class Compare07/CompareMicroPerfAndCodeGenerationTests/GenericKey`1 IL_0006: stloc.0 IL_0007: ldloc.0 - IL_0008: brfalse.s IL_0014 + IL_0008: brfalse.s IL_0012 .line 16707566,16707566 : 0,0 '' IL_000a: ldarg.0 IL_000b: ldloc.0 - IL_000c: tail. - IL_000e: callvirt instance bool class Compare07/CompareMicroPerfAndCodeGenerationTests/GenericKey`1::Equals(class Compare07/CompareMicroPerfAndCodeGenerationTests/GenericKey`1) - IL_0013: ret + IL_000c: callvirt instance bool class Compare07/CompareMicroPerfAndCodeGenerationTests/GenericKey`1::Equals(class Compare07/CompareMicroPerfAndCodeGenerationTests/GenericKey`1) + IL_0011: ret .line 16707566,16707566 : 0,0 '' - IL_0014: ldc.i4.0 - IL_0015: ret + IL_0012: ldc.i4.0 + IL_0013: ret } // end of method GenericKey`1::Equals .property instance int32 Tag() diff --git a/tests/fsharpqa/Source/Optimizations/GenericComparison/Compare10.il.bsl b/tests/fsharpqa/Source/Optimizations/GenericComparison/Compare10.il.bsl index 16bada503c5..55ccbcf4cf7 100644 --- a/tests/fsharpqa/Source/Optimizations/GenericComparison/Compare10.il.bsl +++ b/tests/fsharpqa/Source/Optimizations/GenericComparison/Compare10.il.bsl @@ -13,7 +13,7 @@ .assembly extern FSharp.Core { .publickeytoken = (B0 3F 5F 7F 11 D5 0A 3A ) // .?_....: - .ver 4:4:1:0 + .ver 4:4:3:0 } .assembly Compare10 { @@ -29,20 +29,20 @@ } .mresource public FSharpSignatureData.Compare10 { - // Offset: 0x00000000 Length: 0x00000AA4 + // Offset: 0x00000000 Length: 0x00000AA8 } .mresource public FSharpOptimizationData.Compare10 { - // Offset: 0x00000AA8 Length: 0x0000058E + // Offset: 0x00000AB0 Length: 0x0000058E } .module Compare10.dll -// MVID: {59B18AEE-04BF-1753-A745-0383EE8AB159} +// MVID: {5B1B6346-04BF-1753-A745-038346631B5B} .imagebase 0x00400000 .file alignment 0x00000200 .stackreserve 0x00100000 .subsystem 0x0003 // WINDOWS_CUI .corflags 0x00000001 // ILONLY -// Image base: 0x002E0000 +// Image base: 0x01030000 // =============== CLASS MEMBERS DECLARATION =================== @@ -187,7 +187,7 @@ [4] int32 V_4, [5] int32 V_5) .language '{AB4F38C9-B6E6-43BA-BE3B-58080B2CCCE3}', '{994B45C4-E6E9-11D2-903F-00C04FA302A1}', '{5A869D0B-6611-11D3-BD2A-0000F80849BD}' - .line 16707566,16707566 : 0,0 'C:\\GitHub\\dsyme\\visualfsharp\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Compare10.fsx' + .line 16707566,16707566 : 0,0 'C:\\src\\manofstick\\visualfsharp-nobox\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Compare10.fsx' IL_0000: ldarg.0 IL_0001: ldnull IL_0002: cgt.un @@ -1330,7 +1330,7 @@ instance bool Equals(object obj) cil managed { .custom instance void [mscorlib]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) - // Code size 22 (0x16) + // Code size 20 (0x14) .maxstack 4 .locals init ([0] class Compare10/CompareMicroPerfAndCodeGenerationTests/KeyWithInnerKeys V_0) .line 5,5 : 10,26 '' @@ -1338,18 +1338,17 @@ IL_0001: isinst Compare10/CompareMicroPerfAndCodeGenerationTests/KeyWithInnerKeys IL_0006: stloc.0 IL_0007: ldloc.0 - IL_0008: brfalse.s IL_0014 + IL_0008: brfalse.s IL_0012 .line 16707566,16707566 : 0,0 '' IL_000a: ldarg.0 IL_000b: ldloc.0 - IL_000c: tail. - IL_000e: callvirt instance bool Compare10/CompareMicroPerfAndCodeGenerationTests/KeyWithInnerKeys::Equals(class Compare10/CompareMicroPerfAndCodeGenerationTests/KeyWithInnerKeys) - IL_0013: ret + IL_000c: callvirt instance bool Compare10/CompareMicroPerfAndCodeGenerationTests/KeyWithInnerKeys::Equals(class Compare10/CompareMicroPerfAndCodeGenerationTests/KeyWithInnerKeys) + IL_0011: ret .line 16707566,16707566 : 0,0 '' - IL_0014: ldc.i4.0 - IL_0015: ret + IL_0012: ldc.i4.0 + IL_0013: ret } // end of method KeyWithInnerKeys::Equals .property instance int32 Tag() diff --git a/tests/fsharpqa/Source/Optimizations/GenericComparison/Equals06.il.bsl b/tests/fsharpqa/Source/Optimizations/GenericComparison/Equals06.il.bsl index 91247bff24d..4254bb088fe 100644 --- a/tests/fsharpqa/Source/Optimizations/GenericComparison/Equals06.il.bsl +++ b/tests/fsharpqa/Source/Optimizations/GenericComparison/Equals06.il.bsl @@ -13,7 +13,7 @@ .assembly extern FSharp.Core { .publickeytoken = (B0 3F 5F 7F 11 D5 0A 3A ) // .?_....: - .ver 4:4:1:0 + .ver 4:4:3:0 } .assembly Equals06 { @@ -29,20 +29,20 @@ } .mresource public FSharpSignatureData.Equals06 { - // Offset: 0x00000000 Length: 0x00000896 + // Offset: 0x00000000 Length: 0x0000089A } .mresource public FSharpOptimizationData.Equals06 { - // Offset: 0x000008A0 Length: 0x0000068E + // Offset: 0x000008A0 Length: 0x00000696 } .module Equals06.dll -// MVID: {59B18AEE-0759-31EC-A745-0383EE8AB159} +// MVID: {5B1B6346-0759-31EC-A745-038346631B5B} .imagebase 0x00400000 .file alignment 0x00000200 .stackreserve 0x00100000 .subsystem 0x0003 // WINDOWS_CUI .corflags 0x00000001 // ILONLY -// Image base: 0x01B90000 +// Image base: 0x02B30000 // =============== CLASS MEMBERS DECLARATION =================== @@ -187,7 +187,7 @@ [4] !a V_4, [5] !a V_5) .language '{AB4F38C9-B6E6-43BA-BE3B-58080B2CCCE3}', '{994B45C4-E6E9-11D2-903F-00C04FA302A1}', '{5A869D0B-6611-11D3-BD2A-0000F80849BD}' - .line 16707566,16707566 : 0,0 'C:\\GitHub\\dsyme\\visualfsharp\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Equals06.fsx' + .line 16707566,16707566 : 0,0 'C:\\src\\manofstick\\visualfsharp-nobox\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Equals06.fsx' IL_0000: ldarg.0 IL_0001: ldnull IL_0002: cgt.un @@ -633,7 +633,7 @@ instance bool Equals(object obj) cil managed { .custom instance void [mscorlib]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) - // Code size 22 (0x16) + // Code size 20 (0x14) .maxstack 4 .locals init ([0] class Equals06/EqualsMicroPerfAndCodeGenerationTests/GenericKey`1 V_0) .line 4,4 : 10,20 '' @@ -641,18 +641,17 @@ IL_0001: isinst class Equals06/EqualsMicroPerfAndCodeGenerationTests/GenericKey`1 IL_0006: stloc.0 IL_0007: ldloc.0 - IL_0008: brfalse.s IL_0014 + IL_0008: brfalse.s IL_0012 .line 16707566,16707566 : 0,0 '' IL_000a: ldarg.0 IL_000b: ldloc.0 - IL_000c: tail. - IL_000e: callvirt instance bool class Equals06/EqualsMicroPerfAndCodeGenerationTests/GenericKey`1::Equals(class Equals06/EqualsMicroPerfAndCodeGenerationTests/GenericKey`1) - IL_0013: ret + IL_000c: callvirt instance bool class Equals06/EqualsMicroPerfAndCodeGenerationTests/GenericKey`1::Equals(class Equals06/EqualsMicroPerfAndCodeGenerationTests/GenericKey`1) + IL_0011: ret .line 16707566,16707566 : 0,0 '' - IL_0014: ldc.i4.0 - IL_0015: ret + IL_0012: ldc.i4.0 + IL_0013: ret } // end of method GenericKey`1::Equals .property instance int32 Tag() diff --git a/tests/fsharpqa/Source/Optimizations/GenericComparison/Equals09.il.bsl b/tests/fsharpqa/Source/Optimizations/GenericComparison/Equals09.il.bsl index 8985acaa02b..cde1562a76b 100644 --- a/tests/fsharpqa/Source/Optimizations/GenericComparison/Equals09.il.bsl +++ b/tests/fsharpqa/Source/Optimizations/GenericComparison/Equals09.il.bsl @@ -13,7 +13,7 @@ .assembly extern FSharp.Core { .publickeytoken = (B0 3F 5F 7F 11 D5 0A 3A ) // .?_....: - .ver 4:4:1:0 + .ver 4:4:3:0 } .assembly Equals09 { @@ -29,20 +29,20 @@ } .mresource public FSharpSignatureData.Equals09 { - // Offset: 0x00000000 Length: 0x00000AA0 + // Offset: 0x00000000 Length: 0x00000AA4 } .mresource public FSharpOptimizationData.Equals09 { // Offset: 0x00000AA8 Length: 0x0000058B } .module Equals09.dll -// MVID: {59B18AEE-0759-46D9-A745-0383EE8AB159} +// MVID: {5B1B6346-0759-46D9-A745-038346631B5B} .imagebase 0x00400000 .file alignment 0x00000200 .stackreserve 0x00100000 .subsystem 0x0003 // WINDOWS_CUI .corflags 0x00000001 // ILONLY -// Image base: 0x02720000 +// Image base: 0x02560000 // =============== CLASS MEMBERS DECLARATION =================== @@ -187,7 +187,7 @@ [4] int32 V_4, [5] int32 V_5) .language '{AB4F38C9-B6E6-43BA-BE3B-58080B2CCCE3}', '{994B45C4-E6E9-11D2-903F-00C04FA302A1}', '{5A869D0B-6611-11D3-BD2A-0000F80849BD}' - .line 16707566,16707566 : 0,0 'C:\\GitHub\\dsyme\\visualfsharp\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Equals09.fsx' + .line 16707566,16707566 : 0,0 'C:\\src\\manofstick\\visualfsharp-nobox\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Equals09.fsx' IL_0000: ldarg.0 IL_0001: ldnull IL_0002: cgt.un @@ -1330,7 +1330,7 @@ instance bool Equals(object obj) cil managed { .custom instance void [mscorlib]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) - // Code size 22 (0x16) + // Code size 20 (0x14) .maxstack 4 .locals init ([0] class Equals09/EqualsMicroPerfAndCodeGenerationTests/KeyWithInnerKeys V_0) .line 5,5 : 10,26 '' @@ -1338,18 +1338,17 @@ IL_0001: isinst Equals09/EqualsMicroPerfAndCodeGenerationTests/KeyWithInnerKeys IL_0006: stloc.0 IL_0007: ldloc.0 - IL_0008: brfalse.s IL_0014 + IL_0008: brfalse.s IL_0012 .line 16707566,16707566 : 0,0 '' IL_000a: ldarg.0 IL_000b: ldloc.0 - IL_000c: tail. - IL_000e: callvirt instance bool Equals09/EqualsMicroPerfAndCodeGenerationTests/KeyWithInnerKeys::Equals(class Equals09/EqualsMicroPerfAndCodeGenerationTests/KeyWithInnerKeys) - IL_0013: ret + IL_000c: callvirt instance bool Equals09/EqualsMicroPerfAndCodeGenerationTests/KeyWithInnerKeys::Equals(class Equals09/EqualsMicroPerfAndCodeGenerationTests/KeyWithInnerKeys) + IL_0011: ret .line 16707566,16707566 : 0,0 '' - IL_0014: ldc.i4.0 - IL_0015: ret + IL_0012: ldc.i4.0 + IL_0013: ret } // end of method KeyWithInnerKeys::Equals .property instance int32 Tag() diff --git a/tests/fsharpqa/Source/Optimizations/GenericComparison/Hash09.il.bsl b/tests/fsharpqa/Source/Optimizations/GenericComparison/Hash09.il.bsl index df7b115d207..4cf28a5ff57 100644 --- a/tests/fsharpqa/Source/Optimizations/GenericComparison/Hash09.il.bsl +++ b/tests/fsharpqa/Source/Optimizations/GenericComparison/Hash09.il.bsl @@ -13,7 +13,7 @@ .assembly extern FSharp.Core { .publickeytoken = (B0 3F 5F 7F 11 D5 0A 3A ) // .?_....: - .ver 4:4:1:0 + .ver 4:4:3:0 } .assembly Hash09 { @@ -29,20 +29,20 @@ } .mresource public FSharpSignatureData.Hash09 { - // Offset: 0x00000000 Length: 0x0000088E + // Offset: 0x00000000 Length: 0x00000892 } .mresource public FSharpOptimizationData.Hash09 { - // Offset: 0x00000898 Length: 0x00000686 + // Offset: 0x00000898 Length: 0x0000068E } .module Hash09.dll -// MVID: {59B18AEE-9642-77DB-A745-0383EE8AB159} +// MVID: {5B1B6346-9642-77DB-A745-038346631B5B} .imagebase 0x00400000 .file alignment 0x00000200 .stackreserve 0x00100000 .subsystem 0x0003 // WINDOWS_CUI .corflags 0x00000001 // ILONLY -// Image base: 0x00690000 +// Image base: 0x025D0000 // =============== CLASS MEMBERS DECLARATION =================== @@ -187,7 +187,7 @@ [4] !a V_4, [5] !a V_5) .language '{AB4F38C9-B6E6-43BA-BE3B-58080B2CCCE3}', '{994B45C4-E6E9-11D2-903F-00C04FA302A1}', '{5A869D0B-6611-11D3-BD2A-0000F80849BD}' - .line 16707566,16707566 : 0,0 'C:\\GitHub\\dsyme\\visualfsharp\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Hash09.fsx' + .line 16707566,16707566 : 0,0 'C:\\src\\manofstick\\visualfsharp-nobox\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Hash09.fsx' IL_0000: ldarg.0 IL_0001: ldnull IL_0002: cgt.un @@ -633,7 +633,7 @@ instance bool Equals(object obj) cil managed { .custom instance void [mscorlib]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) - // Code size 22 (0x16) + // Code size 20 (0x14) .maxstack 4 .locals init ([0] class Hash09/HashMicroPerfAndCodeGenerationTests/GenericKey`1 V_0) .line 4,4 : 10,20 '' @@ -641,18 +641,17 @@ IL_0001: isinst class Hash09/HashMicroPerfAndCodeGenerationTests/GenericKey`1 IL_0006: stloc.0 IL_0007: ldloc.0 - IL_0008: brfalse.s IL_0014 + IL_0008: brfalse.s IL_0012 .line 16707566,16707566 : 0,0 '' IL_000a: ldarg.0 IL_000b: ldloc.0 - IL_000c: tail. - IL_000e: callvirt instance bool class Hash09/HashMicroPerfAndCodeGenerationTests/GenericKey`1::Equals(class Hash09/HashMicroPerfAndCodeGenerationTests/GenericKey`1) - IL_0013: ret + IL_000c: callvirt instance bool class Hash09/HashMicroPerfAndCodeGenerationTests/GenericKey`1::Equals(class Hash09/HashMicroPerfAndCodeGenerationTests/GenericKey`1) + IL_0011: ret .line 16707566,16707566 : 0,0 '' - IL_0014: ldc.i4.0 - IL_0015: ret + IL_0012: ldc.i4.0 + IL_0013: ret } // end of method GenericKey`1::Equals .property instance int32 Tag() diff --git a/tests/fsharpqa/Source/Optimizations/GenericComparison/Hash12.il.bsl b/tests/fsharpqa/Source/Optimizations/GenericComparison/Hash12.il.bsl index 9c5bfb73cf3..8836ff15748 100644 --- a/tests/fsharpqa/Source/Optimizations/GenericComparison/Hash12.il.bsl +++ b/tests/fsharpqa/Source/Optimizations/GenericComparison/Hash12.il.bsl @@ -13,7 +13,7 @@ .assembly extern FSharp.Core { .publickeytoken = (B0 3F 5F 7F 11 D5 0A 3A ) // .?_....: - .ver 4:4:1:0 + .ver 4:4:3:0 } .assembly Hash12 { @@ -29,20 +29,20 @@ } .mresource public FSharpSignatureData.Hash12 { - // Offset: 0x00000000 Length: 0x00000A98 + // Offset: 0x00000000 Length: 0x00000A9C } .mresource public FSharpOptimizationData.Hash12 { // Offset: 0x00000AA0 Length: 0x00000585 } .module Hash12.dll -// MVID: {59B18AEE-9661-796E-A745-0383EE8AB159} +// MVID: {5B1B6346-9661-796E-A745-038346631B5B} .imagebase 0x00400000 .file alignment 0x00000200 .stackreserve 0x00100000 .subsystem 0x0003 // WINDOWS_CUI .corflags 0x00000001 // ILONLY -// Image base: 0x01080000 +// Image base: 0x02810000 // =============== CLASS MEMBERS DECLARATION =================== @@ -187,7 +187,7 @@ [4] int32 V_4, [5] int32 V_5) .language '{AB4F38C9-B6E6-43BA-BE3B-58080B2CCCE3}', '{994B45C4-E6E9-11D2-903F-00C04FA302A1}', '{5A869D0B-6611-11D3-BD2A-0000F80849BD}' - .line 16707566,16707566 : 0,0 'C:\\GitHub\\dsyme\\visualfsharp\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Hash12.fsx' + .line 16707566,16707566 : 0,0 'C:\\src\\manofstick\\visualfsharp-nobox\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Hash12.fsx' IL_0000: ldarg.0 IL_0001: ldnull IL_0002: cgt.un @@ -1330,7 +1330,7 @@ instance bool Equals(object obj) cil managed { .custom instance void [mscorlib]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) - // Code size 22 (0x16) + // Code size 20 (0x14) .maxstack 4 .locals init ([0] class Hash12/HashMicroPerfAndCodeGenerationTests/KeyWithInnerKeys V_0) .line 5,5 : 10,26 '' @@ -1338,18 +1338,17 @@ IL_0001: isinst Hash12/HashMicroPerfAndCodeGenerationTests/KeyWithInnerKeys IL_0006: stloc.0 IL_0007: ldloc.0 - IL_0008: brfalse.s IL_0014 + IL_0008: brfalse.s IL_0012 .line 16707566,16707566 : 0,0 '' IL_000a: ldarg.0 IL_000b: ldloc.0 - IL_000c: tail. - IL_000e: callvirt instance bool Hash12/HashMicroPerfAndCodeGenerationTests/KeyWithInnerKeys::Equals(class Hash12/HashMicroPerfAndCodeGenerationTests/KeyWithInnerKeys) - IL_0013: ret + IL_000c: callvirt instance bool Hash12/HashMicroPerfAndCodeGenerationTests/KeyWithInnerKeys::Equals(class Hash12/HashMicroPerfAndCodeGenerationTests/KeyWithInnerKeys) + IL_0011: ret .line 16707566,16707566 : 0,0 '' - IL_0014: ldc.i4.0 - IL_0015: ret + IL_0012: ldc.i4.0 + IL_0013: ret } // end of method KeyWithInnerKeys::Equals .property instance int32 Tag() From 44d7bcd443c279b64460d0696f5d354d3e2973dc Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Mon, 11 Jun 2018 17:27:49 +1000 Subject: [PATCH 16/92] Removed IERorPER by splitting calling class into 2, and added helper functions --- src/fsharp/FSharp.Core/prim-types.fs | 35 ++++++++++++---------------- 1 file changed, 15 insertions(+), 20 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index c07f59dd6bd..056d986f838 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -1561,10 +1561,6 @@ namespace Microsoft.FSharp.Core override iec.Equals(x:obj,y:obj) = GenericEqualityObj true iec (x,y) // ER Semantics override iec.GetHashCode(x:obj) = raise (InvalidOperationException (SR.GetString(SR.notUsedForHashing))) } - type IERorPER = interface end - type ER = inherit IERorPER - type PER = inherit IERorPER - let canUseDefaultEqualityComparer (ty:Type) = let processed = System.Collections.Generic.HashSet () @@ -1630,12 +1626,7 @@ namespace Microsoft.FSharp.Core | true, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #) || (not ((# "ceq" x x : bool #) || (# "ceq" y y : bool #))))) | _ -> null - let getGenericEquality<'T, 'ERorPER when 'ERorPER :> IERorPER> () = - let er = - if typeof<'ERorPER>.Equals typeof then true - elif typeof<'ERorPER>.Equals typeof then false - else raise (Exception "logic error") - + let getGenericEquality<'T> er = match tryGetGenericEqualityTCall er typeof<'T> with | :? GenericEqualityTCall<'T> as call -> call | _ when canUseDefaultEqualityComparer typeof<'T> -> @@ -1646,16 +1637,20 @@ namespace Microsoft.FSharp.Core | _ -> GenericEqualityTCall<'T> (fun x y -> GenericEqualityObj false fsEqualityComparerNoHashingPER (box x, box y)) - type GenericEqualityT<'T, 'ERorPER when 'ERorPER :> IERorPER> private () = - static let f = getGenericEquality<'T, 'ERorPER> () - static member Function = f + type GenericEqualityT_ER<'T> private () = + static let f = getGenericEquality<'T> true + static member inline Equals (x, y) = f.Invoke (x, y) + + type GenericEqualityT_PER<'T> private () = + static let f = getGenericEquality<'T> false + static member inline Equals (x, y) = f.Invoke (x, y) /// Implements generic equality between two values, with PER semantics for NaN (so equality on two NaN values returns false) // // The compiler optimizer is aware of this function (see use of generic_equality_per_inner_vref in opt.fs) // and devirtualizes calls to it based on "T". let GenericEqualityIntrinsic (x : 'T) (y : 'T) : bool = - avoid_tail_call_bool (fun () -> GenericEqualityT<'T, PER>.Function.Invoke (x, y)) + avoid_tail_call_bool (fun () -> GenericEqualityT_PER<'T>.Equals (x, y)) /// Implements generic equality between two values, with ER semantics for NaN (so equality on two NaN values returns true) // @@ -1664,7 +1659,7 @@ namespace Microsoft.FSharp.Core // The compiler optimizer is aware of this function (see use of generic_equality_er_inner_vref in opt.fs) // and devirtualizes calls to it based on "T". let GenericEqualityERIntrinsic (x : 'T) (y : 'T) : bool = - avoid_tail_call_bool (fun () -> GenericEqualityT<'T, ER>.Function.Invoke (x, y)) + avoid_tail_call_bool (fun () -> GenericEqualityT_ER<'T>.Equals (x, y)) /// Implements generic equality between two values using "comp" for recursive calls. // @@ -1673,9 +1668,9 @@ namespace Microsoft.FSharp.Core // is either fsEqualityComparerNoHashingER or fsEqualityComparerNoHashingPER. let GenericEqualityWithComparerIntrinsic (comp : System.Collections.IEqualityComparer) (x : 'T) (y : 'T) : bool = if obj.ReferenceEquals (comp, fsEqualityComparerUnlimitedHashingPER) || obj.ReferenceEquals (comp, fsEqualityComparerNoHashingPER) then - avoid_tail_call_bool (fun () -> GenericEqualityT<'T, PER>.Function.Invoke (x, y)) + avoid_tail_call_bool (fun () -> GenericEqualityT_PER<'T>.Equals (x, y)) elif obj.ReferenceEquals (comp, fsEqualityComparerNoHashingER) then - avoid_tail_call_bool (fun () -> GenericEqualityT<'T, ER>.Function.Invoke (x, y)) + avoid_tail_call_bool (fun () -> GenericEqualityT_ER<'T>.Equals (x, y)) else comp.Equals (box x, box y) @@ -1923,14 +1918,14 @@ namespace Microsoft.FSharp.Core type GenericHashT<'T> private () = static let f = getGenericHashTCall<'T> () - static member Function = f + static member inline GetHashCode x = f.Invoke x /// Intrinsic for calls to depth-unlimited structural hashing that were not optimized by static conditionals. // // NOTE: The compiler optimizer is aware of this function (see uses of generic_hash_inner_vref in opt.fs) // and devirtualizes calls to it based on type "T". let GenericHashIntrinsic input = - avoid_tail_call_int (fun () -> GenericHashT<'T>.Function.Invoke input) + avoid_tail_call_int (fun () -> GenericHashT<'T>.GetHashCode input) /// Intrinsic for calls to depth-limited structural hashing that were not optimized by static conditionals. let LimitedGenericHashIntrinsic limit input = GenericHashParamObj (CountLimitedHasherPER(limit)) (box input) @@ -1944,7 +1939,7 @@ namespace Microsoft.FSharp.Core // and devirtualizes calls to it based on type "T". let GenericHashWithComparerIntrinsic<'T> (comp : System.Collections.IEqualityComparer) (input : 'T) : int = if obj.ReferenceEquals (comp, fsEqualityComparerUnlimitedHashingPER) then - avoid_tail_call_int (fun () -> GenericHashT<'T>.Function.Invoke input) + avoid_tail_call_int (fun () -> GenericHashT<'T>.GetHashCode input) else GenericHashParamObj comp (box input) From cd7dff438a324b7483705f6b0d570f5cc8c87d2f Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Wed, 13 Jun 2018 19:39:39 +1000 Subject: [PATCH 17/92] Changed it all to used EqualityComparer derived classes and restored tail calls --- src/fsharp/FSharp.Core/prim-types.fs | 472 +++++++++--------- .../GenericComparison/Compare07.il.bsl | 25 +- .../GenericComparison/Compare10.il.bsl | 25 +- .../GenericComparison/Equals06.il.bsl | 25 +- .../GenericComparison/Equals09.il.bsl | 23 +- .../GenericComparison/Hash09.il.bsl | 25 +- .../GenericComparison/Hash12.il.bsl | 23 +- 7 files changed, 313 insertions(+), 305 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index 056d986f838..885ce8b8505 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -771,6 +771,9 @@ namespace Microsoft.FSharp.Core let anyToStringShowingNull x = anyToString "null" x module HashCompare = + //------------------------------------------------------------------------- + // LanguagePrimitives.HashCompare: HASHING. + //------------------------------------------------------------------------- let defaultHashNodes = 18 /// The implementation of IEqualityComparer, using depth-limited for hashing and PER semantics for NaN equality. @@ -800,7 +803,106 @@ namespace Microsoft.FSharp.Core /// The unique object for unlimited depth for hashing and PER semantics for equality. let fsEqualityComparerUnlimitedHashingPER = UnlimitedHasherPER() - + + let inline HashCombine nr x y = (x <<< 1) + y + 631 * nr + + let GenericHashObjArray (iec : System.Collections.IEqualityComparer) (x: obj[]) : int = + let len = x.Length + let mutable i = len - 1 + if i > defaultHashNodes then i <- defaultHashNodes // limit the hash + let mutable acc = 0 + while (i >= 0) do + // NOTE: GenericHash* call decreases nr + acc <- HashCombine i acc (iec.GetHashCode(x.GetValue(i))); + i <- i - 1 + acc + + // optimized case - byte arrays + let GenericHashByteArray (x: byte[]) : int = + let len = length x + let mutable i = len - 1 + if i > defaultHashNodes then i <- defaultHashNodes // limit the hash + let mutable acc = 0 + while (i >= 0) do + acc <- HashCombine i acc (intOfByte (get x i)); + i <- i - 1 + acc + + // optimized case - int arrays + let GenericHashInt32Array (x: int[]) : int = + let len = length x + let mutable i = len - 1 + if i > defaultHashNodes then i <- defaultHashNodes // limit the hash + let mutable acc = 0 + while (i >= 0) do + acc <- HashCombine i acc (get x i); + i <- i - 1 + acc + + // optimized case - int arrays + let GenericHashInt64Array (x: int64[]) : int = + let len = length x + let mutable i = len - 1 + if i > defaultHashNodes then i <- defaultHashNodes // limit the hash + let mutable acc = 0 + while (i >= 0) do + acc <- HashCombine i acc (int32 (get x i)); + i <- i - 1 + acc + + // special case - arrays do not by default have a decent structural hashing function + let GenericHashArbArray (iec : System.Collections.IEqualityComparer) (x: System.Array) : int = + match x.Rank with + | 1 -> + let b = x.GetLowerBound(0) + let len = x.Length + let mutable i = b + len - 1 + if i > b + defaultHashNodes then i <- b + defaultHashNodes // limit the hash + let mutable acc = 0 + while (i >= b) do + // NOTE: GenericHash* call decreases nr + acc <- HashCombine i acc (iec.GetHashCode(x.GetValue(i))); + i <- i - 1 + acc + | _ -> + HashCombine 10 (x.GetLength(0)) (x.GetLength(1)) + + // Core implementation of structural hashing, corresponds to pseudo-code in the + // F# Language spec. Searches for the IStructuralHash interface, otherwise uses GetHashCode(). + // Arrays are structurally hashed through a separate technique. + // + // "iec" is either fsEqualityComparerUnlimitedHashingER, fsEqualityComparerUnlimitedHashingPER or a CountLimitedHasherPER. + let rec GenericHashParamObj (iec : System.Collections.IEqualityComparer) (x: obj) : int = + match x with + | null -> 0 + | (:? System.Array as a) -> + match a with + | :? (obj[]) as oa -> GenericHashObjArray iec oa + | :? (byte[]) as ba -> GenericHashByteArray ba + | :? (int[]) as ba -> GenericHashInt32Array ba + | :? (int64[]) as ba -> GenericHashInt64Array ba + | _ -> GenericHashArbArray iec a + | :? IStructuralEquatable as a -> + a.GetHashCode(iec) + | _ -> + x.GetHashCode() + + /// Direct call to GetHashCode on the string type + let inline HashString (s:string) = + match s with + | null -> 0 + | _ -> (# "call instance int32 [mscorlib]System.String::GetHashCode()" s : int #) + + // from mscorlib v4.0.30319 + let inline HashChar (x:char) = (# "or" (# "shl" x 16 : int #) x : int #) + let inline HashSByte (x:sbyte) = (# "xor" (# "shl" x 8 : int #) x : int #) + let inline HashInt16 (x:int16) = (# "or" (# "conv.u2" x : int #) (# "shl" x 16 : int #) : int #) + let inline HashInt64 (x:int64) = (# "xor" (# "conv.i4" x : int #) (# "conv.i4" (# "shr" x 32 : int #) : int #) : int #) + let inline HashUInt64 (x:uint64) = (# "xor" (# "conv.i4" x : int #) (# "conv.i4" (# "shr.un" x 32 : int #) : int #) : int #) + let inline HashIntPtr (x:nativeint) = (# "conv.i4" (# "conv.u8" x : uint64 #) : int #) + let inline HashUIntPtr (x:unativeint) = (# "and" (# "conv.i4" (# "conv.u8" x : uint64 #) : int #) 0x7fffffff : int #) + + //------------------------------------------------------------------------- // LanguagePrimitives.HashCompare: Physical Equality //------------------------------------------------------------------------- @@ -1580,6 +1682,8 @@ namespace Microsoft.FSharp.Core true && ty.IsSealed // covers enum and value types && not ty.IsArray + && not (ty.Equals typeof) + && not (ty.Equals typeof) && not (ty.Equals typeof) && not (ty.Equals typeof) && isValidGenericType true "System.Nullable`1" @@ -1597,60 +1701,141 @@ namespace Microsoft.FSharp.Core recurse 0 [|ty|] - // The FSharp compiler will not insert a tail call when this is used (this might be "fixed" - // in a future release) - let inline avoid_tail_call_bool f = match f () with true -> true | _ -> false - let inline avoid_tail_call_int f = 0 + f () - - type GenericEqualityTCall<'T> = Func<'T, 'T, bool> - - let tryGetGenericEqualityTCall (er:bool) (ty:Type) : obj = + let tryGetFSharpEqualityComparer (er:bool) (ty:Type) : obj = match er, ty with - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> System.String.Equals((# "" x : string #),(# "" y : string #)))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> System.Decimal.op_Equality((# "" x:decimal #), (# "" y:decimal #)))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | _, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | false, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | false, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #))) - | true, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #) || (not ((# "ceq" x x : bool #) || (# "ceq" y y : bool #))))) - | true, ty when ty.Equals typeof -> box (GenericEqualityTCall (fun x y -> (# "ceq" x y : bool #) || (not ((# "ceq" x x : bool #) || (# "ceq" y y : bool #))))) + | _, ty when ty.Equals typeof -> box { + new EqualityComparer() with + member __.Equals (x,y) = System.String.Equals (x, y) + member __.GetHashCode x = HashString x } + + | _, ty when ty.Equals typeof -> box { + new EqualityComparer() with + member __.Equals (x,y) = System.Decimal.op_Equality (x, y) + member __.GetHashCode x = x.GetHashCode () } + + | _, ty when ty.Equals typeof -> box { + new EqualityComparer() with + member __.Equals (x,y) = (# "ceq" x y : bool #) + member __.GetHashCode x = (# "" x : int #) } + + | _, ty when ty.Equals typeof -> box { + new EqualityComparer() with + member __.Equals (x,y) = (# "ceq" x y : bool #) + member __.GetHashCode x = HashSByte x } + + | _, ty when ty.Equals typeof -> box { + new EqualityComparer() with + member __.Equals (x,y) = (# "ceq" x y : bool #) + member __.GetHashCode x = HashInt16 x } + + | _, ty when ty.Equals typeof -> box { + new EqualityComparer() with + member __.Equals (x,y) = (# "ceq" x y : bool #) + member __.GetHashCode x = (# "" x : int #) } + + | _, ty when ty.Equals typeof -> box { + new EqualityComparer() with + member __.Equals (x,y) = (# "ceq" x y : bool #) + member __.GetHashCode x = HashInt64 x } + + | _, ty when ty.Equals typeof -> box { + new EqualityComparer() with + member __.Equals (x,y) = (# "ceq" x y : bool #) + member __.GetHashCode x = (# "" x : int #) } + + | _, ty when ty.Equals typeof -> box { + new EqualityComparer() with + member __.Equals (x,y) = (# "ceq" x y : bool #) + member __.GetHashCode x = (# "" x : int #) } + + | _, ty when ty.Equals typeof -> box { + new EqualityComparer() with + member __.Equals (x,y) = (# "ceq" x y : bool #) + member __.GetHashCode x = (# "" x : int #) } + + | _, ty when ty.Equals typeof -> box { + new EqualityComparer() with + member __.Equals (x,y) = (# "ceq" x y : bool #) + member __.GetHashCode x = HashUInt64 x } + + | _, ty when ty.Equals typeof -> box { + new EqualityComparer() with + member __.Equals (x,y) = (# "ceq" x y : bool #) + member __.GetHashCode x = HashIntPtr x } + + | _, ty when ty.Equals typeof -> box { + new EqualityComparer() with + member __.Equals (x,y) = (# "ceq" x y : bool #) + member __.GetHashCode x = HashUIntPtr x } + + | _, ty when ty.Equals typeof -> box { + new EqualityComparer() with + member __.Equals (x,y) = (# "ceq" x y : bool #) + member __.GetHashCode x = HashChar x } + + | false, ty when ty.Equals typeof -> box { + new EqualityComparer() with + member __.Equals (x,y) = (# "ceq" x y : bool #) + member __.GetHashCode x = x.GetHashCode () } + + | false, ty when ty.Equals typeof -> box { + new EqualityComparer() with + member __.Equals (x,y) = (# "ceq" x y : bool #) + member __.GetHashCode x = x.GetHashCode () } + + | true, ty when ty.Equals typeof -> box { + new EqualityComparer() with + member __.Equals (x,y) = (# "ceq" x y : bool #) || (not ((# "ceq" x x : bool #) || (# "ceq" y y : bool #))) + member __.GetHashCode x = x.GetHashCode () } + + | true, ty when ty.Equals typeof -> box { + new EqualityComparer() with + member __.Equals (x,y) = (# "ceq" x y : bool #) || (not ((# "ceq" x x : bool #) || (# "ceq" y y : bool #))) + member __.GetHashCode x = x.GetHashCode () } + | _ -> null + let genericFSharpEqualityComparer_ER<'T> () = { + new EqualityComparer<'T>() with + member __.Equals (x,y) = GenericEqualityObj true fsEqualityComparerUnlimitedHashingER (box x, box y) + member __.GetHashCode x = GenericHashParamObj fsEqualityComparerUnlimitedHashingPER (box x) + } + + let genericFSharpEqualityComparer_PER<'T> () = { + new EqualityComparer<'T>() with + member __.Equals (x,y) = GenericEqualityObj false fsEqualityComparerUnlimitedHashingPER (box x, box y) + member __.GetHashCode x = GenericHashParamObj fsEqualityComparerUnlimitedHashingPER (box x) + } + let getGenericEquality<'T> er = - match tryGetGenericEqualityTCall er typeof<'T> with - | :? GenericEqualityTCall<'T> as call -> call - | _ when canUseDefaultEqualityComparer typeof<'T> -> - let comparer = System.Collections.Generic.EqualityComparer<'T>.Default - GenericEqualityTCall<'T> (fun x y -> avoid_tail_call_bool (fun () -> comparer.Equals (x, y))) - | _ when er -> - GenericEqualityTCall<'T> (fun x y -> GenericEqualityObj true fsEqualityComparerNoHashingER (box x, box y)) - | _ -> - GenericEqualityTCall<'T> (fun x y -> GenericEqualityObj false fsEqualityComparerNoHashingPER (box x, box y)) - - type GenericEqualityT_ER<'T> private () = - static let f = getGenericEquality<'T> true - static member inline Equals (x, y) = f.Invoke (x, y) - - type GenericEqualityT_PER<'T> private () = - static let f = getGenericEquality<'T> false - static member inline Equals (x, y) = f.Invoke (x, y) + match tryGetFSharpEqualityComparer er typeof<'T> with + | :? EqualityComparer<'T> as call -> call + | _ when canUseDefaultEqualityComparer typeof<'T> -> EqualityComparer<'T>.Default + | _ when er -> genericFSharpEqualityComparer_ER<'T> () + | _ -> genericFSharpEqualityComparer_PER<'T> () + + type FSharpEqualityComparer_ER<'T> private () = + static let comparer = getGenericEquality<'T> true + + static member Comparer = comparer + + static member inline Equals (x, y) = comparer.Equals (x, y) + static member inline GetHashCode x = comparer.GetHashCode x + + type FSharpEqualityComparer_PER<'T> private () = + static let comparer = getGenericEquality<'T> false + + static member Comparer = comparer + + static member inline Equals (x, y) = comparer.Equals (x, y) + static member inline GetHashCode x = comparer.GetHashCode x /// Implements generic equality between two values, with PER semantics for NaN (so equality on two NaN values returns false) // // The compiler optimizer is aware of this function (see use of generic_equality_per_inner_vref in opt.fs) // and devirtualizes calls to it based on "T". let GenericEqualityIntrinsic (x : 'T) (y : 'T) : bool = - avoid_tail_call_bool (fun () -> GenericEqualityT_PER<'T>.Equals (x, y)) + FSharpEqualityComparer_PER<'T>.Equals (x, y) /// Implements generic equality between two values, with ER semantics for NaN (so equality on two NaN values returns true) // @@ -1659,7 +1844,7 @@ namespace Microsoft.FSharp.Core // The compiler optimizer is aware of this function (see use of generic_equality_er_inner_vref in opt.fs) // and devirtualizes calls to it based on "T". let GenericEqualityERIntrinsic (x : 'T) (y : 'T) : bool = - avoid_tail_call_bool (fun () -> GenericEqualityT_ER<'T>.Equals (x, y)) + FSharpEqualityComparer_ER<'T>.Equals (x, y) /// Implements generic equality between two values using "comp" for recursive calls. // @@ -1668,9 +1853,9 @@ namespace Microsoft.FSharp.Core // is either fsEqualityComparerNoHashingER or fsEqualityComparerNoHashingPER. let GenericEqualityWithComparerIntrinsic (comp : System.Collections.IEqualityComparer) (x : 'T) (y : 'T) : bool = if obj.ReferenceEquals (comp, fsEqualityComparerUnlimitedHashingPER) || obj.ReferenceEquals (comp, fsEqualityComparerNoHashingPER) then - avoid_tail_call_bool (fun () -> GenericEqualityT_PER<'T>.Equals (x, y)) + FSharpEqualityComparer_PER<'T>.Equals (x, y) elif obj.ReferenceEquals (comp, fsEqualityComparerNoHashingER) then - avoid_tail_call_bool (fun () -> GenericEqualityT_ER<'T>.Equals (x, y)) + FSharpEqualityComparer_ER<'T>.Equals (x, y) else comp.Equals (box x, box y) @@ -1758,95 +1943,6 @@ namespace Microsoft.FSharp.Core let inline GenericInequalityFast (x:'T) (y:'T) = (not(GenericEqualityFast x y) : bool) let inline GenericInequalityERFast (x:'T) (y:'T) = (not(GenericEqualityERFast x y) : bool) - - //------------------------------------------------------------------------- - // LanguagePrimitives.HashCompare: HASHING. - //------------------------------------------------------------------------- - - let inline HashCombine nr x y = (x <<< 1) + y + 631 * nr - - let GenericHashObjArray (iec : System.Collections.IEqualityComparer) (x: obj[]) : int = - let len = x.Length - let mutable i = len - 1 - if i > defaultHashNodes then i <- defaultHashNodes // limit the hash - let mutable acc = 0 - while (i >= 0) do - // NOTE: GenericHash* call decreases nr - acc <- HashCombine i acc (iec.GetHashCode(x.GetValue(i))); - i <- i - 1 - acc - - // optimized case - byte arrays - let GenericHashByteArray (x: byte[]) : int = - let len = length x - let mutable i = len - 1 - if i > defaultHashNodes then i <- defaultHashNodes // limit the hash - let mutable acc = 0 - while (i >= 0) do - acc <- HashCombine i acc (intOfByte (get x i)); - i <- i - 1 - acc - - // optimized case - int arrays - let GenericHashInt32Array (x: int[]) : int = - let len = length x - let mutable i = len - 1 - if i > defaultHashNodes then i <- defaultHashNodes // limit the hash - let mutable acc = 0 - while (i >= 0) do - acc <- HashCombine i acc (get x i); - i <- i - 1 - acc - - // optimized case - int arrays - let GenericHashInt64Array (x: int64[]) : int = - let len = length x - let mutable i = len - 1 - if i > defaultHashNodes then i <- defaultHashNodes // limit the hash - let mutable acc = 0 - while (i >= 0) do - acc <- HashCombine i acc (int32 (get x i)); - i <- i - 1 - acc - - // special case - arrays do not by default have a decent structural hashing function - let GenericHashArbArray (iec : System.Collections.IEqualityComparer) (x: System.Array) : int = - match x.Rank with - | 1 -> - let b = x.GetLowerBound(0) - let len = x.Length - let mutable i = b + len - 1 - if i > b + defaultHashNodes then i <- b + defaultHashNodes // limit the hash - let mutable acc = 0 - while (i >= b) do - // NOTE: GenericHash* call decreases nr - acc <- HashCombine i acc (iec.GetHashCode(x.GetValue(i))); - i <- i - 1 - acc - | _ -> - HashCombine 10 (x.GetLength(0)) (x.GetLength(1)) - - // Core implementation of structural hashing, corresponds to pseudo-code in the - // F# Language spec. Searches for the IStructuralHash interface, otherwise uses GetHashCode(). - // Arrays are structurally hashed through a separate technique. - // - // "iec" is either fsEqualityComparerUnlimitedHashingER, fsEqualityComparerUnlimitedHashingPER or a CountLimitedHasherPER. - let rec GenericHashParamObj (iec : System.Collections.IEqualityComparer) (x: obj) : int = - match x with - | null -> 0 - | (:? System.Array as a) -> - match a with - | :? (obj[]) as oa -> GenericHashObjArray iec oa - | :? (byte[]) as ba -> GenericHashByteArray ba - | :? (int[]) as ba -> GenericHashInt32Array ba - | :? (int64[]) as ba -> GenericHashInt64Array ba - | _ -> GenericHashArbArray iec a - | :? IStructuralEquatable as a -> - a.GetHashCode(iec) - | _ -> - x.GetHashCode() - - /// Fill in the implementation of CountLimitedHasherPER type CountLimitedHasherPER with @@ -1873,59 +1969,12 @@ namespace Microsoft.FSharp.Core override iec.Equals(x:obj,y:obj) = GenericEqualityObj false iec (x,y) override iec.GetHashCode(x:obj) = GenericHashParamObj iec x - /// Direct call to GetHashCode on the string type - let inline HashString (s:string) = - match s with - | null -> 0 - | _ -> (# "call instance int32 [mscorlib]System.String::GetHashCode()" s : int #) - - // from mscorlib v4.0.30319 - let inline HashChar (x:char) = (# "or" (# "shl" x 16 : int #) x : int #) - let inline HashSByte (x:sbyte) = (# "xor" (# "shl" x 8 : int #) x : int #) - let inline HashInt16 (x:int16) = (# "or" (# "conv.u2" x : int #) (# "shl" x 16 : int #) : int #) - let inline HashInt64 (x:int64) = (# "xor" (# "conv.i4" x : int #) (# "conv.i4" (# "shr" x 32 : int #) : int #) : int #) - let inline HashUInt64 (x:uint64) = (# "xor" (# "conv.i4" x : int #) (# "conv.i4" (# "shr.un" x 32 : int #) : int #) : int #) - let inline HashIntPtr (x:nativeint) = (# "conv.i4" (# "conv.u8" x : uint64 #) : int #) - let inline HashUIntPtr (x:unativeint) = (# "and" (# "conv.i4" (# "conv.u8" x : uint64 #) : int #) 0x7fffffff : int #) - - type GenericHashTCall<'T> = Func<'T, int> - - let tryGetGenericHashTCall (ty:Type) : obj = - match ty with - | ty when ty.Equals typeof -> box (GenericHashTCall (fun x -> (# "" x : int #))) - | ty when ty.Equals typeof -> box (GenericHashTCall (fun x -> (# "" x : int #))) - | ty when ty.Equals typeof -> box (GenericHashTCall (fun x -> (# "" x : int #))) - | ty when ty.Equals typeof -> box (GenericHashTCall (fun x -> (# "" x : int #))) - | ty when ty.Equals typeof -> box (GenericHashTCall HashChar) - | ty when ty.Equals typeof -> box (GenericHashTCall HashSByte) - | ty when ty.Equals typeof -> box (GenericHashTCall HashInt16) - | ty when ty.Equals typeof -> box (GenericHashTCall HashInt64) - | ty when ty.Equals typeof -> box (GenericHashTCall HashUInt64) - | ty when ty.Equals typeof -> box (GenericHashTCall HashIntPtr) - | ty when ty.Equals typeof -> box (GenericHashTCall HashUIntPtr) - | ty when ty.Equals typeof -> box (GenericHashTCall (fun x -> (# "" x : int #))) - | ty when ty.Equals typeof -> box (GenericHashTCall HashString) - | _ -> null - - let getGenericHashTCall<'T> () = - match tryGetGenericHashTCall typeof<'T> with - | :? GenericHashTCall<'T> as call -> call - | _ when canUseDefaultEqualityComparer typeof<'T> -> - let comparer = System.Collections.Generic.EqualityComparer<'T>.Default - GenericHashTCall<'T> (fun x -> avoid_tail_call_int (fun () -> comparer.GetHashCode x)) - | _ -> - GenericHashTCall<'T> (fun x -> GenericHashParamObj fsEqualityComparerUnlimitedHashingPER (box x)) - - type GenericHashT<'T> private () = - static let f = getGenericHashTCall<'T> () - static member inline GetHashCode x = f.Invoke x - /// Intrinsic for calls to depth-unlimited structural hashing that were not optimized by static conditionals. // // NOTE: The compiler optimizer is aware of this function (see uses of generic_hash_inner_vref in opt.fs) // and devirtualizes calls to it based on type "T". let GenericHashIntrinsic input = - avoid_tail_call_int (fun () -> GenericHashT<'T>.GetHashCode input) + FSharpEqualityComparer_PER<'T>.GetHashCode input /// Intrinsic for calls to depth-limited structural hashing that were not optimized by static conditionals. let LimitedGenericHashIntrinsic limit input = GenericHashParamObj (CountLimitedHasherPER(limit)) (box input) @@ -1939,7 +1988,7 @@ namespace Microsoft.FSharp.Core // and devirtualizes calls to it based on type "T". let GenericHashWithComparerIntrinsic<'T> (comp : System.Collections.IEqualityComparer) (input : 'T) : int = if obj.ReferenceEquals (comp, fsEqualityComparerUnlimitedHashingPER) then - avoid_tail_call_int (fun () -> GenericHashT<'T>.GetHashCode input) + FSharpEqualityComparer_PER<'T>.GetHashCode input else GenericHashParamObj comp (box input) @@ -2216,59 +2265,12 @@ namespace Microsoft.FSharp.Core member self.GetHashCode(x) = GenericLimitedHash limit x member self.Equals(x,y) = GenericEquality x y } - let BoolIEquality = MakeGenericEqualityComparer() - let CharIEquality = MakeGenericEqualityComparer() - let StringIEquality = MakeGenericEqualityComparer() - let SByteIEquality = MakeGenericEqualityComparer() - let Int16IEquality = MakeGenericEqualityComparer() - let Int32IEquality = MakeGenericEqualityComparer() - let Int64IEquality = MakeGenericEqualityComparer() - let IntPtrIEquality = MakeGenericEqualityComparer() - let ByteIEquality = MakeGenericEqualityComparer() - let UInt16IEquality = MakeGenericEqualityComparer() - let UInt32IEquality = MakeGenericEqualityComparer() - let UInt64IEquality = MakeGenericEqualityComparer() - let UIntPtrIEquality = MakeGenericEqualityComparer() - let FloatIEquality = MakeGenericEqualityComparer() - let Float32IEquality = MakeGenericEqualityComparer() - let DecimalIEquality = MakeGenericEqualityComparer() - - let tryGetFastGenericEqualityComparerTable (ty:Type) = - // TODO: Remove the ones that don't have special handling and thus just used default - match ty with - | ty when ty.Equals typeof -> box BoolIEquality - | ty when ty.Equals typeof -> box ByteIEquality - | ty when ty.Equals typeof -> box Int32IEquality - | ty when ty.Equals typeof -> box UInt32IEquality - | ty when ty.Equals typeof -> box CharIEquality - | ty when ty.Equals typeof -> box SByteIEquality - | ty when ty.Equals typeof -> box Int16IEquality - | ty when ty.Equals typeof -> box Int64IEquality - | ty when ty.Equals typeof -> box IntPtrIEquality - | ty when ty.Equals typeof -> box UInt16IEquality - | ty when ty.Equals typeof -> box UInt64IEquality - | ty when ty.Equals typeof -> box UIntPtrIEquality - | ty when ty.Equals typeof -> box FloatIEquality - | ty when ty.Equals typeof -> box Float32IEquality - | ty when ty.Equals typeof -> box DecimalIEquality - | ty when ty.Equals typeof -> box StringIEquality - | _ -> null - - let getFastGenericEqualityComparerTable<'T> () = - let ty = typeof<'T> - match tryGetFastGenericEqualityComparerTable ty with - | :? System.Collections.Generic.IEqualityComparer<'T> as comp -> comp - | _ when HashCompare.canUseDefaultEqualityComparer ty-> - unboxPrim (box System.Collections.Generic.EqualityComparer<'T>.Default) - | _ -> - MakeGenericEqualityComparer<'T>() - [] type FastGenericEqualityComparerTable<'T>() = - static let f = getFastGenericEqualityComparerTable<'T> () + static let f = HashCompare.FSharpEqualityComparer_PER<'T>.Comparer static member Function = f - let FastGenericEqualityComparerFromTable<'T> = FastGenericEqualityComparerTable<'T>.Function + let FastGenericEqualityComparerFromTable<'T> = FastGenericEqualityComparerTable<'T>.Function :> IEqualityComparer<'T> // This is the implementation of HashIdentity.Structural. In most cases this just becomes // FastGenericEqualityComparerFromTable. diff --git a/tests/fsharpqa/Source/Optimizations/GenericComparison/Compare07.il.bsl b/tests/fsharpqa/Source/Optimizations/GenericComparison/Compare07.il.bsl index b4c8337b1c2..70335b05d20 100644 --- a/tests/fsharpqa/Source/Optimizations/GenericComparison/Compare07.il.bsl +++ b/tests/fsharpqa/Source/Optimizations/GenericComparison/Compare07.il.bsl @@ -13,7 +13,7 @@ .assembly extern FSharp.Core { .publickeytoken = (B0 3F 5F 7F 11 D5 0A 3A ) // .?_....: - .ver 4:4:3:0 + .ver 4:4:1:0 } .assembly Compare07 { @@ -29,20 +29,20 @@ } .mresource public FSharpSignatureData.Compare07 { - // Offset: 0x00000000 Length: 0x0000089E + // Offset: 0x00000000 Length: 0x0000089A } .mresource public FSharpOptimizationData.Compare07 { - // Offset: 0x000008A8 Length: 0x0000069A + // Offset: 0x000008A0 Length: 0x00000692 } .module Compare07.dll -// MVID: {5B1B6346-05DE-F88E-A745-038346631B5B} +// MVID: {59B18AEE-05DE-F88E-A745-0383EE8AB159} .imagebase 0x00400000 .file alignment 0x00000200 .stackreserve 0x00100000 .subsystem 0x0003 // WINDOWS_CUI .corflags 0x00000001 // ILONLY -// Image base: 0x02B60000 +// Image base: 0x02BA0000 // =============== CLASS MEMBERS DECLARATION =================== @@ -187,7 +187,7 @@ [4] !a V_4, [5] !a V_5) .language '{AB4F38C9-B6E6-43BA-BE3B-58080B2CCCE3}', '{994B45C4-E6E9-11D2-903F-00C04FA302A1}', '{5A869D0B-6611-11D3-BD2A-0000F80849BD}' - .line 16707566,16707566 : 0,0 'C:\\src\\manofstick\\visualfsharp-nobox\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Compare07.fsx' + .line 16707566,16707566 : 0,0 'C:\\GitHub\\dsyme\\visualfsharp\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Compare07.fsx' IL_0000: ldarg.0 IL_0001: ldnull IL_0002: cgt.un @@ -633,7 +633,7 @@ instance bool Equals(object obj) cil managed { .custom instance void [mscorlib]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) - // Code size 20 (0x14) + // Code size 22 (0x16) .maxstack 4 .locals init ([0] class Compare07/CompareMicroPerfAndCodeGenerationTests/GenericKey`1 V_0) .line 4,4 : 10,20 '' @@ -641,17 +641,18 @@ IL_0001: isinst class Compare07/CompareMicroPerfAndCodeGenerationTests/GenericKey`1 IL_0006: stloc.0 IL_0007: ldloc.0 - IL_0008: brfalse.s IL_0012 + IL_0008: brfalse.s IL_0014 .line 16707566,16707566 : 0,0 '' IL_000a: ldarg.0 IL_000b: ldloc.0 - IL_000c: callvirt instance bool class Compare07/CompareMicroPerfAndCodeGenerationTests/GenericKey`1::Equals(class Compare07/CompareMicroPerfAndCodeGenerationTests/GenericKey`1) - IL_0011: ret + IL_000c: tail. + IL_000e: callvirt instance bool class Compare07/CompareMicroPerfAndCodeGenerationTests/GenericKey`1::Equals(class Compare07/CompareMicroPerfAndCodeGenerationTests/GenericKey`1) + IL_0013: ret .line 16707566,16707566 : 0,0 '' - IL_0012: ldc.i4.0 - IL_0013: ret + IL_0014: ldc.i4.0 + IL_0015: ret } // end of method GenericKey`1::Equals .property instance int32 Tag() diff --git a/tests/fsharpqa/Source/Optimizations/GenericComparison/Compare10.il.bsl b/tests/fsharpqa/Source/Optimizations/GenericComparison/Compare10.il.bsl index 55ccbcf4cf7..16bada503c5 100644 --- a/tests/fsharpqa/Source/Optimizations/GenericComparison/Compare10.il.bsl +++ b/tests/fsharpqa/Source/Optimizations/GenericComparison/Compare10.il.bsl @@ -13,7 +13,7 @@ .assembly extern FSharp.Core { .publickeytoken = (B0 3F 5F 7F 11 D5 0A 3A ) // .?_....: - .ver 4:4:3:0 + .ver 4:4:1:0 } .assembly Compare10 { @@ -29,20 +29,20 @@ } .mresource public FSharpSignatureData.Compare10 { - // Offset: 0x00000000 Length: 0x00000AA8 + // Offset: 0x00000000 Length: 0x00000AA4 } .mresource public FSharpOptimizationData.Compare10 { - // Offset: 0x00000AB0 Length: 0x0000058E + // Offset: 0x00000AA8 Length: 0x0000058E } .module Compare10.dll -// MVID: {5B1B6346-04BF-1753-A745-038346631B5B} +// MVID: {59B18AEE-04BF-1753-A745-0383EE8AB159} .imagebase 0x00400000 .file alignment 0x00000200 .stackreserve 0x00100000 .subsystem 0x0003 // WINDOWS_CUI .corflags 0x00000001 // ILONLY -// Image base: 0x01030000 +// Image base: 0x002E0000 // =============== CLASS MEMBERS DECLARATION =================== @@ -187,7 +187,7 @@ [4] int32 V_4, [5] int32 V_5) .language '{AB4F38C9-B6E6-43BA-BE3B-58080B2CCCE3}', '{994B45C4-E6E9-11D2-903F-00C04FA302A1}', '{5A869D0B-6611-11D3-BD2A-0000F80849BD}' - .line 16707566,16707566 : 0,0 'C:\\src\\manofstick\\visualfsharp-nobox\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Compare10.fsx' + .line 16707566,16707566 : 0,0 'C:\\GitHub\\dsyme\\visualfsharp\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Compare10.fsx' IL_0000: ldarg.0 IL_0001: ldnull IL_0002: cgt.un @@ -1330,7 +1330,7 @@ instance bool Equals(object obj) cil managed { .custom instance void [mscorlib]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) - // Code size 20 (0x14) + // Code size 22 (0x16) .maxstack 4 .locals init ([0] class Compare10/CompareMicroPerfAndCodeGenerationTests/KeyWithInnerKeys V_0) .line 5,5 : 10,26 '' @@ -1338,17 +1338,18 @@ IL_0001: isinst Compare10/CompareMicroPerfAndCodeGenerationTests/KeyWithInnerKeys IL_0006: stloc.0 IL_0007: ldloc.0 - IL_0008: brfalse.s IL_0012 + IL_0008: brfalse.s IL_0014 .line 16707566,16707566 : 0,0 '' IL_000a: ldarg.0 IL_000b: ldloc.0 - IL_000c: callvirt instance bool Compare10/CompareMicroPerfAndCodeGenerationTests/KeyWithInnerKeys::Equals(class Compare10/CompareMicroPerfAndCodeGenerationTests/KeyWithInnerKeys) - IL_0011: ret + IL_000c: tail. + IL_000e: callvirt instance bool Compare10/CompareMicroPerfAndCodeGenerationTests/KeyWithInnerKeys::Equals(class Compare10/CompareMicroPerfAndCodeGenerationTests/KeyWithInnerKeys) + IL_0013: ret .line 16707566,16707566 : 0,0 '' - IL_0012: ldc.i4.0 - IL_0013: ret + IL_0014: ldc.i4.0 + IL_0015: ret } // end of method KeyWithInnerKeys::Equals .property instance int32 Tag() diff --git a/tests/fsharpqa/Source/Optimizations/GenericComparison/Equals06.il.bsl b/tests/fsharpqa/Source/Optimizations/GenericComparison/Equals06.il.bsl index 4254bb088fe..91247bff24d 100644 --- a/tests/fsharpqa/Source/Optimizations/GenericComparison/Equals06.il.bsl +++ b/tests/fsharpqa/Source/Optimizations/GenericComparison/Equals06.il.bsl @@ -13,7 +13,7 @@ .assembly extern FSharp.Core { .publickeytoken = (B0 3F 5F 7F 11 D5 0A 3A ) // .?_....: - .ver 4:4:3:0 + .ver 4:4:1:0 } .assembly Equals06 { @@ -29,20 +29,20 @@ } .mresource public FSharpSignatureData.Equals06 { - // Offset: 0x00000000 Length: 0x0000089A + // Offset: 0x00000000 Length: 0x00000896 } .mresource public FSharpOptimizationData.Equals06 { - // Offset: 0x000008A0 Length: 0x00000696 + // Offset: 0x000008A0 Length: 0x0000068E } .module Equals06.dll -// MVID: {5B1B6346-0759-31EC-A745-038346631B5B} +// MVID: {59B18AEE-0759-31EC-A745-0383EE8AB159} .imagebase 0x00400000 .file alignment 0x00000200 .stackreserve 0x00100000 .subsystem 0x0003 // WINDOWS_CUI .corflags 0x00000001 // ILONLY -// Image base: 0x02B30000 +// Image base: 0x01B90000 // =============== CLASS MEMBERS DECLARATION =================== @@ -187,7 +187,7 @@ [4] !a V_4, [5] !a V_5) .language '{AB4F38C9-B6E6-43BA-BE3B-58080B2CCCE3}', '{994B45C4-E6E9-11D2-903F-00C04FA302A1}', '{5A869D0B-6611-11D3-BD2A-0000F80849BD}' - .line 16707566,16707566 : 0,0 'C:\\src\\manofstick\\visualfsharp-nobox\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Equals06.fsx' + .line 16707566,16707566 : 0,0 'C:\\GitHub\\dsyme\\visualfsharp\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Equals06.fsx' IL_0000: ldarg.0 IL_0001: ldnull IL_0002: cgt.un @@ -633,7 +633,7 @@ instance bool Equals(object obj) cil managed { .custom instance void [mscorlib]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) - // Code size 20 (0x14) + // Code size 22 (0x16) .maxstack 4 .locals init ([0] class Equals06/EqualsMicroPerfAndCodeGenerationTests/GenericKey`1 V_0) .line 4,4 : 10,20 '' @@ -641,17 +641,18 @@ IL_0001: isinst class Equals06/EqualsMicroPerfAndCodeGenerationTests/GenericKey`1 IL_0006: stloc.0 IL_0007: ldloc.0 - IL_0008: brfalse.s IL_0012 + IL_0008: brfalse.s IL_0014 .line 16707566,16707566 : 0,0 '' IL_000a: ldarg.0 IL_000b: ldloc.0 - IL_000c: callvirt instance bool class Equals06/EqualsMicroPerfAndCodeGenerationTests/GenericKey`1::Equals(class Equals06/EqualsMicroPerfAndCodeGenerationTests/GenericKey`1) - IL_0011: ret + IL_000c: tail. + IL_000e: callvirt instance bool class Equals06/EqualsMicroPerfAndCodeGenerationTests/GenericKey`1::Equals(class Equals06/EqualsMicroPerfAndCodeGenerationTests/GenericKey`1) + IL_0013: ret .line 16707566,16707566 : 0,0 '' - IL_0012: ldc.i4.0 - IL_0013: ret + IL_0014: ldc.i4.0 + IL_0015: ret } // end of method GenericKey`1::Equals .property instance int32 Tag() diff --git a/tests/fsharpqa/Source/Optimizations/GenericComparison/Equals09.il.bsl b/tests/fsharpqa/Source/Optimizations/GenericComparison/Equals09.il.bsl index cde1562a76b..8985acaa02b 100644 --- a/tests/fsharpqa/Source/Optimizations/GenericComparison/Equals09.il.bsl +++ b/tests/fsharpqa/Source/Optimizations/GenericComparison/Equals09.il.bsl @@ -13,7 +13,7 @@ .assembly extern FSharp.Core { .publickeytoken = (B0 3F 5F 7F 11 D5 0A 3A ) // .?_....: - .ver 4:4:3:0 + .ver 4:4:1:0 } .assembly Equals09 { @@ -29,20 +29,20 @@ } .mresource public FSharpSignatureData.Equals09 { - // Offset: 0x00000000 Length: 0x00000AA4 + // Offset: 0x00000000 Length: 0x00000AA0 } .mresource public FSharpOptimizationData.Equals09 { // Offset: 0x00000AA8 Length: 0x0000058B } .module Equals09.dll -// MVID: {5B1B6346-0759-46D9-A745-038346631B5B} +// MVID: {59B18AEE-0759-46D9-A745-0383EE8AB159} .imagebase 0x00400000 .file alignment 0x00000200 .stackreserve 0x00100000 .subsystem 0x0003 // WINDOWS_CUI .corflags 0x00000001 // ILONLY -// Image base: 0x02560000 +// Image base: 0x02720000 // =============== CLASS MEMBERS DECLARATION =================== @@ -187,7 +187,7 @@ [4] int32 V_4, [5] int32 V_5) .language '{AB4F38C9-B6E6-43BA-BE3B-58080B2CCCE3}', '{994B45C4-E6E9-11D2-903F-00C04FA302A1}', '{5A869D0B-6611-11D3-BD2A-0000F80849BD}' - .line 16707566,16707566 : 0,0 'C:\\src\\manofstick\\visualfsharp-nobox\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Equals09.fsx' + .line 16707566,16707566 : 0,0 'C:\\GitHub\\dsyme\\visualfsharp\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Equals09.fsx' IL_0000: ldarg.0 IL_0001: ldnull IL_0002: cgt.un @@ -1330,7 +1330,7 @@ instance bool Equals(object obj) cil managed { .custom instance void [mscorlib]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) - // Code size 20 (0x14) + // Code size 22 (0x16) .maxstack 4 .locals init ([0] class Equals09/EqualsMicroPerfAndCodeGenerationTests/KeyWithInnerKeys V_0) .line 5,5 : 10,26 '' @@ -1338,17 +1338,18 @@ IL_0001: isinst Equals09/EqualsMicroPerfAndCodeGenerationTests/KeyWithInnerKeys IL_0006: stloc.0 IL_0007: ldloc.0 - IL_0008: brfalse.s IL_0012 + IL_0008: brfalse.s IL_0014 .line 16707566,16707566 : 0,0 '' IL_000a: ldarg.0 IL_000b: ldloc.0 - IL_000c: callvirt instance bool Equals09/EqualsMicroPerfAndCodeGenerationTests/KeyWithInnerKeys::Equals(class Equals09/EqualsMicroPerfAndCodeGenerationTests/KeyWithInnerKeys) - IL_0011: ret + IL_000c: tail. + IL_000e: callvirt instance bool Equals09/EqualsMicroPerfAndCodeGenerationTests/KeyWithInnerKeys::Equals(class Equals09/EqualsMicroPerfAndCodeGenerationTests/KeyWithInnerKeys) + IL_0013: ret .line 16707566,16707566 : 0,0 '' - IL_0012: ldc.i4.0 - IL_0013: ret + IL_0014: ldc.i4.0 + IL_0015: ret } // end of method KeyWithInnerKeys::Equals .property instance int32 Tag() diff --git a/tests/fsharpqa/Source/Optimizations/GenericComparison/Hash09.il.bsl b/tests/fsharpqa/Source/Optimizations/GenericComparison/Hash09.il.bsl index 4cf28a5ff57..df7b115d207 100644 --- a/tests/fsharpqa/Source/Optimizations/GenericComparison/Hash09.il.bsl +++ b/tests/fsharpqa/Source/Optimizations/GenericComparison/Hash09.il.bsl @@ -13,7 +13,7 @@ .assembly extern FSharp.Core { .publickeytoken = (B0 3F 5F 7F 11 D5 0A 3A ) // .?_....: - .ver 4:4:3:0 + .ver 4:4:1:0 } .assembly Hash09 { @@ -29,20 +29,20 @@ } .mresource public FSharpSignatureData.Hash09 { - // Offset: 0x00000000 Length: 0x00000892 + // Offset: 0x00000000 Length: 0x0000088E } .mresource public FSharpOptimizationData.Hash09 { - // Offset: 0x00000898 Length: 0x0000068E + // Offset: 0x00000898 Length: 0x00000686 } .module Hash09.dll -// MVID: {5B1B6346-9642-77DB-A745-038346631B5B} +// MVID: {59B18AEE-9642-77DB-A745-0383EE8AB159} .imagebase 0x00400000 .file alignment 0x00000200 .stackreserve 0x00100000 .subsystem 0x0003 // WINDOWS_CUI .corflags 0x00000001 // ILONLY -// Image base: 0x025D0000 +// Image base: 0x00690000 // =============== CLASS MEMBERS DECLARATION =================== @@ -187,7 +187,7 @@ [4] !a V_4, [5] !a V_5) .language '{AB4F38C9-B6E6-43BA-BE3B-58080B2CCCE3}', '{994B45C4-E6E9-11D2-903F-00C04FA302A1}', '{5A869D0B-6611-11D3-BD2A-0000F80849BD}' - .line 16707566,16707566 : 0,0 'C:\\src\\manofstick\\visualfsharp-nobox\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Hash09.fsx' + .line 16707566,16707566 : 0,0 'C:\\GitHub\\dsyme\\visualfsharp\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Hash09.fsx' IL_0000: ldarg.0 IL_0001: ldnull IL_0002: cgt.un @@ -633,7 +633,7 @@ instance bool Equals(object obj) cil managed { .custom instance void [mscorlib]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) - // Code size 20 (0x14) + // Code size 22 (0x16) .maxstack 4 .locals init ([0] class Hash09/HashMicroPerfAndCodeGenerationTests/GenericKey`1 V_0) .line 4,4 : 10,20 '' @@ -641,17 +641,18 @@ IL_0001: isinst class Hash09/HashMicroPerfAndCodeGenerationTests/GenericKey`1 IL_0006: stloc.0 IL_0007: ldloc.0 - IL_0008: brfalse.s IL_0012 + IL_0008: brfalse.s IL_0014 .line 16707566,16707566 : 0,0 '' IL_000a: ldarg.0 IL_000b: ldloc.0 - IL_000c: callvirt instance bool class Hash09/HashMicroPerfAndCodeGenerationTests/GenericKey`1::Equals(class Hash09/HashMicroPerfAndCodeGenerationTests/GenericKey`1) - IL_0011: ret + IL_000c: tail. + IL_000e: callvirt instance bool class Hash09/HashMicroPerfAndCodeGenerationTests/GenericKey`1::Equals(class Hash09/HashMicroPerfAndCodeGenerationTests/GenericKey`1) + IL_0013: ret .line 16707566,16707566 : 0,0 '' - IL_0012: ldc.i4.0 - IL_0013: ret + IL_0014: ldc.i4.0 + IL_0015: ret } // end of method GenericKey`1::Equals .property instance int32 Tag() diff --git a/tests/fsharpqa/Source/Optimizations/GenericComparison/Hash12.il.bsl b/tests/fsharpqa/Source/Optimizations/GenericComparison/Hash12.il.bsl index 8836ff15748..9c5bfb73cf3 100644 --- a/tests/fsharpqa/Source/Optimizations/GenericComparison/Hash12.il.bsl +++ b/tests/fsharpqa/Source/Optimizations/GenericComparison/Hash12.il.bsl @@ -13,7 +13,7 @@ .assembly extern FSharp.Core { .publickeytoken = (B0 3F 5F 7F 11 D5 0A 3A ) // .?_....: - .ver 4:4:3:0 + .ver 4:4:1:0 } .assembly Hash12 { @@ -29,20 +29,20 @@ } .mresource public FSharpSignatureData.Hash12 { - // Offset: 0x00000000 Length: 0x00000A9C + // Offset: 0x00000000 Length: 0x00000A98 } .mresource public FSharpOptimizationData.Hash12 { // Offset: 0x00000AA0 Length: 0x00000585 } .module Hash12.dll -// MVID: {5B1B6346-9661-796E-A745-038346631B5B} +// MVID: {59B18AEE-9661-796E-A745-0383EE8AB159} .imagebase 0x00400000 .file alignment 0x00000200 .stackreserve 0x00100000 .subsystem 0x0003 // WINDOWS_CUI .corflags 0x00000001 // ILONLY -// Image base: 0x02810000 +// Image base: 0x01080000 // =============== CLASS MEMBERS DECLARATION =================== @@ -187,7 +187,7 @@ [4] int32 V_4, [5] int32 V_5) .language '{AB4F38C9-B6E6-43BA-BE3B-58080B2CCCE3}', '{994B45C4-E6E9-11D2-903F-00C04FA302A1}', '{5A869D0B-6611-11D3-BD2A-0000F80849BD}' - .line 16707566,16707566 : 0,0 'C:\\src\\manofstick\\visualfsharp-nobox\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Hash12.fsx' + .line 16707566,16707566 : 0,0 'C:\\GitHub\\dsyme\\visualfsharp\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Hash12.fsx' IL_0000: ldarg.0 IL_0001: ldnull IL_0002: cgt.un @@ -1330,7 +1330,7 @@ instance bool Equals(object obj) cil managed { .custom instance void [mscorlib]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) - // Code size 20 (0x14) + // Code size 22 (0x16) .maxstack 4 .locals init ([0] class Hash12/HashMicroPerfAndCodeGenerationTests/KeyWithInnerKeys V_0) .line 5,5 : 10,26 '' @@ -1338,17 +1338,18 @@ IL_0001: isinst Hash12/HashMicroPerfAndCodeGenerationTests/KeyWithInnerKeys IL_0006: stloc.0 IL_0007: ldloc.0 - IL_0008: brfalse.s IL_0012 + IL_0008: brfalse.s IL_0014 .line 16707566,16707566 : 0,0 '' IL_000a: ldarg.0 IL_000b: ldloc.0 - IL_000c: callvirt instance bool Hash12/HashMicroPerfAndCodeGenerationTests/KeyWithInnerKeys::Equals(class Hash12/HashMicroPerfAndCodeGenerationTests/KeyWithInnerKeys) - IL_0011: ret + IL_000c: tail. + IL_000e: callvirt instance bool Hash12/HashMicroPerfAndCodeGenerationTests/KeyWithInnerKeys::Equals(class Hash12/HashMicroPerfAndCodeGenerationTests/KeyWithInnerKeys) + IL_0013: ret .line 16707566,16707566 : 0,0 '' - IL_0012: ldc.i4.0 - IL_0013: ret + IL_0014: ldc.i4.0 + IL_0015: ret } // end of method KeyWithInnerKeys::Equals .property instance int32 Tag() From cb29dbbf9c9ec1c230d630c5b3677e1200d84c3b Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Thu, 14 Jun 2018 19:17:46 +1000 Subject: [PATCH 18/92] Removed comparers that matched EqualityComparer<>.Default and code review changes --- src/fsharp/FSharp.Core/prim-types.fs | 169 +++++++-------------------- 1 file changed, 43 insertions(+), 126 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index 885ce8b8505..184ec962bfc 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -1666,146 +1666,67 @@ namespace Microsoft.FSharp.Core let canUseDefaultEqualityComparer (ty:Type) = let processed = System.Collections.Generic.HashSet () - let rec recurse idx (types:array) = + let rec checkType idx (types:Type[]) = if idx = types.Length then true else let ty = get types idx if not (processed.Add ty) then - recurse (idx+1) types + checkType (idx+1) types else let isValidGenericType ifNotType fullname = if not (ty.IsGenericType && ty.GetGenericTypeDefinition().FullName.Equals fullname) then ifNotType - else recurse 0 (ty.GetGenericArguments ()) + else checkType 0 (ty.GetGenericArguments ()) + let isTypeAndGenericArgumentsOK fullname = isValidGenericType false fullname + let isNotTypeOrIsTypeAndGenericArgumentsOK fullname = isValidGenericType true fullname // avoid any types that need special handling in GenericEqualityObj - true - && ty.IsSealed // covers enum and value types + // GenericEqualityObj handles string as a special cases, but internally routes to same equality + + ty.IsSealed // covers enum and value types + // ref types need to be sealed as derived class might implement IStructuralEquatable && not ty.IsArray - && not (ty.Equals typeof) - && not (ty.Equals typeof) && not (ty.Equals typeof) && not (ty.Equals typeof) - && isValidGenericType true "System.Nullable`1" + && isNotTypeOrIsTypeAndGenericArgumentsOK "System.Nullable`1" && not (typeof.IsAssignableFrom ty - && not (false - || isValidGenericType false "System.ValueTuple`1" - || isValidGenericType false "System.ValueTuple`2" - || isValidGenericType false "System.ValueTuple`3" - || isValidGenericType false "System.ValueTuple`4" - || isValidGenericType false "System.ValueTuple`5" - || isValidGenericType false "System.ValueTuple`6" - || isValidGenericType false "System.ValueTuple`7" - || isValidGenericType false "System.ValueTuple`8")) - && recurse (idx+1) types - - recurse 0 [|ty|] + // we accept ValueTuple even though it supports IStructuralEquatable + // if all generic arguements pass check + && not ( isTypeAndGenericArgumentsOK "System.ValueTuple`1" + || isTypeAndGenericArgumentsOK "System.ValueTuple`2" + || isTypeAndGenericArgumentsOK "System.ValueTuple`3" + || isTypeAndGenericArgumentsOK "System.ValueTuple`4" + || isTypeAndGenericArgumentsOK "System.ValueTuple`5" + || isTypeAndGenericArgumentsOK "System.ValueTuple`6" + || isTypeAndGenericArgumentsOK "System.ValueTuple`7" + || isTypeAndGenericArgumentsOK "System.ValueTuple`8")) + && checkType (idx+1) types + + checkType 0 [|ty|] let tryGetFSharpEqualityComparer (er:bool) (ty:Type) : obj = match er, ty with - | _, ty when ty.Equals typeof -> box { - new EqualityComparer() with - member __.Equals (x,y) = System.String.Equals (x, y) - member __.GetHashCode x = HashString x } - - | _, ty when ty.Equals typeof -> box { - new EqualityComparer() with - member __.Equals (x,y) = System.Decimal.op_Equality (x, y) - member __.GetHashCode x = x.GetHashCode () } - - | _, ty when ty.Equals typeof -> box { - new EqualityComparer() with - member __.Equals (x,y) = (# "ceq" x y : bool #) - member __.GetHashCode x = (# "" x : int #) } - - | _, ty when ty.Equals typeof -> box { - new EqualityComparer() with - member __.Equals (x,y) = (# "ceq" x y : bool #) - member __.GetHashCode x = HashSByte x } - - | _, ty when ty.Equals typeof -> box { - new EqualityComparer() with - member __.Equals (x,y) = (# "ceq" x y : bool #) - member __.GetHashCode x = HashInt16 x } - - | _, ty when ty.Equals typeof -> box { - new EqualityComparer() with - member __.Equals (x,y) = (# "ceq" x y : bool #) - member __.GetHashCode x = (# "" x : int #) } - - | _, ty when ty.Equals typeof -> box { - new EqualityComparer() with - member __.Equals (x,y) = (# "ceq" x y : bool #) - member __.GetHashCode x = HashInt64 x } - - | _, ty when ty.Equals typeof -> box { - new EqualityComparer() with - member __.Equals (x,y) = (# "ceq" x y : bool #) - member __.GetHashCode x = (# "" x : int #) } - - | _, ty when ty.Equals typeof -> box { - new EqualityComparer() with - member __.Equals (x,y) = (# "ceq" x y : bool #) - member __.GetHashCode x = (# "" x : int #) } - - | _, ty when ty.Equals typeof -> box { - new EqualityComparer() with - member __.Equals (x,y) = (# "ceq" x y : bool #) - member __.GetHashCode x = (# "" x : int #) } - - | _, ty when ty.Equals typeof -> box { - new EqualityComparer() with - member __.Equals (x,y) = (# "ceq" x y : bool #) - member __.GetHashCode x = HashUInt64 x } - - | _, ty when ty.Equals typeof -> box { - new EqualityComparer() with - member __.Equals (x,y) = (# "ceq" x y : bool #) - member __.GetHashCode x = HashIntPtr x } - - | _, ty when ty.Equals typeof -> box { - new EqualityComparer() with - member __.Equals (x,y) = (# "ceq" x y : bool #) - member __.GetHashCode x = HashUIntPtr x } - - | _, ty when ty.Equals typeof -> box { - new EqualityComparer() with - member __.Equals (x,y) = (# "ceq" x y : bool #) - member __.GetHashCode x = HashChar x } - - | false, ty when ty.Equals typeof -> box { - new EqualityComparer() with - member __.Equals (x,y) = (# "ceq" x y : bool #) - member __.GetHashCode x = x.GetHashCode () } - - | false, ty when ty.Equals typeof -> box { - new EqualityComparer() with - member __.Equals (x,y) = (# "ceq" x y : bool #) - member __.GetHashCode x = x.GetHashCode () } - - | true, ty when ty.Equals typeof -> box { - new EqualityComparer() with - member __.Equals (x,y) = (# "ceq" x y : bool #) || (not ((# "ceq" x x : bool #) || (# "ceq" y y : bool #))) - member __.GetHashCode x = x.GetHashCode () } - - | true, ty when ty.Equals typeof -> box { - new EqualityComparer() with - member __.Equals (x,y) = (# "ceq" x y : bool #) || (not ((# "ceq" x x : bool #) || (# "ceq" y y : bool #))) - member __.GetHashCode x = x.GetHashCode () } - + | false, ty when ty.Equals typeof -> + box { new EqualityComparer() with + member __.Equals (x,y) = (# "ceq" x y : bool #) + member __.GetHashCode x = x.GetHashCode () } + | false, ty when ty.Equals typeof -> + box { new EqualityComparer() with + member __.Equals (x,y) = (# "ceq" x y : bool #) + member __.GetHashCode x = x.GetHashCode () } + | true, ty when ty.Equals typeof -> box EqualityComparer.Default + | true, ty when ty.Equals typeof -> box EqualityComparer.Default | _ -> null - let genericFSharpEqualityComparer_ER<'T> () = { - new EqualityComparer<'T>() with + let genericFSharpEqualityComparer_ER<'T> () = + { new EqualityComparer<'T>() with member __.Equals (x,y) = GenericEqualityObj true fsEqualityComparerUnlimitedHashingER (box x, box y) - member __.GetHashCode x = GenericHashParamObj fsEqualityComparerUnlimitedHashingPER (box x) - } + member __.GetHashCode x = GenericHashParamObj fsEqualityComparerUnlimitedHashingPER (box x) } - let genericFSharpEqualityComparer_PER<'T> () = { - new EqualityComparer<'T>() with + let genericFSharpEqualityComparer_PER<'T> () = + { new EqualityComparer<'T>() with member __.Equals (x,y) = GenericEqualityObj false fsEqualityComparerUnlimitedHashingPER (box x, box y) - member __.GetHashCode x = GenericHashParamObj fsEqualityComparerUnlimitedHashingPER (box x) - } + member __.GetHashCode x = GenericHashParamObj fsEqualityComparerUnlimitedHashingPER (box x) } let getGenericEquality<'T> er = match tryGetFSharpEqualityComparer er typeof<'T> with @@ -1977,7 +1898,8 @@ namespace Microsoft.FSharp.Core FSharpEqualityComparer_PER<'T>.GetHashCode input /// Intrinsic for calls to depth-limited structural hashing that were not optimized by static conditionals. - let LimitedGenericHashIntrinsic limit input = GenericHashParamObj (CountLimitedHasherPER(limit)) (box input) + let LimitedGenericHashIntrinsic limit input = + GenericHashParamObj (CountLimitedHasherPER(limit)) (box input) /// Intrinsic for a recursive call to structural hashing that was not optimized by static conditionals. // @@ -2252,7 +2174,6 @@ namespace Microsoft.FSharp.Core // LanguagePrimitives: PUBLISH IEqualityComparer AND IComparer OBJECTS //------------------------------------------------------------------------- - let inline MakeGenericEqualityComparer<'T>() = // type-specialize some common cases to generate more efficient functions { new System.Collections.Generic.IEqualityComparer<'T> with @@ -2265,12 +2186,8 @@ namespace Microsoft.FSharp.Core member self.GetHashCode(x) = GenericLimitedHash limit x member self.Equals(x,y) = GenericEquality x y } - [] - type FastGenericEqualityComparerTable<'T>() = - static let f = HashCompare.FSharpEqualityComparer_PER<'T>.Comparer - static member Function = f - - let FastGenericEqualityComparerFromTable<'T> = FastGenericEqualityComparerTable<'T>.Function :> IEqualityComparer<'T> + let FastGenericEqualityComparerFromTable<'T> = + HashCompare.FSharpEqualityComparer_PER<'T>.Comparer :> IEqualityComparer<'T> // This is the implementation of HashIdentity.Structural. In most cases this just becomes // FastGenericEqualityComparerFromTable. From 23cc296666ea64dbd842f6c6652e2a47c844eefa Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sat, 16 Jun 2018 14:19:31 +1000 Subject: [PATCH 19/92] Added additional types where EqualityComparer.Default can be used --- src/fsharp/FSharp.Core/prim-types.fs | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index 184ec962bfc..6ad5a57a0e3 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -1663,7 +1663,7 @@ namespace Microsoft.FSharp.Core override iec.Equals(x:obj,y:obj) = GenericEqualityObj true iec (x,y) // ER Semantics override iec.GetHashCode(x:obj) = raise (InvalidOperationException (SR.GetString(SR.notUsedForHashing))) } - let canUseDefaultEqualityComparer (ty:Type) = + let canUseDefaultEqualityComparer er (rootType:Type) = let processed = System.Collections.Generic.HashSet () let rec checkType idx (types:Type[]) = @@ -1686,8 +1686,8 @@ namespace Microsoft.FSharp.Core ty.IsSealed // covers enum and value types // ref types need to be sealed as derived class might implement IStructuralEquatable && not ty.IsArray - && not (ty.Equals typeof) - && not (ty.Equals typeof) + && (er || (not (ty.Equals typeof))) + && (er || (not (ty.Equals typeof))) && isNotTypeOrIsTypeAndGenericArgumentsOK "System.Nullable`1" && not (typeof.IsAssignableFrom ty // we accept ValueTuple even though it supports IStructuralEquatable @@ -1699,10 +1699,16 @@ namespace Microsoft.FSharp.Core || isTypeAndGenericArgumentsOK "System.ValueTuple`5" || isTypeAndGenericArgumentsOK "System.ValueTuple`6" || isTypeAndGenericArgumentsOK "System.ValueTuple`7" - || isTypeAndGenericArgumentsOK "System.ValueTuple`8")) + || isTypeAndGenericArgumentsOK "System.ValueTuple`8" + || isTypeAndGenericArgumentsOK "Microsoft.FSharp.Collections.FSharpList`1" + || isTypeAndGenericArgumentsOK "Microsoft.FSharp.Core.FSharpOption`1" + || isTypeAndGenericArgumentsOK "Microsoft.FSharp.Core.FSharpValueOption`1" + || isTypeAndGenericArgumentsOK "Microsoft.FSharp.Core.FSharpResult`2" + ) + ) && checkType (idx+1) types - checkType 0 [|ty|] + checkType 0 [|rootType|] let tryGetFSharpEqualityComparer (er:bool) (ty:Type) : obj = match er, ty with @@ -1731,7 +1737,7 @@ namespace Microsoft.FSharp.Core let getGenericEquality<'T> er = match tryGetFSharpEqualityComparer er typeof<'T> with | :? EqualityComparer<'T> as call -> call - | _ when canUseDefaultEqualityComparer typeof<'T> -> EqualityComparer<'T>.Default + | _ when canUseDefaultEqualityComparer er typeof<'T> -> EqualityComparer<'T>.Default | _ when er -> genericFSharpEqualityComparer_ER<'T> () | _ -> genericFSharpEqualityComparer_PER<'T> () From e89986ee978615185988dfd262861b5c513b9842 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sat, 16 Jun 2018 17:20:03 +1000 Subject: [PATCH 20/92] Save unnecessary type checks when more information is known --- src/fsharp/FSharp.Core/prim-types.fs | 66 ++++++++++++++++++++++++---- 1 file changed, 57 insertions(+), 9 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index 6ad5a57a0e3..9b04318e7e4 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -1663,6 +1663,9 @@ namespace Microsoft.FSharp.Core override iec.Equals(x:obj,y:obj) = GenericEqualityObj true iec (x,y) // ER Semantics override iec.GetHashCode(x:obj) = raise (InvalidOperationException (SR.GetString(SR.notUsedForHashing))) } + let isStructuralEquatable (ty:Type) = typeof.IsAssignableFrom ty + let isArray (ty:Type) = ty.IsArray || (typeof.IsAssignableFrom ty) + let canUseDefaultEqualityComparer er (rootType:Type) = let processed = System.Collections.Generic.HashSet () @@ -1685,11 +1688,11 @@ namespace Microsoft.FSharp.Core ty.IsSealed // covers enum and value types // ref types need to be sealed as derived class might implement IStructuralEquatable - && not ty.IsArray + && not (isArray ty) && (er || (not (ty.Equals typeof))) && (er || (not (ty.Equals typeof))) && isNotTypeOrIsTypeAndGenericArgumentsOK "System.Nullable`1" - && not (typeof.IsAssignableFrom ty + && not (isStructuralEquatable ty // we accept ValueTuple even though it supports IStructuralEquatable // if all generic arguements pass check && not ( isTypeAndGenericArgumentsOK "System.ValueTuple`1" @@ -1724,22 +1727,67 @@ namespace Microsoft.FSharp.Core | true, ty when ty.Equals typeof -> box EqualityComparer.Default | _ -> null - let genericFSharpEqualityComparer_ER<'T> () = + let arrayEqualityComparer<'T> er comparer = + let arrayEquals (er:bool) (iec:System.Collections.IEqualityComparer) (xobj:obj) (yobj:obj) : bool = + match xobj,yobj with + | null, null -> true + | null, _ -> false + | _, null -> false + | (:? (obj[]) as arr1), (:? (obj[]) as arr2) -> GenericEqualityObjArray er iec arr1 arr2 + | (:? (byte[]) as arr1), (:? (byte[]) as arr2) -> GenericEqualityByteArray arr1 arr2 + | (:? (int32[]) as arr1), (:? (int32[]) as arr2) -> GenericEqualityInt32Array arr1 arr2 + | (:? (int64[]) as arr1), (:? (int64[]) as arr2) -> GenericEqualityInt64Array arr1 arr2 + | (:? (char[]) as arr1), (:? (char[]) as arr2) -> GenericEqualityCharArray arr1 arr2 + | (:? (float32[]) as arr1), (:? (float32[]) as arr2) -> GenericEqualitySingleArray er arr1 arr2 + | (:? (float[]) as arr1), (:? (float[]) as arr2) -> GenericEqualityDoubleArray er arr1 arr2 + | (:? System.Array as arr1), (:? System.Array as arr2) -> GenericEqualityArbArray er iec arr1 arr2 + | _ -> raise (Exception "invalid logic - expected array") + + let getHashCode iec (xobj:obj) = + match xobj with + | null -> 0 + | :? (obj[]) as oa -> GenericHashObjArray iec oa + | :? (byte[]) as ba -> GenericHashByteArray ba + | :? (int[]) as ba -> GenericHashInt32Array ba + | :? (int64[]) as ba -> GenericHashInt64Array ba + | :? System.Array as a -> GenericHashArbArray iec a + | _ -> raise (Exception "invalid logic - expected array") + { new EqualityComparer<'T>() with - member __.Equals (x,y) = GenericEqualityObj true fsEqualityComparerUnlimitedHashingER (box x, box y) - member __.GetHashCode x = GenericHashParamObj fsEqualityComparerUnlimitedHashingPER (box x) } + member __.Equals (x, y) = arrayEquals er comparer (box x) (box y) + member __.GetHashCode x = getHashCode fsEqualityComparerUnlimitedHashingPER (box x) } - let genericFSharpEqualityComparer_PER<'T> () = + let structuralEqualityComparer<'T> comparer = + { new EqualityComparer<'T>() with + member __.Equals (x,y) = + match box x, box y with + | null, null -> true + | null, _ -> false + | _, null -> false + | (:? IStructuralEquatable as x1), yobj -> x1.Equals (yobj, comparer) + | _ -> raise (Exception "invalid logic - expected IStructuralEquatable") + + member __.GetHashCode x = + match box x with + | null -> 0 + | :? IStructuralEquatable as a -> a.GetHashCode fsEqualityComparerUnlimitedHashingPER + | _ -> raise (Exception "invalid logic - expected IStructuralEquatable") } + + let unknownEqualityComparer<'T> er comparer = { new EqualityComparer<'T>() with - member __.Equals (x,y) = GenericEqualityObj false fsEqualityComparerUnlimitedHashingPER (box x, box y) + member __.Equals (x,y) = GenericEqualityObj er comparer (box x, box y) member __.GetHashCode x = GenericHashParamObj fsEqualityComparerUnlimitedHashingPER (box x) } let getGenericEquality<'T> er = match tryGetFSharpEqualityComparer er typeof<'T> with | :? EqualityComparer<'T> as call -> call | _ when canUseDefaultEqualityComparer er typeof<'T> -> EqualityComparer<'T>.Default - | _ when er -> genericFSharpEqualityComparer_ER<'T> () - | _ -> genericFSharpEqualityComparer_PER<'T> () + | _ when isArray typeof<'T> && er -> arrayEqualityComparer true fsEqualityComparerUnlimitedHashingER + | _ when isArray typeof<'T> -> arrayEqualityComparer false fsEqualityComparerUnlimitedHashingPER + | _ when isStructuralEquatable typeof<'T> && er -> structuralEqualityComparer fsEqualityComparerUnlimitedHashingER + | _ when isStructuralEquatable typeof<'T> -> structuralEqualityComparer fsEqualityComparerUnlimitedHashingPER + | _ when er -> unknownEqualityComparer true fsEqualityComparerUnlimitedHashingER + | _ -> unknownEqualityComparer false fsEqualityComparerUnlimitedHashingPER type FSharpEqualityComparer_ER<'T> private () = static let comparer = getGenericEquality<'T> true From 4d65fcdc2ca05ae56b3d0e5a52c4f7ea4f4941a9 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Mon, 18 Jun 2018 17:48:34 +1000 Subject: [PATCH 21/92] Removed now unused objects, and other minor cleanup --- src/fsharp/FSharp.Core/prim-types.fs | 45 +++++++--------------------- 1 file changed, 11 insertions(+), 34 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index 9b04318e7e4..ca0ef1398c8 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -1484,8 +1484,8 @@ namespace Microsoft.FSharp.Core // Run in either PER or ER mode. In PER mode, equality involving a NaN returns "false". // In ER mode, equality on two NaNs returns "true". // - // If "er" is true the "iec" is fsEqualityComparerNoHashingER - // If "er" is false the "iec" is fsEqualityComparerNoHashingPER + // If "er" is true the "iec" is fsEqualityComparerUnlimitedHashingER + // If "er" is false the "iec" is fsEqualityComparerUnlimitedHashingPER let rec GenericEqualityObj (er:bool) (iec:System.Collections.IEqualityComparer) ((xobj:obj),(yobj:obj)) : bool = (*if objEq xobj yobj then true else *) match xobj,yobj with @@ -1648,21 +1648,6 @@ namespace Microsoft.FSharp.Core else i <- i + 1 res - - /// One of the two unique instances of System.Collections.IEqualityComparer. Implements PER semantics - /// where equality on NaN returns "false". - let fsEqualityComparerNoHashingPER = - { new System.Collections.IEqualityComparer with - override iec.Equals(x:obj,y:obj) = GenericEqualityObj false iec (x,y) // PER Semantics - override iec.GetHashCode(x:obj) = raise (InvalidOperationException (SR.GetString(SR.notUsedForHashing))) } - - /// One of the two unique instances of System.Collections.IEqualityComparer. Implements ER semantics - /// where equality on NaN returns "true". - let fsEqualityComparerNoHashingER = - { new System.Collections.IEqualityComparer with - override iec.Equals(x:obj,y:obj) = GenericEqualityObj true iec (x,y) // ER Semantics - override iec.GetHashCode(x:obj) = raise (InvalidOperationException (SR.GetString(SR.notUsedForHashing))) } - let isStructuralEquatable (ty:Type) = typeof.IsAssignableFrom ty let isArray (ty:Type) = ty.IsArray || (typeof.IsAssignableFrom ty) @@ -1791,26 +1776,18 @@ namespace Microsoft.FSharp.Core type FSharpEqualityComparer_ER<'T> private () = static let comparer = getGenericEquality<'T> true - static member Comparer = comparer - static member inline Equals (x, y) = comparer.Equals (x, y) - static member inline GetHashCode x = comparer.GetHashCode x - type FSharpEqualityComparer_PER<'T> private () = static let comparer = getGenericEquality<'T> false - static member Comparer = comparer - static member inline Equals (x, y) = comparer.Equals (x, y) - static member inline GetHashCode x = comparer.GetHashCode x - /// Implements generic equality between two values, with PER semantics for NaN (so equality on two NaN values returns false) // // The compiler optimizer is aware of this function (see use of generic_equality_per_inner_vref in opt.fs) // and devirtualizes calls to it based on "T". let GenericEqualityIntrinsic (x : 'T) (y : 'T) : bool = - FSharpEqualityComparer_PER<'T>.Equals (x, y) + FSharpEqualityComparer_PER<'T>.Comparer.Equals (x, y) /// Implements generic equality between two values, with ER semantics for NaN (so equality on two NaN values returns true) // @@ -1819,18 +1796,18 @@ namespace Microsoft.FSharp.Core // The compiler optimizer is aware of this function (see use of generic_equality_er_inner_vref in opt.fs) // and devirtualizes calls to it based on "T". let GenericEqualityERIntrinsic (x : 'T) (y : 'T) : bool = - FSharpEqualityComparer_ER<'T>.Equals (x, y) + FSharpEqualityComparer_ER<'T>.Comparer.Equals (x, y) /// Implements generic equality between two values using "comp" for recursive calls. // // The compiler optimizer is aware of this function (see use of generic_equality_withc_inner_vref in opt.fs) // and devirtualizes calls to it based on "T", and under the assumption that "comp" - // is either fsEqualityComparerNoHashingER or fsEqualityComparerNoHashingPER. + // is either fsEqualityComparerUnlimitedHashingER or fsEqualityComparerUnlimitedHashingPER. let GenericEqualityWithComparerIntrinsic (comp : System.Collections.IEqualityComparer) (x : 'T) (y : 'T) : bool = - if obj.ReferenceEquals (comp, fsEqualityComparerUnlimitedHashingPER) || obj.ReferenceEquals (comp, fsEqualityComparerNoHashingPER) then - FSharpEqualityComparer_PER<'T>.Equals (x, y) - elif obj.ReferenceEquals (comp, fsEqualityComparerNoHashingER) then - FSharpEqualityComparer_ER<'T>.Equals (x, y) + if obj.ReferenceEquals (comp, fsEqualityComparerUnlimitedHashingPER) then + FSharpEqualityComparer_PER<'T>.Comparer.Equals (x, y) + elif obj.ReferenceEquals (comp, fsEqualityComparerUnlimitedHashingER) then + FSharpEqualityComparer_ER<'T>.Comparer.Equals (x, y) else comp.Equals (box x, box y) @@ -1949,7 +1926,7 @@ namespace Microsoft.FSharp.Core // NOTE: The compiler optimizer is aware of this function (see uses of generic_hash_inner_vref in opt.fs) // and devirtualizes calls to it based on type "T". let GenericHashIntrinsic input = - FSharpEqualityComparer_PER<'T>.GetHashCode input + FSharpEqualityComparer_PER<'T>.Comparer.GetHashCode input /// Intrinsic for calls to depth-limited structural hashing that were not optimized by static conditionals. let LimitedGenericHashIntrinsic limit input = @@ -1964,7 +1941,7 @@ namespace Microsoft.FSharp.Core // and devirtualizes calls to it based on type "T". let GenericHashWithComparerIntrinsic<'T> (comp : System.Collections.IEqualityComparer) (input : 'T) : int = if obj.ReferenceEquals (comp, fsEqualityComparerUnlimitedHashingPER) then - FSharpEqualityComparer_PER<'T>.GetHashCode input + FSharpEqualityComparer_PER<'T>.Comparer.GetHashCode input else GenericHashParamObj comp (box input) From 69e954b4629345f8831f28ac459bf9c4d43215f9 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sat, 23 Jun 2018 10:34:03 +1000 Subject: [PATCH 22/92] Modified Optimizer to manually inline GenericEqualityIntrinsic and friends (as they have special handling) --- src/fsharp/FSharp.Core/prim-types.fs | 29 +++++-- src/fsharp/FSharp.Core/prim-types.fsi | 20 +++++ src/fsharp/Optimizer.fs | 25 ++++-- src/fsharp/TcGlobals.fs | 7 ++ .../Linq101Joins01.il.bsl | 83 +++++++++++-------- .../StaticInit/StaticInit_Struct01.il.bsl | 43 ++++++---- .../GenericComparison/Compare07.il.bsl | 80 +++++++++--------- .../GenericComparison/Equals06.il.bsl | 80 +++++++++--------- .../GenericComparison/Equals07.il.bsl | 45 +++++----- .../GenericComparison/Equals08.il.bsl | 45 +++++----- .../GenericComparison/Hash09.il.bsl | 80 +++++++++--------- .../GenericComparison/Hash10.il.bsl | 39 ++++----- .../GenericComparison/Hash11.il.bsl | 39 ++++----- 13 files changed, 351 insertions(+), 264 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index ca0ef1398c8..fd7c235cb58 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -1774,20 +1774,31 @@ namespace Microsoft.FSharp.Core | _ when er -> unknownEqualityComparer true fsEqualityComparerUnlimitedHashingER | _ -> unknownEqualityComparer false fsEqualityComparerUnlimitedHashingPER + [] type FSharpEqualityComparer_ER<'T> private () = static let comparer = getGenericEquality<'T> true - static member Comparer = comparer + static member EqualityComparer = comparer + [] type FSharpEqualityComparer_PER<'T> private () = static let comparer = getGenericEquality<'T> false - static member Comparer = comparer + static member EqualityComparer = comparer + + let inline FSharpEqualityComparer_ER_Equals (x:'T) (y:'T) = + FSharpEqualityComparer_ER<'T>.EqualityComparer.Equals (x, y) + + let inline FSharpEqualityComparer_PER_Equals (x:'T) (y:'T) = + FSharpEqualityComparer_PER<'T>.EqualityComparer.Equals (x, y) + + let inline FSharpEqualityComparer_GetHashCode (x:'T) = + FSharpEqualityComparer_PER<'T>.EqualityComparer.GetHashCode x /// Implements generic equality between two values, with PER semantics for NaN (so equality on two NaN values returns false) // // The compiler optimizer is aware of this function (see use of generic_equality_per_inner_vref in opt.fs) // and devirtualizes calls to it based on "T". let GenericEqualityIntrinsic (x : 'T) (y : 'T) : bool = - FSharpEqualityComparer_PER<'T>.Comparer.Equals (x, y) + FSharpEqualityComparer_PER<'T>.EqualityComparer.Equals (x, y) /// Implements generic equality between two values, with ER semantics for NaN (so equality on two NaN values returns true) // @@ -1796,7 +1807,7 @@ namespace Microsoft.FSharp.Core // The compiler optimizer is aware of this function (see use of generic_equality_er_inner_vref in opt.fs) // and devirtualizes calls to it based on "T". let GenericEqualityERIntrinsic (x : 'T) (y : 'T) : bool = - FSharpEqualityComparer_ER<'T>.Comparer.Equals (x, y) + FSharpEqualityComparer_ER<'T>.EqualityComparer.Equals (x, y) /// Implements generic equality between two values using "comp" for recursive calls. // @@ -1805,9 +1816,9 @@ namespace Microsoft.FSharp.Core // is either fsEqualityComparerUnlimitedHashingER or fsEqualityComparerUnlimitedHashingPER. let GenericEqualityWithComparerIntrinsic (comp : System.Collections.IEqualityComparer) (x : 'T) (y : 'T) : bool = if obj.ReferenceEquals (comp, fsEqualityComparerUnlimitedHashingPER) then - FSharpEqualityComparer_PER<'T>.Comparer.Equals (x, y) + FSharpEqualityComparer_PER<'T>.EqualityComparer.Equals (x, y) elif obj.ReferenceEquals (comp, fsEqualityComparerUnlimitedHashingER) then - FSharpEqualityComparer_ER<'T>.Comparer.Equals (x, y) + FSharpEqualityComparer_ER<'T>.EqualityComparer.Equals (x, y) else comp.Equals (box x, box y) @@ -1926,7 +1937,7 @@ namespace Microsoft.FSharp.Core // NOTE: The compiler optimizer is aware of this function (see uses of generic_hash_inner_vref in opt.fs) // and devirtualizes calls to it based on type "T". let GenericHashIntrinsic input = - FSharpEqualityComparer_PER<'T>.Comparer.GetHashCode input + FSharpEqualityComparer_PER<'T>.EqualityComparer.GetHashCode input /// Intrinsic for calls to depth-limited structural hashing that were not optimized by static conditionals. let LimitedGenericHashIntrinsic limit input = @@ -1941,7 +1952,7 @@ namespace Microsoft.FSharp.Core // and devirtualizes calls to it based on type "T". let GenericHashWithComparerIntrinsic<'T> (comp : System.Collections.IEqualityComparer) (input : 'T) : int = if obj.ReferenceEquals (comp, fsEqualityComparerUnlimitedHashingPER) then - FSharpEqualityComparer_PER<'T>.Comparer.GetHashCode input + FSharpEqualityComparer_PER<'T>.EqualityComparer.GetHashCode input else GenericHashParamObj comp (box input) @@ -2218,7 +2229,7 @@ namespace Microsoft.FSharp.Core member self.Equals(x,y) = GenericEquality x y } let FastGenericEqualityComparerFromTable<'T> = - HashCompare.FSharpEqualityComparer_PER<'T>.Comparer :> IEqualityComparer<'T> + HashCompare.FSharpEqualityComparer_PER<'T>.EqualityComparer :> IEqualityComparer<'T> // This is the implementation of HashIdentity.Structural. In most cases this just becomes // FastGenericEqualityComparerFromTable. diff --git a/src/fsharp/FSharp.Core/prim-types.fsi b/src/fsharp/FSharp.Core/prim-types.fsi index 54fdf39ba2c..52b2139725d 100644 --- a/src/fsharp/FSharp.Core/prim-types.fsi +++ b/src/fsharp/FSharp.Core/prim-types.fsi @@ -1238,6 +1238,26 @@ namespace Microsoft.FSharp.Core /// The F# compiler emits calls to some of the functions in this module as part of the compiled form of some language constructs module HashCompare = + [] + type FSharpEqualityComparer_ER<'T> = + static member EqualityComparer : System.Collections.Generic.EqualityComparer<'T> + + [] + type FSharpEqualityComparer_PER<'T> = + static member EqualityComparer : System.Collections.Generic.EqualityComparer<'T> + + /// A primitive entry point used by the F# compiler for optimization purposes. + [] + val inline FSharpEqualityComparer_ER_Equals : x:'T -> y:'T -> bool + + /// A primitive entry point used by the F# compiler for optimization purposes. + [] + val inline FSharpEqualityComparer_PER_Equals : x:'T -> y:'T -> bool + + /// A primitive entry point used by the F# compiler for optimization purposes. + [] + val inline FSharpEqualityComparer_GetHashCode : x:'T -> int + /// A primitive entry point used by the F# compiler for optimization purposes. [] val PhysicalHashIntrinsic : input:'T -> int when 'T : not struct diff --git a/src/fsharp/Optimizer.fs b/src/fsharp/Optimizer.fs index da19114bcc7..4921dcff817 100644 --- a/src/fsharp/Optimizer.fs +++ b/src/fsharp/Optimizer.fs @@ -2328,12 +2328,12 @@ and TryDevirtualizeApplication cenv env (f, tyargs, args, m) = // REVIEW: GenericEqualityIntrinsic (which has no comparer) implements PER semantics (5537: this should be ER semantics) // We are devirtualizing to a Equals(T) method which also implements PER semantics (5537: this should be ER semantics) | Expr.Val(v, _, _), [ty], _ when CanDevirtualizeApplication cenv v cenv.g.generic_equality_er_inner_vref ty args -> - + let tyargsOriginal = tyargs let tcref, tyargs = StripToNominalTyconRef cenv ty match tcref.GeneratedHashAndEqualsValues with | Some (_, vref) -> Some (DevirtualizeApplication cenv env vref ty tyargs args m) - | _ -> None - + | _ -> + Some (DevirtualizeApplication cenv env cenv.g.fsharpEqualityComparer_ER_Equals_vref ty tyargsOriginal args m) // Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericEqualityWithComparerFast | Expr.Val(v, _, _), [ty], _ when CanDevirtualizeApplication cenv v cenv.g.generic_equality_withc_inner_vref ty args -> @@ -2345,23 +2345,27 @@ and TryDevirtualizeApplication cenv env (f, tyargs, args, m) = Some (DevirtualizeApplication cenv env withcEqualsVal ty tyargs args2 m) | _ -> None - // Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericEqualityWithComparer + // Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericEqualityIntrinsic | Expr.Val(v, _, _), [ty], _ when CanDevirtualizeApplication cenv v cenv.g.generic_equality_per_inner_vref ty args && not(isRefTupleTy cenv.g ty) -> + let tyargsOriginal = tyargs let tcref, tyargs = StripToNominalTyconRef cenv ty match tcref.GeneratedHashAndEqualsWithComparerValues, args with | Some (_, _, withcEqualsVal), [x; y] -> let args2 = [x; mkRefTupledNoTypes cenv.g m [mkCoerceExpr(y, cenv.g.obj_ty, m, ty); (mkCallGetGenericPEREqualityComparer cenv.g m)]] Some (DevirtualizeApplication cenv env withcEqualsVal ty tyargs args2 m) - | _ -> None + | _ -> + Some (DevirtualizeApplication cenv env cenv.g.fsharpEqualityComparer_PER_Equals_vref ty tyargsOriginal args m) // Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericHashIntrinsic | Expr.Val(v, _, _), [ty], _ when CanDevirtualizeApplication cenv v cenv.g.generic_hash_inner_vref ty args -> + let tyargsOriginal = tyargs let tcref, tyargs = StripToNominalTyconRef cenv ty match tcref.GeneratedHashAndEqualsWithComparerValues, args with | Some (_, withcGetHashCodeVal, _), [x] -> let args2 = [x; mkCallGetGenericEREqualityComparer cenv.g m] Some (DevirtualizeApplication cenv env withcGetHashCodeVal ty tyargs args2 m) - | _ -> None + | _ -> + Some (DevirtualizeApplication cenv env cenv.g.fsharpEqualityComparer_GetHashCode_vref ty tyargsOriginal args m) // Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericHashWithComparerIntrinsic | Expr.Val(v, _, _), [ty], _ when CanDevirtualizeApplication cenv v cenv.g.generic_hash_withc_inner_vref ty args -> @@ -2416,6 +2420,15 @@ and TryDevirtualizeApplication cenv env (f, tyargs, args, m) = match vref with | Some vref -> Some (DevirtualizeApplication cenv env vref ty tyargs (mkCallGetGenericPEREqualityComparer cenv.g m :: args) m) | None -> None + + | Expr.Val(v, _, _), [(TType_var t) as ty], _ when (not cenv.g.compilingFslib) && valRefEq cenv.g v cenv.g.generic_equality_per_inner_vref && t.Rigidity = TyparRigidity.Rigid -> + Some (DevirtualizeApplication cenv env cenv.g.fsharpEqualityComparer_PER_Equals_vref ty tyargs args m) + + | Expr.Val(v, _, _), [(TType_var t) as ty], _ when (not cenv.g.compilingFslib) && valRefEq cenv.g v cenv.g.generic_equality_er_inner_vref && t.Rigidity = TyparRigidity.Rigid -> + Some (DevirtualizeApplication cenv env cenv.g.fsharpEqualityComparer_ER_Equals_vref ty tyargs args m) + + | Expr.Val(v, _, _), [(TType_var t) as ty], _ when (not cenv.g.compilingFslib) && valRefEq cenv.g v cenv.g.generic_hash_inner_vref && t.Rigidity = TyparRigidity.Rigid -> + Some (DevirtualizeApplication cenv env cenv.g.fsharpEqualityComparer_GetHashCode_vref ty tyargs args m) // Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericComparisonWithComparerIntrinsic for tuple types | Expr.Val(v, _, _), [ty], _ when valRefEq cenv.g v cenv.g.generic_comparison_withc_inner_vref && isRefTupleTy cenv.g ty -> diff --git a/src/fsharp/TcGlobals.fs b/src/fsharp/TcGlobals.fs index d6fb7cd3c73..70ff2912bfb 100755 --- a/src/fsharp/TcGlobals.fs +++ b/src/fsharp/TcGlobals.fs @@ -583,6 +583,10 @@ type public TcGlobals(compilingFslib: bool, ilg:ILGlobals, fslibCcu: CcuThunk, d let v_generic_comparison_inner_info = makeIntrinsicValRef(fslib_MFHashCompare_nleref, "GenericComparisonIntrinsic" , None , None , [vara], mk_compare_sig varaTy) let v_generic_comparison_withc_inner_info = makeIntrinsicValRef(fslib_MFHashCompare_nleref, "GenericComparisonWithComparerIntrinsic", None , None , [vara], mk_compare_withc_sig varaTy) + let v_FSharpEqualityComparer_PER_Equals_info = makeIntrinsicValRef(fslib_MFHashCompare_nleref, "FSharpEqualityComparer_PER_Equals" , None , None , [vara], mk_rel_sig varaTy) + let v_FSharpEqualityComparer_GetHashCode_info = makeIntrinsicValRef(fslib_MFHashCompare_nleref, "FSharpEqualityComparer_GetHashCode", None , None , [vara], mk_hash_sig varaTy) + let v_FSharpEqualityComparer_ER_Equals_info = makeIntrinsicValRef(fslib_MFHashCompare_nleref, "FSharpEqualityComparer_ER_Equals" , None , None , [vara], mk_rel_sig varaTy) + let v_generic_hash_inner_info = makeIntrinsicValRef(fslib_MFHashCompare_nleref, "GenericHashIntrinsic" , None , None , [vara], mk_hash_sig varaTy) let v_generic_hash_withc_inner_info = makeIntrinsicValRef(fslib_MFHashCompare_nleref, "GenericHashWithComparerIntrinsic" , None , None , [vara], mk_hash_withc_sig varaTy) @@ -1220,6 +1224,9 @@ type public TcGlobals(compilingFslib: bool, ilg:ILGlobals, fslibCcu: CcuThunk, d member __.generic_hash_withc_outer_info = v_generic_hash_withc_outer_info member val generic_hash_inner_vref = ValRefForIntrinsic v_generic_hash_inner_info member val generic_hash_withc_inner_vref = ValRefForIntrinsic v_generic_hash_withc_inner_info + member val fsharpEqualityComparer_ER_Equals_vref = ValRefForIntrinsic v_FSharpEqualityComparer_ER_Equals_info + member val fsharpEqualityComparer_PER_Equals_vref = ValRefForIntrinsic v_FSharpEqualityComparer_PER_Equals_info + member val fsharpEqualityComparer_GetHashCode_vref = ValRefForIntrinsic v_FSharpEqualityComparer_GetHashCode_info member val reference_equality_inner_vref = ValRefForIntrinsic v_reference_equality_inner_info diff --git a/tests/fsharpqa/Source/CodeGen/EmittedIL/QueryExpressionStepping/Linq101Joins01.il.bsl b/tests/fsharpqa/Source/CodeGen/EmittedIL/QueryExpressionStepping/Linq101Joins01.il.bsl index 22342da9b92..603c997764a 100644 --- a/tests/fsharpqa/Source/CodeGen/EmittedIL/QueryExpressionStepping/Linq101Joins01.il.bsl +++ b/tests/fsharpqa/Source/CodeGen/EmittedIL/QueryExpressionStepping/Linq101Joins01.il.bsl @@ -13,7 +13,7 @@ .assembly extern FSharp.Core { .publickeytoken = (B0 3F 5F 7F 11 D5 0A 3A ) // .?_....: - .ver 4:4:1:0 + .ver 4:4:3:0 } .assembly extern Utils { @@ -38,20 +38,20 @@ } .mresource public FSharpSignatureData.Linq101Joins01 { - // Offset: 0x00000000 Length: 0x000002F4 + // Offset: 0x00000000 Length: 0x00000326 } .mresource public FSharpOptimizationData.Linq101Joins01 { - // Offset: 0x000002F8 Length: 0x000000C3 + // Offset: 0x00000330 Length: 0x000000C3 } .module Linq101Joins01.exe -// MVID: {5A1F62A6-151B-685E-A745-0383A6621F5A} +// MVID: {5B2D78B8-151B-685E-A745-0383B8782D5B} .imagebase 0x00400000 .file alignment 0x00000200 .stackreserve 0x00100000 .subsystem 0x0003 // WINDOWS_CUI .corflags 0x00000001 // ILONLY -// Image base: 0x03830000 +// Image base: 0x027D0000 // =============== CLASS MEMBERS DECLARATION =================== @@ -81,7 +81,7 @@ // Code size 2 (0x2) .maxstack 8 .language '{AB4F38C9-B6E6-43BA-BE3B-58080B2CCCE3}', '{994B45C4-E6E9-11D2-903F-00C04FA302A1}', '{5A869D0B-6611-11D3-BD2A-0000F80849BD}' - .line 14,14 : 32,33 'C:\\visualfsharp\\tests\\fsharpqa\\Source\\CodeGen\\EmittedIL\\QueryExpressionStepping\\Linq101Joins01.fs' + .line 14,14 : 32,33 'C:\\src\\manofstick\\visualfsharp-nobox\\tests\\fsharpqa\\Source\\CodeGen\\EmittedIL\\QueryExpressionStepping\\Linq101Joins01.fs' IL_0000: ldarg.1 IL_0001: ret } // end of method q@14::Invoke @@ -790,54 +790,67 @@ .method public strict virtual instance class [FSharp.Core]Microsoft.FSharp.Linq.QuerySource`2,class [Utils]Utils/Product,string>,object> Invoke(class [Utils]Utils/Product _arg2) cil managed { - // Code size 69 (0x45) + // Code size 86 (0x56) .maxstack 9 .locals init ([0] class [Utils]Utils/Product p, - [1] string t) + [1] string t, + [2] object V_2, + [3] object V_3, + [4] object V_4, + [5] object V_5) .line 40,40 : 9,40 '' IL_0000: ldarg.1 IL_0001: stloc.0 .line 41,41 : 17,39 '' IL_0002: ldloc.0 IL_0003: box [Utils]Utils/Product - IL_0008: ldnull - IL_0009: call bool [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/HashCompare::GenericEqualityIntrinsic(!!0, - !!0) - IL_000e: brfalse.s IL_0012 - - IL_0010: br.s IL_0014 - - IL_0012: br.s IL_001c + IL_0008: stloc.2 + IL_0009: ldnull + IL_000a: stloc.3 + IL_000b: ldloc.2 + IL_000c: stloc.s V_4 + IL_000e: ldloc.3 + IL_000f: stloc.s V_5 + IL_0011: call class [mscorlib]System.Collections.Generic.EqualityComparer`1 class [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/HashCompare/FSharpEqualityComparer_PER`1::get_EqualityComparer() + IL_0016: ldloc.s V_4 + IL_0018: ldloc.s V_5 + IL_001a: callvirt instance bool class [mscorlib]System.Collections.Generic.EqualityComparer`1::Equals(!0, + !0) + IL_001f: brfalse.s IL_0023 + + IL_0021: br.s IL_0025 + + IL_0023: br.s IL_002d .line 41,41 : 40,55 '' - IL_0014: ldstr "(No products)" + IL_0025: ldstr "(No products)" .line 100001,100001 : 0,0 '' - IL_0019: nop - IL_001a: br.s IL_0023 + IL_002a: nop + IL_002b: br.s IL_0034 .line 41,41 : 61,74 '' - IL_001c: ldloc.0 - IL_001d: callvirt instance string [Utils]Utils/Product::get_ProductName() + IL_002d: ldloc.0 + IL_002e: callvirt instance string [Utils]Utils/Product::get_ProductName() .line 100001,100001 : 0,0 '' - IL_0022: nop + IL_0033: nop .line 100001,100001 : 0,0 '' - IL_0023: stloc.1 + IL_0034: stloc.1 .line 42,42 : 9,22 '' - IL_0024: ldarg.0 - IL_0025: ldfld class [FSharp.Core]Microsoft.FSharp.Linq.QueryBuilder Linq101Joins01/'q4@40-4'::builder@ - IL_002a: ldarg.0 - IL_002b: ldfld string Linq101Joins01/'q4@40-4'::c - IL_0030: ldarg.0 - IL_0031: ldfld class [mscorlib]System.Collections.Generic.IEnumerable`1 Linq101Joins01/'q4@40-4'::ps - IL_0036: ldloc.0 - IL_0037: ldloc.1 - IL_0038: newobj instance void class [mscorlib]System.Tuple`4,class [Utils]Utils/Product,string>::.ctor(!0, + IL_0035: ldarg.0 + IL_0036: ldfld class [FSharp.Core]Microsoft.FSharp.Linq.QueryBuilder Linq101Joins01/'q4@40-4'::builder@ + IL_003b: ldarg.0 + IL_003c: ldfld string Linq101Joins01/'q4@40-4'::c + IL_0041: ldarg.0 + IL_0042: ldfld class [mscorlib]System.Collections.Generic.IEnumerable`1 Linq101Joins01/'q4@40-4'::ps + IL_0047: ldloc.0 + IL_0048: ldloc.1 + IL_0049: newobj instance void class [mscorlib]System.Tuple`4,class [Utils]Utils/Product,string>::.ctor(!0, !1, !2, !3) - IL_003d: tail. - IL_003f: callvirt instance class [FSharp.Core]Microsoft.FSharp.Linq.QuerySource`2 [FSharp.Core]Microsoft.FSharp.Linq.QueryBuilder::Yield,class [Utils]Utils/Product,string>,object>(!!0) - IL_0044: ret + IL_004e: tail. + IL_0050: callvirt instance class [FSharp.Core]Microsoft.FSharp.Linq.QuerySource`2 [FSharp.Core]Microsoft.FSharp.Linq.QueryBuilder::Yield,class [Utils]Utils/Product,string>,object>(!!0) + IL_0055: ret } // end of method 'q4@40-4'::Invoke } // end of class 'q4@40-4' diff --git a/tests/fsharpqa/Source/CodeGen/EmittedIL/StaticInit/StaticInit_Struct01.il.bsl b/tests/fsharpqa/Source/CodeGen/EmittedIL/StaticInit/StaticInit_Struct01.il.bsl index 55664ad8b3a..17ce5430574 100644 --- a/tests/fsharpqa/Source/CodeGen/EmittedIL/StaticInit/StaticInit_Struct01.il.bsl +++ b/tests/fsharpqa/Source/CodeGen/EmittedIL/StaticInit/StaticInit_Struct01.il.bsl @@ -13,7 +13,7 @@ .assembly extern FSharp.Core { .publickeytoken = (B0 3F 5F 7F 11 D5 0A 3A ) // .?_....: - .ver 4:4:1:0 + .ver 4:4:3:0 } .assembly StaticInit_Struct01 { @@ -29,20 +29,20 @@ } .mresource public FSharpSignatureData.StaticInit_Struct01 { - // Offset: 0x00000000 Length: 0x000007B1 + // Offset: 0x00000000 Length: 0x000007B5 } .mresource public FSharpOptimizationData.StaticInit_Struct01 { - // Offset: 0x000007B8 Length: 0x0000021F + // Offset: 0x000007C0 Length: 0x0000021F } .module StaticInit_Struct01.dll -// MVID: {59B19250-05F6-D6CB-A745-03835092B159} +// MVID: {5B2D78C5-05F6-D6CB-A745-0383C5782D5B} .imagebase 0x00400000 .file alignment 0x00000200 .stackreserve 0x00100000 .subsystem 0x0003 // WINDOWS_CUI .corflags 0x00000001 // ILONLY -// Image base: 0x02BA0000 +// Image base: 0x02C80000 // =============== CLASS MEMBERS DECLARATION =================== @@ -71,7 +71,7 @@ .maxstack 5 .locals init ([0] valuetype StaticInit_Struct01/C& V_0) .language '{AB4F38C9-B6E6-43BA-BE3B-58080B2CCCE3}', '{994B45C4-E6E9-11D2-903F-00C04FA302A1}', '{5A869D0B-6611-11D3-BD2A-0000F80849BD}' - .line 4,4 : 6,7 'C:\\GitHub\\dsyme\\visualfsharp\\tests\\fsharpqa\\Source\\CodeGen\\EmittedIL\\StaticInit\\StaticInit_Struct01.fs' + .line 4,4 : 6,7 'C:\\src\\manofstick\\visualfsharp-nobox\\tests\\fsharpqa\\Source\\CodeGen\\EmittedIL\\StaticInit\\StaticInit_Struct01.fs' IL_0000: ldarga.s obj IL_0002: stloc.0 IL_0003: call class [mscorlib]System.Collections.IComparer [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives::get_GenericComparer() @@ -256,20 +256,33 @@ instance bool Equals(valuetype StaticInit_Struct01/C obj) cil managed { .custom instance void [mscorlib]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) - // Code size 23 (0x17) - .maxstack 4 - .locals init ([0] valuetype StaticInit_Struct01/C& V_0) + // Code size 38 (0x26) + .maxstack 5 + .locals init ([0] valuetype StaticInit_Struct01/C& V_0, + [1] valuetype [mscorlib]System.DateTime V_1, + [2] valuetype [mscorlib]System.DateTime V_2, + [3] valuetype [mscorlib]System.DateTime V_3, + [4] valuetype [mscorlib]System.DateTime V_4) .line 4,4 : 6,7 '' IL_0000: ldarga.s obj IL_0002: stloc.0 IL_0003: ldarg.0 IL_0004: ldfld valuetype [mscorlib]System.DateTime StaticInit_Struct01/C::s - IL_0009: ldloc.0 - IL_000a: ldfld valuetype [mscorlib]System.DateTime StaticInit_Struct01/C::s - IL_000f: tail. - IL_0011: call bool [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/HashCompare::GenericEqualityERIntrinsic(!!0, - !!0) - IL_0016: ret + IL_0009: stloc.1 + IL_000a: ldloc.0 + IL_000b: ldfld valuetype [mscorlib]System.DateTime StaticInit_Struct01/C::s + IL_0010: stloc.2 + IL_0011: ldloc.1 + IL_0012: stloc.3 + IL_0013: ldloc.2 + IL_0014: stloc.s V_4 + IL_0016: call class [mscorlib]System.Collections.Generic.EqualityComparer`1 class [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/HashCompare/FSharpEqualityComparer_ER`1::get_EqualityComparer() + IL_001b: ldloc.3 + IL_001c: ldloc.s V_4 + IL_001e: tail. + IL_0020: callvirt instance bool class [mscorlib]System.Collections.Generic.EqualityComparer`1::Equals(!0, + !0) + IL_0025: ret } // end of method C::Equals .method public hidebysig virtual final diff --git a/tests/fsharpqa/Source/Optimizations/GenericComparison/Compare07.il.bsl b/tests/fsharpqa/Source/Optimizations/GenericComparison/Compare07.il.bsl index 70335b05d20..cb04fa9fb46 100644 --- a/tests/fsharpqa/Source/Optimizations/GenericComparison/Compare07.il.bsl +++ b/tests/fsharpqa/Source/Optimizations/GenericComparison/Compare07.il.bsl @@ -13,7 +13,7 @@ .assembly extern FSharp.Core { .publickeytoken = (B0 3F 5F 7F 11 D5 0A 3A ) // .?_....: - .ver 4:4:1:0 + .ver 4:4:3:0 } .assembly Compare07 { @@ -29,20 +29,20 @@ } .mresource public FSharpSignatureData.Compare07 { - // Offset: 0x00000000 Length: 0x0000089A + // Offset: 0x00000000 Length: 0x0000089E } .mresource public FSharpOptimizationData.Compare07 { - // Offset: 0x000008A0 Length: 0x00000692 + // Offset: 0x000008A8 Length: 0x0000069A } .module Compare07.dll -// MVID: {59B18AEE-05DE-F88E-A745-0383EE8AB159} +// MVID: {5B2D7B11-05DE-F88E-A745-0383117B2D5B} .imagebase 0x00400000 .file alignment 0x00000200 .stackreserve 0x00100000 .subsystem 0x0003 // WINDOWS_CUI .corflags 0x00000001 // ILONLY -// Image base: 0x02BA0000 +// Image base: 0x02640000 // =============== CLASS MEMBERS DECLARATION =================== @@ -187,7 +187,7 @@ [4] !a V_4, [5] !a V_5) .language '{AB4F38C9-B6E6-43BA-BE3B-58080B2CCCE3}', '{994B45C4-E6E9-11D2-903F-00C04FA302A1}', '{5A869D0B-6611-11D3-BD2A-0000F80849BD}' - .line 16707566,16707566 : 0,0 'C:\\GitHub\\dsyme\\visualfsharp\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Compare07.fsx' + .line 16707566,16707566 : 0,0 'C:\\src\\manofstick\\visualfsharp-nobox\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Compare07.fsx' IL_0000: ldarg.0 IL_0001: ldnull IL_0002: cgt.un @@ -560,8 +560,8 @@ instance bool Equals(class Compare07/CompareMicroPerfAndCodeGenerationTests/GenericKey`1 obj) cil managed { .custom instance void [mscorlib]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) - // Code size 77 (0x4d) - .maxstack 4 + // Code size 87 (0x57) + .maxstack 5 .locals init ([0] class Compare07/CompareMicroPerfAndCodeGenerationTests/GenericKey`1 V_0, [1] class Compare07/CompareMicroPerfAndCodeGenerationTests/GenericKey`1 V_1, [2] !a V_2, @@ -570,13 +570,13 @@ IL_0000: ldarg.0 IL_0001: ldnull IL_0002: cgt.un - IL_0004: brfalse.s IL_0045 + IL_0004: brfalse.s IL_004f .line 16707566,16707566 : 0,0 '' IL_0006: ldarg.1 IL_0007: ldnull IL_0008: cgt.un - IL_000a: brfalse.s IL_0043 + IL_000a: brfalse.s IL_004d .line 16707566,16707566 : 0,0 '' IL_000c: ldarg.0 @@ -592,41 +592,43 @@ IL_0019: ldloc.1 IL_001a: ldfld !0 class Compare07/CompareMicroPerfAndCodeGenerationTests/GenericKey`1::item1 IL_001f: stloc.3 - IL_0020: ldloc.2 - IL_0021: ldloc.3 - IL_0022: call bool [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/HashCompare::GenericEqualityERIntrinsic(!!0, - !!0) - IL_0027: brfalse.s IL_0041 - - .line 16707566,16707566 : 0,0 '' - IL_0029: ldloc.0 - IL_002a: ldfld !0 class Compare07/CompareMicroPerfAndCodeGenerationTests/GenericKey`1::item2 - IL_002f: stloc.2 - IL_0030: ldloc.1 - IL_0031: ldfld !0 class Compare07/CompareMicroPerfAndCodeGenerationTests/GenericKey`1::item2 - IL_0036: stloc.3 - IL_0037: ldloc.2 - IL_0038: ldloc.3 - IL_0039: tail. - IL_003b: call bool [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/HashCompare::GenericEqualityERIntrinsic(!!0, - !!0) - IL_0040: ret + IL_0020: call class [mscorlib]System.Collections.Generic.EqualityComparer`1 class [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/HashCompare/FSharpEqualityComparer_ER`1::get_EqualityComparer() + IL_0025: ldloc.2 + IL_0026: ldloc.3 + IL_0027: callvirt instance bool class [mscorlib]System.Collections.Generic.EqualityComparer`1::Equals(!0, + !0) + IL_002c: brfalse.s IL_004b + + .line 16707566,16707566 : 0,0 '' + IL_002e: ldloc.0 + IL_002f: ldfld !0 class Compare07/CompareMicroPerfAndCodeGenerationTests/GenericKey`1::item2 + IL_0034: stloc.2 + IL_0035: ldloc.1 + IL_0036: ldfld !0 class Compare07/CompareMicroPerfAndCodeGenerationTests/GenericKey`1::item2 + IL_003b: stloc.3 + IL_003c: call class [mscorlib]System.Collections.Generic.EqualityComparer`1 class [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/HashCompare/FSharpEqualityComparer_ER`1::get_EqualityComparer() + IL_0041: ldloc.2 + IL_0042: ldloc.3 + IL_0043: tail. + IL_0045: callvirt instance bool class [mscorlib]System.Collections.Generic.EqualityComparer`1::Equals(!0, + !0) + IL_004a: ret .line 16707566,16707566 : 0,0 '' - IL_0041: ldc.i4.0 - IL_0042: ret + IL_004b: ldc.i4.0 + IL_004c: ret .line 16707566,16707566 : 0,0 '' - IL_0043: ldc.i4.0 - IL_0044: ret + IL_004d: ldc.i4.0 + IL_004e: ret .line 16707566,16707566 : 0,0 '' - IL_0045: ldarg.1 - IL_0046: ldnull - IL_0047: cgt.un - IL_0049: ldc.i4.0 - IL_004a: ceq - IL_004c: ret + IL_004f: ldarg.1 + IL_0050: ldnull + IL_0051: cgt.un + IL_0053: ldc.i4.0 + IL_0054: ceq + IL_0056: ret } // end of method GenericKey`1::Equals .method public hidebysig virtual final diff --git a/tests/fsharpqa/Source/Optimizations/GenericComparison/Equals06.il.bsl b/tests/fsharpqa/Source/Optimizations/GenericComparison/Equals06.il.bsl index 91247bff24d..e575063fd39 100644 --- a/tests/fsharpqa/Source/Optimizations/GenericComparison/Equals06.il.bsl +++ b/tests/fsharpqa/Source/Optimizations/GenericComparison/Equals06.il.bsl @@ -13,7 +13,7 @@ .assembly extern FSharp.Core { .publickeytoken = (B0 3F 5F 7F 11 D5 0A 3A ) // .?_....: - .ver 4:4:1:0 + .ver 4:4:3:0 } .assembly Equals06 { @@ -29,20 +29,20 @@ } .mresource public FSharpSignatureData.Equals06 { - // Offset: 0x00000000 Length: 0x00000896 + // Offset: 0x00000000 Length: 0x0000089A } .mresource public FSharpOptimizationData.Equals06 { - // Offset: 0x000008A0 Length: 0x0000068E + // Offset: 0x000008A0 Length: 0x00000696 } .module Equals06.dll -// MVID: {59B18AEE-0759-31EC-A745-0383EE8AB159} +// MVID: {5B2D7B11-0759-31EC-A745-0383117B2D5B} .imagebase 0x00400000 .file alignment 0x00000200 .stackreserve 0x00100000 .subsystem 0x0003 // WINDOWS_CUI .corflags 0x00000001 // ILONLY -// Image base: 0x01B90000 +// Image base: 0x02980000 // =============== CLASS MEMBERS DECLARATION =================== @@ -187,7 +187,7 @@ [4] !a V_4, [5] !a V_5) .language '{AB4F38C9-B6E6-43BA-BE3B-58080B2CCCE3}', '{994B45C4-E6E9-11D2-903F-00C04FA302A1}', '{5A869D0B-6611-11D3-BD2A-0000F80849BD}' - .line 16707566,16707566 : 0,0 'C:\\GitHub\\dsyme\\visualfsharp\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Equals06.fsx' + .line 16707566,16707566 : 0,0 'C:\\src\\manofstick\\visualfsharp-nobox\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Equals06.fsx' IL_0000: ldarg.0 IL_0001: ldnull IL_0002: cgt.un @@ -560,8 +560,8 @@ instance bool Equals(class Equals06/EqualsMicroPerfAndCodeGenerationTests/GenericKey`1 obj) cil managed { .custom instance void [mscorlib]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) - // Code size 77 (0x4d) - .maxstack 4 + // Code size 87 (0x57) + .maxstack 5 .locals init ([0] class Equals06/EqualsMicroPerfAndCodeGenerationTests/GenericKey`1 V_0, [1] class Equals06/EqualsMicroPerfAndCodeGenerationTests/GenericKey`1 V_1, [2] !a V_2, @@ -570,13 +570,13 @@ IL_0000: ldarg.0 IL_0001: ldnull IL_0002: cgt.un - IL_0004: brfalse.s IL_0045 + IL_0004: brfalse.s IL_004f .line 16707566,16707566 : 0,0 '' IL_0006: ldarg.1 IL_0007: ldnull IL_0008: cgt.un - IL_000a: brfalse.s IL_0043 + IL_000a: brfalse.s IL_004d .line 16707566,16707566 : 0,0 '' IL_000c: ldarg.0 @@ -592,41 +592,43 @@ IL_0019: ldloc.1 IL_001a: ldfld !0 class Equals06/EqualsMicroPerfAndCodeGenerationTests/GenericKey`1::item1 IL_001f: stloc.3 - IL_0020: ldloc.2 - IL_0021: ldloc.3 - IL_0022: call bool [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/HashCompare::GenericEqualityERIntrinsic(!!0, - !!0) - IL_0027: brfalse.s IL_0041 - - .line 16707566,16707566 : 0,0 '' - IL_0029: ldloc.0 - IL_002a: ldfld !0 class Equals06/EqualsMicroPerfAndCodeGenerationTests/GenericKey`1::item2 - IL_002f: stloc.2 - IL_0030: ldloc.1 - IL_0031: ldfld !0 class Equals06/EqualsMicroPerfAndCodeGenerationTests/GenericKey`1::item2 - IL_0036: stloc.3 - IL_0037: ldloc.2 - IL_0038: ldloc.3 - IL_0039: tail. - IL_003b: call bool [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/HashCompare::GenericEqualityERIntrinsic(!!0, - !!0) - IL_0040: ret + IL_0020: call class [mscorlib]System.Collections.Generic.EqualityComparer`1 class [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/HashCompare/FSharpEqualityComparer_ER`1::get_EqualityComparer() + IL_0025: ldloc.2 + IL_0026: ldloc.3 + IL_0027: callvirt instance bool class [mscorlib]System.Collections.Generic.EqualityComparer`1::Equals(!0, + !0) + IL_002c: brfalse.s IL_004b + + .line 16707566,16707566 : 0,0 '' + IL_002e: ldloc.0 + IL_002f: ldfld !0 class Equals06/EqualsMicroPerfAndCodeGenerationTests/GenericKey`1::item2 + IL_0034: stloc.2 + IL_0035: ldloc.1 + IL_0036: ldfld !0 class Equals06/EqualsMicroPerfAndCodeGenerationTests/GenericKey`1::item2 + IL_003b: stloc.3 + IL_003c: call class [mscorlib]System.Collections.Generic.EqualityComparer`1 class [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/HashCompare/FSharpEqualityComparer_ER`1::get_EqualityComparer() + IL_0041: ldloc.2 + IL_0042: ldloc.3 + IL_0043: tail. + IL_0045: callvirt instance bool class [mscorlib]System.Collections.Generic.EqualityComparer`1::Equals(!0, + !0) + IL_004a: ret .line 16707566,16707566 : 0,0 '' - IL_0041: ldc.i4.0 - IL_0042: ret + IL_004b: ldc.i4.0 + IL_004c: ret .line 16707566,16707566 : 0,0 '' - IL_0043: ldc.i4.0 - IL_0044: ret + IL_004d: ldc.i4.0 + IL_004e: ret .line 16707566,16707566 : 0,0 '' - IL_0045: ldarg.1 - IL_0046: ldnull - IL_0047: cgt.un - IL_0049: ldc.i4.0 - IL_004a: ceq - IL_004c: ret + IL_004f: ldarg.1 + IL_0050: ldnull + IL_0051: cgt.un + IL_0053: ldc.i4.0 + IL_0054: ceq + IL_0056: ret } // end of method GenericKey`1::Equals .method public hidebysig virtual final diff --git a/tests/fsharpqa/Source/Optimizations/GenericComparison/Equals07.il.bsl b/tests/fsharpqa/Source/Optimizations/GenericComparison/Equals07.il.bsl index 91f97c289a2..1ce42f2b348 100644 --- a/tests/fsharpqa/Source/Optimizations/GenericComparison/Equals07.il.bsl +++ b/tests/fsharpqa/Source/Optimizations/GenericComparison/Equals07.il.bsl @@ -13,7 +13,7 @@ .assembly extern FSharp.Core { .publickeytoken = (B0 3F 5F 7F 11 D5 0A 3A ) // .?_....: - .ver 4:4:1:0 + .ver 4:4:3:0 } .assembly Equals07 { @@ -29,20 +29,20 @@ } .mresource public FSharpSignatureData.Equals07 { - // Offset: 0x00000000 Length: 0x0000022D + // Offset: 0x00000000 Length: 0x00000245 } .mresource public FSharpOptimizationData.Equals07 { - // Offset: 0x00000238 Length: 0x000000AF + // Offset: 0x00000250 Length: 0x000000AF } .module Equals07.dll -// MVID: {59B18AEE-0759-AE27-A745-0383EE8AB159} +// MVID: {5B2D7B11-0759-AE27-A745-0383117B2D5B} .imagebase 0x00400000 .file alignment 0x00000200 .stackreserve 0x00100000 .subsystem 0x0003 // WINDOWS_CUI .corflags 0x00000001 // ILONLY -// Image base: 0x01C80000 +// Image base: 0x02D80000 // =============== CLASS MEMBERS DECLARATION =================== @@ -57,14 +57,14 @@ .custom instance void [FSharp.Core]Microsoft.FSharp.Core.CompilationMappingAttribute::.ctor(valuetype [FSharp.Core]Microsoft.FSharp.Core.SourceConstructFlags) = ( 01 00 07 00 00 00 00 00 ) .method public static bool f7() cil managed { - // Code size 68 (0x44) + // Code size 73 (0x49) .maxstack 5 .locals init ([0] bool x, [1] uint8[] t1, [2] uint8[] t2, [3] int32 i) .language '{AB4F38C9-B6E6-43BA-BE3B-58080B2CCCE3}', '{994B45C4-E6E9-11D2-903F-00C04FA302A1}', '{5A869D0B-6611-11D3-BD2A-0000F80849BD}' - .line 5,5 : 8,29 'C:\\GitHub\\dsyme\\visualfsharp\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Equals07.fsx' + .line 5,5 : 8,29 'C:\\src\\manofstick\\visualfsharp-nobox\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Equals07.fsx' IL_0000: ldc.i4.0 IL_0001: stloc.0 .line 6,6 : 8,35 '' @@ -90,26 +90,27 @@ .line 8,8 : 8,32 '' IL_002a: ldc.i4.0 IL_002b: stloc.3 - IL_002c: br.s IL_003a + IL_002c: br.s IL_003f .line 9,9 : 12,26 '' - IL_002e: ldloc.1 - IL_002f: ldloc.2 - IL_0030: call bool [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/HashCompare::GenericEqualityIntrinsic(!!0, - !!0) - IL_0035: stloc.0 - IL_0036: ldloc.3 - IL_0037: ldc.i4.1 - IL_0038: add - IL_0039: stloc.3 + IL_002e: call class [mscorlib]System.Collections.Generic.EqualityComparer`1 class [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/HashCompare/FSharpEqualityComparer_PER`1::get_EqualityComparer() + IL_0033: ldloc.1 + IL_0034: ldloc.2 + IL_0035: callvirt instance bool class [mscorlib]System.Collections.Generic.EqualityComparer`1::Equals(!0, + !0) + IL_003a: stloc.0 + IL_003b: ldloc.3 + IL_003c: ldc.i4.1 + IL_003d: add + IL_003e: stloc.3 .line 8,8 : 8,32 '' - IL_003a: ldloc.3 - IL_003b: ldc.i4 0x989681 - IL_0040: blt.s IL_002e + IL_003f: ldloc.3 + IL_0040: ldc.i4 0x989681 + IL_0045: blt.s IL_002e .line 10,10 : 8,9 '' - IL_0042: ldloc.0 - IL_0043: ret + IL_0047: ldloc.0 + IL_0048: ret } // end of method EqualsMicroPerfAndCodeGenerationTests::f7 } // end of class EqualsMicroPerfAndCodeGenerationTests diff --git a/tests/fsharpqa/Source/Optimizations/GenericComparison/Equals08.il.bsl b/tests/fsharpqa/Source/Optimizations/GenericComparison/Equals08.il.bsl index 55da6ee102e..39e19138617 100644 --- a/tests/fsharpqa/Source/Optimizations/GenericComparison/Equals08.il.bsl +++ b/tests/fsharpqa/Source/Optimizations/GenericComparison/Equals08.il.bsl @@ -13,7 +13,7 @@ .assembly extern FSharp.Core { .publickeytoken = (B0 3F 5F 7F 11 D5 0A 3A ) // .?_....: - .ver 4:4:1:0 + .ver 4:4:3:0 } .assembly Equals08 { @@ -29,20 +29,20 @@ } .mresource public FSharpSignatureData.Equals08 { - // Offset: 0x00000000 Length: 0x0000022D + // Offset: 0x00000000 Length: 0x00000245 } .mresource public FSharpOptimizationData.Equals08 { - // Offset: 0x00000238 Length: 0x000000AF + // Offset: 0x00000250 Length: 0x000000AF } .module Equals08.dll -// MVID: {59B18AEE-0759-659E-A745-0383EE8AB159} +// MVID: {5B2D7B11-0759-659E-A745-0383117B2D5B} .imagebase 0x00400000 .file alignment 0x00000200 .stackreserve 0x00100000 .subsystem 0x0003 // WINDOWS_CUI .corflags 0x00000001 // ILONLY -// Image base: 0x01090000 +// Image base: 0x02FD0000 // =============== CLASS MEMBERS DECLARATION =================== @@ -57,14 +57,14 @@ .custom instance void [FSharp.Core]Microsoft.FSharp.Core.CompilationMappingAttribute::.ctor(valuetype [FSharp.Core]Microsoft.FSharp.Core.SourceConstructFlags) = ( 01 00 07 00 00 00 00 00 ) .method public static bool f8() cil managed { - // Code size 68 (0x44) + // Code size 73 (0x49) .maxstack 5 .locals init ([0] bool x, [1] int32[] t1, [2] int32[] t2, [3] int32 i) .language '{AB4F38C9-B6E6-43BA-BE3B-58080B2CCCE3}', '{994B45C4-E6E9-11D2-903F-00C04FA302A1}', '{5A869D0B-6611-11D3-BD2A-0000F80849BD}' - .line 5,5 : 8,29 'C:\\GitHub\\dsyme\\visualfsharp\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Equals08.fsx' + .line 5,5 : 8,29 'C:\\src\\manofstick\\visualfsharp-nobox\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Equals08.fsx' IL_0000: ldc.i4.0 IL_0001: stloc.0 .line 6,6 : 8,31 '' @@ -90,26 +90,27 @@ .line 8,8 : 8,32 '' IL_002a: ldc.i4.0 IL_002b: stloc.3 - IL_002c: br.s IL_003a + IL_002c: br.s IL_003f .line 9,9 : 12,26 '' - IL_002e: ldloc.1 - IL_002f: ldloc.2 - IL_0030: call bool [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/HashCompare::GenericEqualityIntrinsic(!!0, - !!0) - IL_0035: stloc.0 - IL_0036: ldloc.3 - IL_0037: ldc.i4.1 - IL_0038: add - IL_0039: stloc.3 + IL_002e: call class [mscorlib]System.Collections.Generic.EqualityComparer`1 class [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/HashCompare/FSharpEqualityComparer_PER`1::get_EqualityComparer() + IL_0033: ldloc.1 + IL_0034: ldloc.2 + IL_0035: callvirt instance bool class [mscorlib]System.Collections.Generic.EqualityComparer`1::Equals(!0, + !0) + IL_003a: stloc.0 + IL_003b: ldloc.3 + IL_003c: ldc.i4.1 + IL_003d: add + IL_003e: stloc.3 .line 8,8 : 8,32 '' - IL_003a: ldloc.3 - IL_003b: ldc.i4 0x989681 - IL_0040: blt.s IL_002e + IL_003f: ldloc.3 + IL_0040: ldc.i4 0x989681 + IL_0045: blt.s IL_002e .line 10,10 : 8,9 '' - IL_0042: ldloc.0 - IL_0043: ret + IL_0047: ldloc.0 + IL_0048: ret } // end of method EqualsMicroPerfAndCodeGenerationTests::f8 } // end of class EqualsMicroPerfAndCodeGenerationTests diff --git a/tests/fsharpqa/Source/Optimizations/GenericComparison/Hash09.il.bsl b/tests/fsharpqa/Source/Optimizations/GenericComparison/Hash09.il.bsl index df7b115d207..726d2aea5e8 100644 --- a/tests/fsharpqa/Source/Optimizations/GenericComparison/Hash09.il.bsl +++ b/tests/fsharpqa/Source/Optimizations/GenericComparison/Hash09.il.bsl @@ -13,7 +13,7 @@ .assembly extern FSharp.Core { .publickeytoken = (B0 3F 5F 7F 11 D5 0A 3A ) // .?_....: - .ver 4:4:1:0 + .ver 4:4:3:0 } .assembly Hash09 { @@ -29,20 +29,20 @@ } .mresource public FSharpSignatureData.Hash09 { - // Offset: 0x00000000 Length: 0x0000088E + // Offset: 0x00000000 Length: 0x00000892 } .mresource public FSharpOptimizationData.Hash09 { - // Offset: 0x00000898 Length: 0x00000686 + // Offset: 0x00000898 Length: 0x0000068E } .module Hash09.dll -// MVID: {59B18AEE-9642-77DB-A745-0383EE8AB159} +// MVID: {5B2D7B11-9642-77DB-A745-0383117B2D5B} .imagebase 0x00400000 .file alignment 0x00000200 .stackreserve 0x00100000 .subsystem 0x0003 // WINDOWS_CUI .corflags 0x00000001 // ILONLY -// Image base: 0x00690000 +// Image base: 0x02990000 // =============== CLASS MEMBERS DECLARATION =================== @@ -187,7 +187,7 @@ [4] !a V_4, [5] !a V_5) .language '{AB4F38C9-B6E6-43BA-BE3B-58080B2CCCE3}', '{994B45C4-E6E9-11D2-903F-00C04FA302A1}', '{5A869D0B-6611-11D3-BD2A-0000F80849BD}' - .line 16707566,16707566 : 0,0 'C:\\GitHub\\dsyme\\visualfsharp\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Hash09.fsx' + .line 16707566,16707566 : 0,0 'C:\\src\\manofstick\\visualfsharp-nobox\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Hash09.fsx' IL_0000: ldarg.0 IL_0001: ldnull IL_0002: cgt.un @@ -560,8 +560,8 @@ instance bool Equals(class Hash09/HashMicroPerfAndCodeGenerationTests/GenericKey`1 obj) cil managed { .custom instance void [mscorlib]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) - // Code size 77 (0x4d) - .maxstack 4 + // Code size 87 (0x57) + .maxstack 5 .locals init ([0] class Hash09/HashMicroPerfAndCodeGenerationTests/GenericKey`1 V_0, [1] class Hash09/HashMicroPerfAndCodeGenerationTests/GenericKey`1 V_1, [2] !a V_2, @@ -570,13 +570,13 @@ IL_0000: ldarg.0 IL_0001: ldnull IL_0002: cgt.un - IL_0004: brfalse.s IL_0045 + IL_0004: brfalse.s IL_004f .line 16707566,16707566 : 0,0 '' IL_0006: ldarg.1 IL_0007: ldnull IL_0008: cgt.un - IL_000a: brfalse.s IL_0043 + IL_000a: brfalse.s IL_004d .line 16707566,16707566 : 0,0 '' IL_000c: ldarg.0 @@ -592,41 +592,43 @@ IL_0019: ldloc.1 IL_001a: ldfld !0 class Hash09/HashMicroPerfAndCodeGenerationTests/GenericKey`1::item1 IL_001f: stloc.3 - IL_0020: ldloc.2 - IL_0021: ldloc.3 - IL_0022: call bool [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/HashCompare::GenericEqualityERIntrinsic(!!0, - !!0) - IL_0027: brfalse.s IL_0041 - - .line 16707566,16707566 : 0,0 '' - IL_0029: ldloc.0 - IL_002a: ldfld !0 class Hash09/HashMicroPerfAndCodeGenerationTests/GenericKey`1::item2 - IL_002f: stloc.2 - IL_0030: ldloc.1 - IL_0031: ldfld !0 class Hash09/HashMicroPerfAndCodeGenerationTests/GenericKey`1::item2 - IL_0036: stloc.3 - IL_0037: ldloc.2 - IL_0038: ldloc.3 - IL_0039: tail. - IL_003b: call bool [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/HashCompare::GenericEqualityERIntrinsic(!!0, - !!0) - IL_0040: ret + IL_0020: call class [mscorlib]System.Collections.Generic.EqualityComparer`1 class [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/HashCompare/FSharpEqualityComparer_ER`1::get_EqualityComparer() + IL_0025: ldloc.2 + IL_0026: ldloc.3 + IL_0027: callvirt instance bool class [mscorlib]System.Collections.Generic.EqualityComparer`1::Equals(!0, + !0) + IL_002c: brfalse.s IL_004b + + .line 16707566,16707566 : 0,0 '' + IL_002e: ldloc.0 + IL_002f: ldfld !0 class Hash09/HashMicroPerfAndCodeGenerationTests/GenericKey`1::item2 + IL_0034: stloc.2 + IL_0035: ldloc.1 + IL_0036: ldfld !0 class Hash09/HashMicroPerfAndCodeGenerationTests/GenericKey`1::item2 + IL_003b: stloc.3 + IL_003c: call class [mscorlib]System.Collections.Generic.EqualityComparer`1 class [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/HashCompare/FSharpEqualityComparer_ER`1::get_EqualityComparer() + IL_0041: ldloc.2 + IL_0042: ldloc.3 + IL_0043: tail. + IL_0045: callvirt instance bool class [mscorlib]System.Collections.Generic.EqualityComparer`1::Equals(!0, + !0) + IL_004a: ret .line 16707566,16707566 : 0,0 '' - IL_0041: ldc.i4.0 - IL_0042: ret + IL_004b: ldc.i4.0 + IL_004c: ret .line 16707566,16707566 : 0,0 '' - IL_0043: ldc.i4.0 - IL_0044: ret + IL_004d: ldc.i4.0 + IL_004e: ret .line 16707566,16707566 : 0,0 '' - IL_0045: ldarg.1 - IL_0046: ldnull - IL_0047: cgt.un - IL_0049: ldc.i4.0 - IL_004a: ceq - IL_004c: ret + IL_004f: ldarg.1 + IL_0050: ldnull + IL_0051: cgt.un + IL_0053: ldc.i4.0 + IL_0054: ceq + IL_0056: ret } // end of method GenericKey`1::Equals .method public hidebysig virtual final diff --git a/tests/fsharpqa/Source/Optimizations/GenericComparison/Hash10.il.bsl b/tests/fsharpqa/Source/Optimizations/GenericComparison/Hash10.il.bsl index 20c3ceeb8f6..029eaf7814a 100644 --- a/tests/fsharpqa/Source/Optimizations/GenericComparison/Hash10.il.bsl +++ b/tests/fsharpqa/Source/Optimizations/GenericComparison/Hash10.il.bsl @@ -13,7 +13,7 @@ .assembly extern FSharp.Core { .publickeytoken = (B0 3F 5F 7F 11 D5 0A 3A ) // .?_....: - .ver 4:4:1:0 + .ver 4:4:3:0 } .assembly Hash10 { @@ -29,20 +29,20 @@ } .mresource public FSharpSignatureData.Hash10 { - // Offset: 0x00000000 Length: 0x00000219 + // Offset: 0x00000000 Length: 0x00000231 } .mresource public FSharpOptimizationData.Hash10 { - // Offset: 0x00000220 Length: 0x000000A9 + // Offset: 0x00000238 Length: 0x000000A9 } .module Hash10.dll -// MVID: {59B18AEE-9661-78B4-A745-0383EE8AB159} +// MVID: {5B2D7B11-9661-78B4-A745-0383117B2D5B} .imagebase 0x00400000 .file alignment 0x00000200 .stackreserve 0x00100000 .subsystem 0x0003 // WINDOWS_CUI .corflags 0x00000001 // ILONLY -// Image base: 0x01080000 +// Image base: 0x01690000 // =============== CLASS MEMBERS DECLARATION =================== @@ -57,13 +57,13 @@ .custom instance void [FSharp.Core]Microsoft.FSharp.Core.CompilationMappingAttribute::.ctor(valuetype [FSharp.Core]Microsoft.FSharp.Core.SourceConstructFlags) = ( 01 00 07 00 00 00 00 00 ) .method public static void f7() cil managed { - // Code size 44 (0x2c) + // Code size 49 (0x31) .maxstack 5 .locals init ([0] uint8[] arr, [1] int32 i, [2] int32 V_2) .language '{AB4F38C9-B6E6-43BA-BE3B-58080B2CCCE3}', '{994B45C4-E6E9-11D2-903F-00C04FA302A1}', '{5A869D0B-6611-11D3-BD2A-0000F80849BD}' - .line 6,6 : 8,36 'C:\\GitHub\\dsyme\\visualfsharp\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Hash10.fsx' + .line 6,6 : 8,36 'C:\\src\\manofstick\\visualfsharp-nobox\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Hash10.fsx' IL_0000: ldc.i4.0 IL_0001: ldc.i4.1 IL_0002: ldc.i4.s 100 @@ -76,22 +76,23 @@ .line 7,7 : 8,32 '' IL_0014: ldc.i4.0 IL_0015: stloc.1 - IL_0016: br.s IL_0023 + IL_0016: br.s IL_0028 .line 8,8 : 12,30 '' - IL_0018: ldloc.0 - IL_0019: call int32 [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/HashCompare::GenericHashIntrinsic(!!0) - IL_001e: stloc.2 - IL_001f: ldloc.1 - IL_0020: ldc.i4.1 - IL_0021: add - IL_0022: stloc.1 + IL_0018: call class [mscorlib]System.Collections.Generic.EqualityComparer`1 class [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/HashCompare/FSharpEqualityComparer_PER`1::get_EqualityComparer() + IL_001d: ldloc.0 + IL_001e: callvirt instance int32 class [mscorlib]System.Collections.Generic.EqualityComparer`1::GetHashCode(!0) + IL_0023: stloc.2 + IL_0024: ldloc.1 + IL_0025: ldc.i4.1 + IL_0026: add + IL_0027: stloc.1 .line 7,7 : 8,32 '' - IL_0023: ldloc.1 - IL_0024: ldc.i4 0x989681 - IL_0029: blt.s IL_0018 + IL_0028: ldloc.1 + IL_0029: ldc.i4 0x989681 + IL_002e: blt.s IL_0018 - IL_002b: ret + IL_0030: ret } // end of method HashMicroPerfAndCodeGenerationTests::f7 } // end of class HashMicroPerfAndCodeGenerationTests diff --git a/tests/fsharpqa/Source/Optimizations/GenericComparison/Hash11.il.bsl b/tests/fsharpqa/Source/Optimizations/GenericComparison/Hash11.il.bsl index f4eb5020175..9848907a1b1 100644 --- a/tests/fsharpqa/Source/Optimizations/GenericComparison/Hash11.il.bsl +++ b/tests/fsharpqa/Source/Optimizations/GenericComparison/Hash11.il.bsl @@ -13,7 +13,7 @@ .assembly extern FSharp.Core { .publickeytoken = (B0 3F 5F 7F 11 D5 0A 3A ) // .?_....: - .ver 4:4:1:0 + .ver 4:4:3:0 } .assembly Hash11 { @@ -29,20 +29,20 @@ } .mresource public FSharpSignatureData.Hash11 { - // Offset: 0x00000000 Length: 0x00000219 + // Offset: 0x00000000 Length: 0x00000231 } .mresource public FSharpOptimizationData.Hash11 { - // Offset: 0x00000220 Length: 0x000000A9 + // Offset: 0x00000238 Length: 0x000000A9 } .module Hash11.dll -// MVID: {59B18AEE-9661-78D3-A745-0383EE8AB159} +// MVID: {5B2D7B11-9661-78D3-A745-0383117B2D5B} .imagebase 0x00400000 .file alignment 0x00000200 .stackreserve 0x00100000 .subsystem 0x0003 // WINDOWS_CUI .corflags 0x00000001 // ILONLY -// Image base: 0x002D0000 +// Image base: 0x027C0000 // =============== CLASS MEMBERS DECLARATION =================== @@ -57,13 +57,13 @@ .custom instance void [FSharp.Core]Microsoft.FSharp.Core.CompilationMappingAttribute::.ctor(valuetype [FSharp.Core]Microsoft.FSharp.Core.SourceConstructFlags) = ( 01 00 07 00 00 00 00 00 ) .method public static void f8() cil managed { - // Code size 44 (0x2c) + // Code size 49 (0x31) .maxstack 5 .locals init ([0] int32[] arr, [1] int32 i, [2] int32 V_2) .language '{AB4F38C9-B6E6-43BA-BE3B-58080B2CCCE3}', '{994B45C4-E6E9-11D2-903F-00C04FA302A1}', '{5A869D0B-6611-11D3-BD2A-0000F80849BD}' - .line 6,6 : 8,32 'C:\\GitHub\\dsyme\\visualfsharp\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Hash11.fsx' + .line 6,6 : 8,32 'C:\\src\\manofstick\\visualfsharp-nobox\\tests\\fsharpqa\\Source\\Optimizations\\GenericComparison\\Hash11.fsx' IL_0000: ldc.i4.0 IL_0001: ldc.i4.1 IL_0002: ldc.i4.s 100 @@ -76,22 +76,23 @@ .line 7,7 : 8,32 '' IL_0014: ldc.i4.0 IL_0015: stloc.1 - IL_0016: br.s IL_0023 + IL_0016: br.s IL_0028 .line 8,8 : 12,30 '' - IL_0018: ldloc.0 - IL_0019: call int32 [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/HashCompare::GenericHashIntrinsic(!!0) - IL_001e: stloc.2 - IL_001f: ldloc.1 - IL_0020: ldc.i4.1 - IL_0021: add - IL_0022: stloc.1 + IL_0018: call class [mscorlib]System.Collections.Generic.EqualityComparer`1 class [FSharp.Core]Microsoft.FSharp.Core.LanguagePrimitives/HashCompare/FSharpEqualityComparer_PER`1::get_EqualityComparer() + IL_001d: ldloc.0 + IL_001e: callvirt instance int32 class [mscorlib]System.Collections.Generic.EqualityComparer`1::GetHashCode(!0) + IL_0023: stloc.2 + IL_0024: ldloc.1 + IL_0025: ldc.i4.1 + IL_0026: add + IL_0027: stloc.1 .line 7,7 : 8,32 '' - IL_0023: ldloc.1 - IL_0024: ldc.i4 0x989681 - IL_0029: blt.s IL_0018 + IL_0028: ldloc.1 + IL_0029: ldc.i4 0x989681 + IL_002e: blt.s IL_0018 - IL_002b: ret + IL_0030: ret } // end of method HashMicroPerfAndCodeGenerationTests::f8 } // end of class HashMicroPerfAndCodeGenerationTests From 1198f42d2e7b2407d44c8f579201bf7cc791959c Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sat, 23 Jun 2018 20:18:15 +1000 Subject: [PATCH 23/92] Fixed SurfaceArea --- .../SurfaceArea.coreclr.fs | 17 +++++++++++++++++ .../FSharp.Core.UnitTests/SurfaceArea.net40.fs | 17 +++++++++++++++++ 2 files changed, 34 insertions(+) diff --git a/tests/FSharp.Core.UnitTests/SurfaceArea.coreclr.fs b/tests/FSharp.Core.UnitTests/SurfaceArea.coreclr.fs index 0f36e747976..ef363486f12 100644 --- a/tests/FSharp.Core.UnitTests/SurfaceArea.coreclr.fs +++ b/tests/FSharp.Core.UnitTests/SurfaceArea.coreclr.fs @@ -2229,11 +2229,25 @@ Microsoft.FSharp.Core.LanguagePrimitives+ErrorStrings: System.String get_InputMu Microsoft.FSharp.Core.LanguagePrimitives+ErrorStrings: System.String get_InputSequenceEmptyString() Microsoft.FSharp.Core.LanguagePrimitives+ErrorStrings: System.String get_NoNegateMinValueString() Microsoft.FSharp.Core.LanguagePrimitives+ErrorStrings: System.Type GetType() +Microsoft.FSharp.Core.LanguagePrimitives+HashCompare+FSharpEqualityComparer_ER`1[T]: Boolean Equals(System.Object) +Microsoft.FSharp.Core.LanguagePrimitives+HashCompare+FSharpEqualityComparer_ER`1[T]: Int32 GetHashCode() +Microsoft.FSharp.Core.LanguagePrimitives+HashCompare+FSharpEqualityComparer_ER`1[T]: System.Collections.Generic.EqualityComparer`1[T] EqualityComparer +Microsoft.FSharp.Core.LanguagePrimitives+HashCompare+FSharpEqualityComparer_ER`1[T]: System.Collections.Generic.EqualityComparer`1[T] get_EqualityComparer() +Microsoft.FSharp.Core.LanguagePrimitives+HashCompare+FSharpEqualityComparer_ER`1[T]: System.String ToString() +Microsoft.FSharp.Core.LanguagePrimitives+HashCompare+FSharpEqualityComparer_ER`1[T]: System.Type GetType() +Microsoft.FSharp.Core.LanguagePrimitives+HashCompare+FSharpEqualityComparer_PER`1[T]: Boolean Equals(System.Object) +Microsoft.FSharp.Core.LanguagePrimitives+HashCompare+FSharpEqualityComparer_PER`1[T]: Int32 GetHashCode() +Microsoft.FSharp.Core.LanguagePrimitives+HashCompare+FSharpEqualityComparer_PER`1[T]: System.Collections.Generic.EqualityComparer`1[T] EqualityComparer +Microsoft.FSharp.Core.LanguagePrimitives+HashCompare+FSharpEqualityComparer_PER`1[T]: System.Collections.Generic.EqualityComparer`1[T] get_EqualityComparer() +Microsoft.FSharp.Core.LanguagePrimitives+HashCompare+FSharpEqualityComparer_PER`1[T]: System.String ToString() +Microsoft.FSharp.Core.LanguagePrimitives+HashCompare+FSharpEqualityComparer_PER`1[T]: System.Type GetType() Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Boolean Equals(System.Object) Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Boolean FastEqualsTuple2[T1,T2](System.Collections.IEqualityComparer, System.Tuple`2[T1,T2], System.Tuple`2[T1,T2]) Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Boolean FastEqualsTuple3[T1,T2,T3](System.Collections.IEqualityComparer, System.Tuple`3[T1,T2,T3], System.Tuple`3[T1,T2,T3]) Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Boolean FastEqualsTuple4[T1,T2,T3,T4](System.Collections.IEqualityComparer, System.Tuple`4[T1,T2,T3,T4], System.Tuple`4[T1,T2,T3,T4]) Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Boolean FastEqualsTuple5[T1,T2,T3,T4,T5](System.Collections.IEqualityComparer, System.Tuple`5[T1,T2,T3,T4,T5], System.Tuple`5[T1,T2,T3,T4,T5]) +Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Boolean FSharpEqualityComparer_ER_Equals[T](T, T) +Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Boolean FSharpEqualityComparer_PER_Equals[T](T, T) Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Boolean GenericEqualityERIntrinsic[T](T, T) Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Boolean GenericEqualityIntrinsic[T](T, T) Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Boolean GenericEqualityWithComparerIntrinsic[T](System.Collections.IEqualityComparer, T, T) @@ -2250,6 +2264,7 @@ Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Int32 FastHashTuple2[T1,T2 Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Int32 FastHashTuple3[T1,T2,T3](System.Collections.IEqualityComparer, System.Tuple`3[T1,T2,T3]) Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Int32 FastHashTuple4[T1,T2,T3,T4](System.Collections.IEqualityComparer, System.Tuple`4[T1,T2,T3,T4]) Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Int32 FastHashTuple5[T1,T2,T3,T4,T5](System.Collections.IEqualityComparer, System.Tuple`5[T1,T2,T3,T4,T5]) +Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Int32 FSharpEqualityComparer_GetHashCode[T](T) Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Int32 GenericComparisonIntrinsic[T](T, T) Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Int32 GenericComparisonWithComparerIntrinsic[T](System.Collections.IComparer, T, T) Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Int32 GenericHashIntrinsic[T](T) @@ -2257,6 +2272,8 @@ Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Int32 GenericHashWithCompa Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Int32 GetHashCode() Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Int32 LimitedGenericHashIntrinsic[T](Int32, T) Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Int32 PhysicalHashIntrinsic[T](T) +Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Microsoft.FSharp.Core.LanguagePrimitives+HashCompare+FSharpEqualityComparer_ER`1[T] +Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Microsoft.FSharp.Core.LanguagePrimitives+HashCompare+FSharpEqualityComparer_PER`1[T] Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: System.String ToString() Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: System.Type GetType() Microsoft.FSharp.Core.LanguagePrimitives+IntrinsicFunctions: Boolean Equals(System.Object) diff --git a/tests/FSharp.Core.UnitTests/SurfaceArea.net40.fs b/tests/FSharp.Core.UnitTests/SurfaceArea.net40.fs index 54038feab93..7f08a8900ac 100644 --- a/tests/FSharp.Core.UnitTests/SurfaceArea.net40.fs +++ b/tests/FSharp.Core.UnitTests/SurfaceArea.net40.fs @@ -2316,11 +2316,25 @@ Microsoft.FSharp.Core.LanguagePrimitives+ErrorStrings: System.String get_InputMu Microsoft.FSharp.Core.LanguagePrimitives+ErrorStrings: System.String get_InputSequenceEmptyString() Microsoft.FSharp.Core.LanguagePrimitives+ErrorStrings: System.String get_NoNegateMinValueString() Microsoft.FSharp.Core.LanguagePrimitives+ErrorStrings: System.Type GetType() +Microsoft.FSharp.Core.LanguagePrimitives+HashCompare+FSharpEqualityComparer_ER`1[T]: Boolean Equals(System.Object) +Microsoft.FSharp.Core.LanguagePrimitives+HashCompare+FSharpEqualityComparer_ER`1[T]: Int32 GetHashCode() +Microsoft.FSharp.Core.LanguagePrimitives+HashCompare+FSharpEqualityComparer_ER`1[T]: System.Collections.Generic.EqualityComparer`1[T] EqualityComparer +Microsoft.FSharp.Core.LanguagePrimitives+HashCompare+FSharpEqualityComparer_ER`1[T]: System.Collections.Generic.EqualityComparer`1[T] get_EqualityComparer() +Microsoft.FSharp.Core.LanguagePrimitives+HashCompare+FSharpEqualityComparer_ER`1[T]: System.String ToString() +Microsoft.FSharp.Core.LanguagePrimitives+HashCompare+FSharpEqualityComparer_ER`1[T]: System.Type GetType() +Microsoft.FSharp.Core.LanguagePrimitives+HashCompare+FSharpEqualityComparer_PER`1[T]: Boolean Equals(System.Object) +Microsoft.FSharp.Core.LanguagePrimitives+HashCompare+FSharpEqualityComparer_PER`1[T]: Int32 GetHashCode() +Microsoft.FSharp.Core.LanguagePrimitives+HashCompare+FSharpEqualityComparer_PER`1[T]: System.Collections.Generic.EqualityComparer`1[T] EqualityComparer +Microsoft.FSharp.Core.LanguagePrimitives+HashCompare+FSharpEqualityComparer_PER`1[T]: System.Collections.Generic.EqualityComparer`1[T] get_EqualityComparer() +Microsoft.FSharp.Core.LanguagePrimitives+HashCompare+FSharpEqualityComparer_PER`1[T]: System.String ToString() +Microsoft.FSharp.Core.LanguagePrimitives+HashCompare+FSharpEqualityComparer_PER`1[T]: System.Type GetType() Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Boolean Equals(System.Object) Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Boolean FastEqualsTuple2[T1,T2](System.Collections.IEqualityComparer, System.Tuple`2[T1,T2], System.Tuple`2[T1,T2]) Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Boolean FastEqualsTuple3[T1,T2,T3](System.Collections.IEqualityComparer, System.Tuple`3[T1,T2,T3], System.Tuple`3[T1,T2,T3]) Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Boolean FastEqualsTuple4[T1,T2,T3,T4](System.Collections.IEqualityComparer, System.Tuple`4[T1,T2,T3,T4], System.Tuple`4[T1,T2,T3,T4]) Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Boolean FastEqualsTuple5[T1,T2,T3,T4,T5](System.Collections.IEqualityComparer, System.Tuple`5[T1,T2,T3,T4,T5], System.Tuple`5[T1,T2,T3,T4,T5]) +Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Boolean FSharpEqualityComparer_ER_Equals[T](T, T) +Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Boolean FSharpEqualityComparer_PER_Equals[T](T, T) Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Boolean GenericEqualityERIntrinsic[T](T, T) Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Boolean GenericEqualityIntrinsic[T](T, T) Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Boolean GenericEqualityWithComparerIntrinsic[T](System.Collections.IEqualityComparer, T, T) @@ -2337,6 +2351,7 @@ Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Int32 FastHashTuple2[T1,T2 Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Int32 FastHashTuple3[T1,T2,T3](System.Collections.IEqualityComparer, System.Tuple`3[T1,T2,T3]) Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Int32 FastHashTuple4[T1,T2,T3,T4](System.Collections.IEqualityComparer, System.Tuple`4[T1,T2,T3,T4]) Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Int32 FastHashTuple5[T1,T2,T3,T4,T5](System.Collections.IEqualityComparer, System.Tuple`5[T1,T2,T3,T4,T5]) +Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Int32 FSharpEqualityComparer_GetHashCode[T](T) Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Int32 GenericComparisonIntrinsic[T](T, T) Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Int32 GenericComparisonWithComparerIntrinsic[T](System.Collections.IComparer, T, T) Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Int32 GenericHashIntrinsic[T](T) @@ -2344,6 +2359,8 @@ Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Int32 GenericHashWithCompa Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Int32 GetHashCode() Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Int32 LimitedGenericHashIntrinsic[T](Int32, T) Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Int32 PhysicalHashIntrinsic[T](T) +Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Microsoft.FSharp.Core.LanguagePrimitives+HashCompare+FSharpEqualityComparer_ER`1[T] +Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: Microsoft.FSharp.Core.LanguagePrimitives+HashCompare+FSharpEqualityComparer_PER`1[T] Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: System.String ToString() Microsoft.FSharp.Core.LanguagePrimitives+HashCompare: System.Type GetType() Microsoft.FSharp.Core.LanguagePrimitives+IntrinsicFunctions: Boolean Equals(System.Object) From 41ddb084d02e5440088ca4f52d5e2bd6e1faf883 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sun, 24 Jun 2018 06:51:05 +1000 Subject: [PATCH 24/92] Ensure FSharp.Core has the optimization functions (and added comments) --- src/fsharp/Optimizer.fs | 32 +++++++++++++++++++++++++------- 1 file changed, 25 insertions(+), 7 deletions(-) diff --git a/src/fsharp/Optimizer.fs b/src/fsharp/Optimizer.fs index 4921dcff817..d5bdf9a282d 100644 --- a/src/fsharp/Optimizer.fs +++ b/src/fsharp/Optimizer.fs @@ -2333,7 +2333,10 @@ and TryDevirtualizeApplication cenv env (f, tyargs, args, m) = match tcref.GeneratedHashAndEqualsValues with | Some (_, vref) -> Some (DevirtualizeApplication cenv env vref ty tyargs args m) | _ -> - Some (DevirtualizeApplication cenv env cenv.g.fsharpEqualityComparer_ER_Equals_vref ty tyargsOriginal args m) + // if type of generic argument has no generated equality operators, covert to "FSharpEqualityComparer_ER<'T>.EqualityComparer.Equals" + match cenv.g.fsharpEqualityComparer_ER_Equals_vref.TryDeref with + | ValueNone -> None // referencing old version of FSharp.Core.dll + | _ -> Some (DevirtualizeApplication cenv env cenv.g.fsharpEqualityComparer_ER_Equals_vref ty tyargsOriginal args m) // Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericEqualityWithComparerFast | Expr.Val(v, _, _), [ty], _ when CanDevirtualizeApplication cenv v cenv.g.generic_equality_withc_inner_vref ty args -> @@ -2354,7 +2357,10 @@ and TryDevirtualizeApplication cenv env (f, tyargs, args, m) = let args2 = [x; mkRefTupledNoTypes cenv.g m [mkCoerceExpr(y, cenv.g.obj_ty, m, ty); (mkCallGetGenericPEREqualityComparer cenv.g m)]] Some (DevirtualizeApplication cenv env withcEqualsVal ty tyargs args2 m) | _ -> - Some (DevirtualizeApplication cenv env cenv.g.fsharpEqualityComparer_PER_Equals_vref ty tyargsOriginal args m) + // if type of generic argument has no generated equality operators, covert to "FSharpEqualityComparer_PER<'T>.EqualityComparer.Equals" + match cenv.g.fsharpEqualityComparer_PER_Equals_vref.TryDeref with + | ValueNone -> None // referencing old version of FSharp.Core.dll + | _ -> Some (DevirtualizeApplication cenv env cenv.g.fsharpEqualityComparer_PER_Equals_vref ty tyargsOriginal args m) // Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericHashIntrinsic | Expr.Val(v, _, _), [ty], _ when CanDevirtualizeApplication cenv v cenv.g.generic_hash_inner_vref ty args -> @@ -2364,8 +2370,11 @@ and TryDevirtualizeApplication cenv env (f, tyargs, args, m) = | Some (_, withcGetHashCodeVal, _), [x] -> let args2 = [x; mkCallGetGenericEREqualityComparer cenv.g m] Some (DevirtualizeApplication cenv env withcGetHashCodeVal ty tyargs args2 m) - | _ -> - Some (DevirtualizeApplication cenv env cenv.g.fsharpEqualityComparer_GetHashCode_vref ty tyargsOriginal args m) + | _ -> + // if type of generic argument has no generated equality operators, covert to "FSharpEqualityComparer_PER<'T>.EqualityComparer.GetHashCode" + match cenv.g.fsharpEqualityComparer_GetHashCode_vref.TryDeref with + | ValueNone -> None // referencing old version of FSharp.Core.dll + | _ -> Some (DevirtualizeApplication cenv env cenv.g.fsharpEqualityComparer_GetHashCode_vref ty tyargsOriginal args m) // Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericHashWithComparerIntrinsic | Expr.Val(v, _, _), [ty], _ when CanDevirtualizeApplication cenv v cenv.g.generic_hash_withc_inner_vref ty args -> @@ -2421,14 +2430,23 @@ and TryDevirtualizeApplication cenv env (f, tyargs, args, m) = | Some vref -> Some (DevirtualizeApplication cenv env vref ty tyargs (mkCallGetGenericPEREqualityComparer cenv.g m :: args) m) | None -> None + // "GenericEqualityIntrinsic" when found in a generic context, convert to "FSharpEqualityComparer_PER<'T>.EqualityComparer.Equals" | Expr.Val(v, _, _), [(TType_var t) as ty], _ when (not cenv.g.compilingFslib) && valRefEq cenv.g v cenv.g.generic_equality_per_inner_vref && t.Rigidity = TyparRigidity.Rigid -> - Some (DevirtualizeApplication cenv env cenv.g.fsharpEqualityComparer_PER_Equals_vref ty tyargs args m) + match cenv.g.fsharpEqualityComparer_PER_Equals_vref.TryDeref with + | ValueNone -> None // referencing old version of FSharp.Core.dll + | _ -> Some (DevirtualizeApplication cenv env cenv.g.fsharpEqualityComparer_PER_Equals_vref ty tyargs args m) + // "GenericEqualityERIntrinsic" when found in a generic context, convert to "FSharpEqualityComparer_ER<'T>.EqualityComparer.Equals" | Expr.Val(v, _, _), [(TType_var t) as ty], _ when (not cenv.g.compilingFslib) && valRefEq cenv.g v cenv.g.generic_equality_er_inner_vref && t.Rigidity = TyparRigidity.Rigid -> - Some (DevirtualizeApplication cenv env cenv.g.fsharpEqualityComparer_ER_Equals_vref ty tyargs args m) + match cenv.g.fsharpEqualityComparer_ER_Equals_vref.TryDeref with + | ValueNone -> None // referencing old version of FSharp.Core.dll + | _ -> Some (DevirtualizeApplication cenv env cenv.g.fsharpEqualityComparer_ER_Equals_vref ty tyargs args m) + // "GenericHashIntrinsic" when found in a generic context, convert to "FSharpEqualityComparer_PER<'T>.EqualityComparer.GetHashCode" | Expr.Val(v, _, _), [(TType_var t) as ty], _ when (not cenv.g.compilingFslib) && valRefEq cenv.g v cenv.g.generic_hash_inner_vref && t.Rigidity = TyparRigidity.Rigid -> - Some (DevirtualizeApplication cenv env cenv.g.fsharpEqualityComparer_GetHashCode_vref ty tyargs args m) + match cenv.g.fsharpEqualityComparer_GetHashCode_vref.TryDeref with + | ValueNone -> None // referencing old version of FSharp.Core.dll + | _ -> Some (DevirtualizeApplication cenv env cenv.g.fsharpEqualityComparer_GetHashCode_vref ty tyargs args m) // Optimize/analyze calls to LanguagePrimitives.HashCompare.GenericComparisonWithComparerIntrinsic for tuple types | Expr.Val(v, _, _), [ty], _ when valRefEq cenv.g v cenv.g.generic_comparison_withc_inner_vref && isRefTupleTy cenv.g ty -> From d845e48de726267b7c84438b43126c8cb79efa8d Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Mon, 25 Jun 2018 19:20:17 +1000 Subject: [PATCH 25/92] Remove IL bloat from this PR as per https://github.com/Microsoft/visualfsharp/issues/5212 --- src/fsharp/FSharp.Core/prim-types.fs | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index fd7c235cb58..c5a590da292 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -1719,12 +1719,26 @@ namespace Microsoft.FSharp.Core | null, _ -> false | _, null -> false | (:? (obj[]) as arr1), (:? (obj[]) as arr2) -> GenericEqualityObjArray er iec arr1 arr2 + | _ -> + match xobj,yobj with | (:? (byte[]) as arr1), (:? (byte[]) as arr2) -> GenericEqualityByteArray arr1 arr2 + | _ -> + match xobj,yobj with | (:? (int32[]) as arr1), (:? (int32[]) as arr2) -> GenericEqualityInt32Array arr1 arr2 + | _ -> + match xobj,yobj with | (:? (int64[]) as arr1), (:? (int64[]) as arr2) -> GenericEqualityInt64Array arr1 arr2 + | _ -> + match xobj,yobj with | (:? (char[]) as arr1), (:? (char[]) as arr2) -> GenericEqualityCharArray arr1 arr2 + | _ -> + match xobj,yobj with | (:? (float32[]) as arr1), (:? (float32[]) as arr2) -> GenericEqualitySingleArray er arr1 arr2 + | _ -> + match xobj,yobj with | (:? (float[]) as arr1), (:? (float[]) as arr2) -> GenericEqualityDoubleArray er arr1 arr2 + | _ -> + match xobj,yobj with | (:? System.Array as arr1), (:? System.Array as arr2) -> GenericEqualityArbArray er iec arr1 arr2 | _ -> raise (Exception "invalid logic - expected array") From 251dbdbf03429ae052ffbf24d1e39417e115ce18 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Tue, 26 Jun 2018 19:50:58 +1000 Subject: [PATCH 26/92] Remove null checks for IStructuralEquality Value Types --- src/fsharp/FSharp.Core/prim-types.fs | 24 ++++++++++++++++-------- 1 file changed, 16 insertions(+), 8 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index c5a590da292..fe788bd3291 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -1649,6 +1649,7 @@ namespace Microsoft.FSharp.Core res let isStructuralEquatable (ty:Type) = typeof.IsAssignableFrom ty + let isValueTypeStructuralEquatable (ty:Type) = isStructuralEquatable ty && ty.IsValueType let isArray (ty:Type) = ty.IsArray || (typeof.IsAssignableFrom ty) let canUseDefaultEqualityComparer er (rootType:Type) = @@ -1772,6 +1773,11 @@ namespace Microsoft.FSharp.Core | :? IStructuralEquatable as a -> a.GetHashCode fsEqualityComparerUnlimitedHashingPER | _ -> raise (Exception "invalid logic - expected IStructuralEquatable") } + let structuralEqualityComparerValueType<'T> comparer = + { new EqualityComparer<'T>() with + member __.Equals (x,y) = ((box x):?>IStructuralEquatable).Equals (y, comparer) + member __.GetHashCode x = ((box x):?>IStructuralEquatable).GetHashCode fsEqualityComparerUnlimitedHashingPER } + let unknownEqualityComparer<'T> er comparer = { new EqualityComparer<'T>() with member __.Equals (x,y) = GenericEqualityObj er comparer (box x, box y) @@ -1779,14 +1785,16 @@ namespace Microsoft.FSharp.Core let getGenericEquality<'T> er = match tryGetFSharpEqualityComparer er typeof<'T> with - | :? EqualityComparer<'T> as call -> call - | _ when canUseDefaultEqualityComparer er typeof<'T> -> EqualityComparer<'T>.Default - | _ when isArray typeof<'T> && er -> arrayEqualityComparer true fsEqualityComparerUnlimitedHashingER - | _ when isArray typeof<'T> -> arrayEqualityComparer false fsEqualityComparerUnlimitedHashingPER - | _ when isStructuralEquatable typeof<'T> && er -> structuralEqualityComparer fsEqualityComparerUnlimitedHashingER - | _ when isStructuralEquatable typeof<'T> -> structuralEqualityComparer fsEqualityComparerUnlimitedHashingPER - | _ when er -> unknownEqualityComparer true fsEqualityComparerUnlimitedHashingER - | _ -> unknownEqualityComparer false fsEqualityComparerUnlimitedHashingPER + | :? EqualityComparer<'T> as call -> call + | _ when canUseDefaultEqualityComparer er typeof<'T> -> EqualityComparer<'T>.Default + | _ when isArray typeof<'T> && er -> arrayEqualityComparer true fsEqualityComparerUnlimitedHashingER + | _ when isArray typeof<'T> -> arrayEqualityComparer false fsEqualityComparerUnlimitedHashingPER + | _ when isValueTypeStructuralEquatable typeof<'T> && er -> structuralEqualityComparerValueType fsEqualityComparerUnlimitedHashingER + | _ when isValueTypeStructuralEquatable typeof<'T> -> structuralEqualityComparerValueType fsEqualityComparerUnlimitedHashingPER + | _ when isStructuralEquatable typeof<'T> && er -> structuralEqualityComparer fsEqualityComparerUnlimitedHashingER + | _ when isStructuralEquatable typeof<'T> -> structuralEqualityComparer fsEqualityComparerUnlimitedHashingPER + | _ when er -> unknownEqualityComparer true fsEqualityComparerUnlimitedHashingER + | _ -> unknownEqualityComparer false fsEqualityComparerUnlimitedHashingPER [] type FSharpEqualityComparer_ER<'T> private () = From 4a68ba5ca767a42e64ecb8a914656fa30378e656 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Wed, 27 Jun 2018 15:58:29 +1000 Subject: [PATCH 27/92] Consolidated Type Specific Array Equality functions --- src/fsharp/FSharp.Core/prim-types.fs | 126 +++++---------------------- 1 file changed, 20 insertions(+), 106 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index fe788bd3291..87ce50eb3d1 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -1378,105 +1378,30 @@ namespace Microsoft.FSharp.Core when 'T : char = not (# "clt" x y : bool #) when 'T : decimal = System.Decimal.op_GreaterThanOrEqual ((# "" x:decimal #), (# "" y:decimal #)) - //------------------------------------------------------------------------- // LanguagePrimitives.HashCompare: EQUALITY //------------------------------------------------------------------------- - - /// optimized case: Core implementation of structural equality on arrays. - let GenericEqualityByteArray (x:byte[]) (y:byte[]) : bool= - let lenx = x.Length - let leny = y.Length - let c = (lenx = leny) - if not c then c - else - let mutable i = 0 - let mutable res = true - while i < lenx do - let c = byteEq (get x i) (get y i) - if not c then (res <- false; i <- lenx) - else i <- i + 1 - res - - /// optimized case: Core implementation of structural equality on arrays. - let GenericEqualityInt32Array (x:int[]) (y:int[]) : bool= - let lenx = x.Length - let leny = y.Length - let c = (lenx = leny) - if not c then c - else - let mutable i = 0 - let mutable res = true - while i < lenx do - let c = int32Eq (get x i) (get y i) - if not c then (res <- false; i <- lenx) - else i <- i + 1 - res - - /// optimized case: Core implementation of structural equality on arrays - let GenericEqualitySingleArray er (x:float32[]) (y:float32[]) : bool= - let lenx = x.Length - let leny = y.Length - let f32eq x y = if er && not(float32Eq x x) && not(float32Eq y y) then true else (float32Eq x y) - let c = (lenx = leny) - if not c then c - else - let mutable i = 0 - let mutable res = true - while i < lenx do - let c = f32eq (get x i) (get y i) - if not c then (res <- false; i <- lenx) - else i <- i + 1 - res - - /// optimized case: Core implementation of structural equality on arrays. - let GenericEqualityDoubleArray er (x:float[]) (y:float[]) : bool= - let lenx = x.Length - let leny = y.Length - let c = (lenx = leny) - let feq x y = if er && not(floatEq x x) && not(floatEq y y) then true else (floatEq x y) - if not c then c - else - let mutable i = 0 - let mutable res = true - while i < lenx do - let c = feq (get x i) (get y i) - if not c then (res <- false; i <- lenx) - else i <- i + 1 - res - - /// optimized case: Core implementation of structural equality on arrays. - let GenericEqualityCharArray (x:char[]) (y:char[]) : bool= - let lenx = x.Length - let leny = y.Length - let c = (lenx = leny) - if not c then c - else - let mutable i = 0 - let mutable res = true - while i < lenx do - let c = charEq (get x i) (get y i) - if not c then (res <- false; i <- lenx) - else i <- i + 1 - res - - /// optimized case: Core implementation of structural equality on arrays. - let GenericEqualityInt64Array (x:int64[]) (y:int64[]) : bool= + let inline ArrayEquality<'T> (f:'T->'T->bool) (x:'T[]) (y:'T[]) : bool = let lenx = x.Length let leny = y.Length - let c = (lenx = leny) - if not c then c - else - let mutable i = 0 - let mutable res = true - while i < lenx do - let c = int64Eq (get x i) (get y i) - if not c then (res <- false; i <- lenx) - else i <- i + 1 - res - - + let rec loop i = + if i = lenx then true + elif f (get x i) (get y i) then loop (i+1) + else false + (lenx = leny) && loop 0 + + let inline ArrayEqualityWithERFlag<'T> (er:bool) (f:'T->'T->bool) (x:'T[]) (y:'T[]) : bool = + if er + then ArrayEquality (fun x y -> (not (f x x) && not (f y y)) || (f x y)) x y + else ArrayEquality f x y + + let GenericEqualityByteArray x y = ArrayEquality byteEq x y + let GenericEqualityInt32Array x y = ArrayEquality int32Eq x y + let GenericEqualitySingleArray er x y = ArrayEqualityWithERFlag er float32Eq x y + let GenericEqualityDoubleArray er x y = ArrayEqualityWithERFlag er floatEq x y + let GenericEqualityCharArray x y = ArrayEquality charEq x y + let GenericEqualityInt64Array x y = ArrayEquality int64Eq x y /// The core implementation of generic equality between two objects. This corresponds /// to th e pseudo-code in the F# language spec. @@ -1634,19 +1559,8 @@ namespace Microsoft.FSharp.Core #endif /// optimized case: Core implementation of structural equality on object arrays. - and GenericEqualityObjArray er iec (x:obj[]) (y:obj[]) : bool = - let lenx = x.Length - let leny = y.Length - let c = (lenx = leny ) - if not c then c - else - let mutable i = 0 - let mutable res = true - while i < lenx do - let c = GenericEqualityObj er iec ((get x i),(get y i)) - if not c then (res <- false; i <- lenx) - else i <- i + 1 - res + and GenericEqualityObjArray er iec (xarray:obj[]) (yarray:obj[]) : bool = + ArrayEquality (fun x y -> GenericEqualityObj er iec (x, y)) xarray yarray let isStructuralEquatable (ty:Type) = typeof.IsAssignableFrom ty let isValueTypeStructuralEquatable (ty:Type) = isStructuralEquatable ty && ty.IsValueType From 6bce4b8942fc99278d5e6e94bdb9ae014db8a4bf Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Thu, 28 Jun 2018 08:59:46 +1000 Subject: [PATCH 28/92] Fix compiler call via FSharpFunc.Invoke rather than direct --- src/fsharp/FSharp.Core/prim-types.fs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index 87ce50eb3d1..85079264009 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -1657,7 +1657,7 @@ namespace Microsoft.FSharp.Core | (:? System.Array as arr1), (:? System.Array as arr2) -> GenericEqualityArbArray er iec arr1 arr2 | _ -> raise (Exception "invalid logic - expected array") - let getHashCode iec (xobj:obj) = + let getHashCode (iec, xobj:obj) = match xobj with | null -> 0 | :? (obj[]) as oa -> GenericHashObjArray iec oa @@ -1669,7 +1669,7 @@ namespace Microsoft.FSharp.Core { new EqualityComparer<'T>() with member __.Equals (x, y) = arrayEquals er comparer (box x) (box y) - member __.GetHashCode x = getHashCode fsEqualityComparerUnlimitedHashingPER (box x) } + member __.GetHashCode x = getHashCode (fsEqualityComparerUnlimitedHashingPER, box x) } let structuralEqualityComparer<'T> comparer = { new EqualityComparer<'T>() with From b5e263389e24826c32d99d573a39ed4c00cbf0cd Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Thu, 28 Jun 2018 11:35:25 +1000 Subject: [PATCH 29/92] Replaced duplicated GetHashCode code with inline function --- src/fsharp/FSharp.Core/prim-types.fs | 77 ++++++++-------------------- 1 file changed, 20 insertions(+), 57 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index 85079264009..7084299bde7 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -806,66 +806,29 @@ namespace Microsoft.FSharp.Core let inline HashCombine nr x y = (x <<< 1) + y + 631 * nr - let GenericHashObjArray (iec : System.Collections.IEqualityComparer) (x: obj[]) : int = - let len = x.Length - let mutable i = len - 1 - if i > defaultHashNodes then i <- defaultHashNodes // limit the hash - let mutable acc = 0 - while (i >= 0) do - // NOTE: GenericHash* call decreases nr - acc <- HashCombine i acc (iec.GetHashCode(x.GetValue(i))); - i <- i - 1 - acc - - // optimized case - byte arrays - let GenericHashByteArray (x: byte[]) : int = - let len = length x - let mutable i = len - 1 - if i > defaultHashNodes then i <- defaultHashNodes // limit the hash - let mutable acc = 0 - while (i >= 0) do - acc <- HashCombine i acc (intOfByte (get x i)); - i <- i - 1 - acc - - // optimized case - int arrays - let GenericHashInt32Array (x: int[]) : int = - let len = length x - let mutable i = len - 1 - if i > defaultHashNodes then i <- defaultHashNodes // limit the hash - let mutable acc = 0 - while (i >= 0) do - acc <- HashCombine i acc (get x i); - i <- i - 1 - acc - - // optimized case - int arrays - let GenericHashInt64Array (x: int64[]) : int = - let len = length x - let mutable i = len - 1 - if i > defaultHashNodes then i <- defaultHashNodes // limit the hash - let mutable acc = 0 - while (i >= 0) do - acc <- HashCombine i acc (int32 (get x i)); - i <- i - 1 - acc + let inline ArrayHashing<'element,'array when 'array :> System.Array> get lowerBound (f:'element->int) (x:'array) : int = + let rec loop acc i = + if i < lowerBound then acc + else loop (HashCombine i acc (f (get x i))) (i-1) + + let lastIdx = + let upperBound = lowerBound+defaultHashNodes + match lowerBound+x.Length-1 with + | oversized when oversized > upperBound -> upperBound + | good -> good + + loop 0 lastIdx + + let GenericHashObjArray (iec:System.Collections.IEqualityComparer) (x:obj[]) = ArrayHashing get 0 iec.GetHashCode x + let GenericHashByteArray (x:byte[]) = ArrayHashing get 0 intOfByte x + let GenericHashInt32Array (x:int32[]) = ArrayHashing get 0 (fun x -> x) x + let GenericHashInt64Array (x:int64[]) = ArrayHashing get 0 int32 x // special case - arrays do not by default have a decent structural hashing function let GenericHashArbArray (iec : System.Collections.IEqualityComparer) (x: System.Array) : int = - match x.Rank with - | 1 -> - let b = x.GetLowerBound(0) - let len = x.Length - let mutable i = b + len - 1 - if i > b + defaultHashNodes then i <- b + defaultHashNodes // limit the hash - let mutable acc = 0 - while (i >= b) do - // NOTE: GenericHash* call decreases nr - acc <- HashCombine i acc (iec.GetHashCode(x.GetValue(i))); - i <- i - 1 - acc - | _ -> - HashCombine 10 (x.GetLength(0)) (x.GetLength(1)) + match x.Rank with + | 1 -> ArrayHashing (fun a i -> a.GetValue i) (x.GetLowerBound 0) iec.GetHashCode x + | _ -> HashCombine 10 (x.GetLength(0)) (x.GetLength(1)) // Core implementation of structural hashing, corresponds to pseudo-code in the // F# Language spec. Searches for the IStructuralHash interface, otherwise uses GetHashCode(). From 7551f9326b8c72b03a183a4fa96a5a601a9e2d30 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Thu, 28 Jun 2018 12:27:58 +1000 Subject: [PATCH 30/92] Common array EqualityComparers (for types that previously had specialized GetHashCode) --- src/fsharp/FSharp.Core/prim-types.fs | 90 +++++++++++++++------------- 1 file changed, 48 insertions(+), 42 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index 7084299bde7..f512e7527b8 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -1590,49 +1590,55 @@ namespace Microsoft.FSharp.Core | true, ty when ty.Equals typeof -> box EqualityComparer.Default | _ -> null - let arrayEqualityComparer<'T> er comparer = - let arrayEquals (er:bool) (iec:System.Collections.IEqualityComparer) (xobj:obj) (yobj:obj) : bool = - match xobj,yobj with - | null, null -> true - | null, _ -> false - | _, null -> false - | (:? (obj[]) as arr1), (:? (obj[]) as arr2) -> GenericEqualityObjArray er iec arr1 arr2 - | _ -> - match xobj,yobj with - | (:? (byte[]) as arr1), (:? (byte[]) as arr2) -> GenericEqualityByteArray arr1 arr2 - | _ -> - match xobj,yobj with - | (:? (int32[]) as arr1), (:? (int32[]) as arr2) -> GenericEqualityInt32Array arr1 arr2 - | _ -> - match xobj,yobj with - | (:? (int64[]) as arr1), (:? (int64[]) as arr2) -> GenericEqualityInt64Array arr1 arr2 - | _ -> - match xobj,yobj with - | (:? (char[]) as arr1), (:? (char[]) as arr2) -> GenericEqualityCharArray arr1 arr2 - | _ -> - match xobj,yobj with - | (:? (float32[]) as arr1), (:? (float32[]) as arr2) -> GenericEqualitySingleArray er arr1 arr2 - | _ -> - match xobj,yobj with - | (:? (float[]) as arr1), (:? (float[]) as arr2) -> GenericEqualityDoubleArray er arr1 arr2 - | _ -> - match xobj,yobj with - | (:? System.Array as arr1), (:? System.Array as arr2) -> GenericEqualityArbArray er iec arr1 arr2 - | _ -> raise (Exception "invalid logic - expected array") - - let getHashCode (iec, xobj:obj) = - match xobj with - | null -> 0 - | :? (obj[]) as oa -> GenericHashObjArray iec oa - | :? (byte[]) as ba -> GenericHashByteArray ba - | :? (int[]) as ba -> GenericHashInt32Array ba - | :? (int64[]) as ba -> GenericHashInt64Array ba - | :? System.Array as a -> GenericHashArbArray iec a - | _ -> raise (Exception "invalid logic - expected array") + let inline nullableEqualityComparer<'a when 'a : null> equals getHashCode = + box { new EqualityComparer<'a>() with + member __.Equals (x,y) = + match x, y with + | null, null -> true + | null, _ -> false + | _, null -> false + | _ -> equals x y + + member __.GetHashCode x = + match x with + | null -> 0 + | _ -> getHashCode x } + + let tryGetFSharpArrayEqualityComparer (ty:Type) er comparer : obj = + if ty.Equals typeof then nullableEqualityComparer (fun x y -> GenericEqualityObjArray er comparer x y) (GenericHashObjArray fsEqualityComparerUnlimitedHashingPER) + elif ty.Equals typeof then nullableEqualityComparer GenericEqualityByteArray GenericHashByteArray + elif ty.Equals typeof then nullableEqualityComparer GenericEqualityInt32Array GenericHashInt32Array + elif ty.Equals typeof then nullableEqualityComparer GenericEqualityInt64Array GenericHashInt64Array + else null - { new EqualityComparer<'T>() with - member __.Equals (x, y) = arrayEquals er comparer (box x) (box y) - member __.GetHashCode x = getHashCode (fsEqualityComparerUnlimitedHashingPER, box x) } + let arrayEqualityComparer<'T> er comparer = + match tryGetFSharpArrayEqualityComparer typeof<'T> er comparer with + | :? EqualityComparer<'T> as arrayComparer -> arrayComparer + | _ -> + { new EqualityComparer<'T>() with + member __.Equals (x, y) = + let xobj, yobj = box x, box y + match xobj,yobj with + | null, null -> true + | null, _ -> false + | _, null -> false + | (:? (char[]) as arr1), (:? (char[]) as arr2) -> GenericEqualityCharArray arr1 arr2 + | _ -> + match xobj,yobj with + | (:? (float32[]) as arr1), (:? (float32[]) as arr2) -> GenericEqualitySingleArray er arr1 arr2 + | _ -> + match xobj,yobj with + | (:? (float[]) as arr1), (:? (float[])as arr2) -> GenericEqualityDoubleArray er arr1 arr2 + | _ -> + match xobj,yobj with + | (:? System.Array as arr1), (:? System.Array as arr2) -> GenericEqualityArbArray er comparer arr1 arr2 + | _ -> raise (Exception "invalid logic - expected array") + + member __.GetHashCode x = + match box x with + | null -> 0 + | :? System.Array as a -> GenericHashArbArray fsEqualityComparerUnlimitedHashingPER a + | _ -> raise (Exception "invalid logic - expected array") } let structuralEqualityComparer<'T> comparer = { new EqualityComparer<'T>() with From 02f05d1f7c3b8ef2fbc085f414d268e0ddee266e Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Wed, 11 Jul 2018 16:59:13 +1000 Subject: [PATCH 31/92] Fix regression in regards to hash code on fast-path covariant arrays (+ comments) --- src/fsharp/FSharp.Core/prim-types.fs | 30 ++++++++++++++++++++++------ 1 file changed, 24 insertions(+), 6 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index f512e7527b8..9da460dd5fa 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -839,6 +839,12 @@ namespace Microsoft.FSharp.Core match x with | null -> 0 | (:? System.Array as a) -> + // due to the rules of the CLI type system, array casts are "assignment compatible" + // see: https://blogs.msdn.microsoft.com/ericlippert/2009/09/24/why-is-covariance-of-value-typed-arrays-inconsistent/ + // this means that the cast and comparison for byte will also handle sbyte, int32 handle uint32, + // and int64 handle uint64. The hash code of an individual array element is different for the different + // types, but it is irrelevant for the creation of the hash code - but this is to be replicated in + // the tryGetFSharpArrayEqualityComparer function. match a with | :? (obj[]) as oa -> GenericHashObjArray iec oa | :? (byte[]) as ba -> GenericHashByteArray ba @@ -1383,10 +1389,12 @@ namespace Microsoft.FSharp.Core | (:? string as xs),(:? string as ys) -> System.String.Equals(xs,ys) // Permit structural equality on arrays | (:? System.Array as arr1),_ -> + // due to the rules of the CLI type system, array casts are "assignment compatible" + // see: https://blogs.msdn.microsoft.com/ericlippert/2009/09/24/why-is-covariance-of-value-typed-arrays-inconsistent/ + // this means that the cast and comparison for byte will also handle sbyte, int32 handle uint32, + // and int64 handle uint64. Equality will still be correct. match arr1,yobj with - // Fast path | (:? (obj[]) as arr1), (:? (obj[]) as arr2) -> GenericEqualityObjArray er iec arr1 arr2 - // Fast path | (:? (byte[]) as arr1), (:? (byte[]) as arr2) -> GenericEqualityByteArray arr1 arr2 | (:? (int32[]) as arr1), (:? (int32[]) as arr2) -> GenericEqualityInt32Array arr1 arr2 | (:? (int64[]) as arr1), (:? (int64[]) as arr2) -> GenericEqualityInt64Array arr1 arr2 @@ -1604,11 +1612,21 @@ namespace Microsoft.FSharp.Core | null -> 0 | _ -> getHashCode x } + let inline castNullableEqualityComparer<'fromType, 'toType when 'toType : null and 'fromType : null> (equals:'toType->'toType->bool) (getHashCode:'toType->int) = + let castEquals (lhs:'fromType) (rhs:'fromType) = equals (unboxPrim lhs) (unboxPrim rhs) + let castGetHashCode (o:'fromType) = getHashCode (unboxPrim o) + nullableEqualityComparer castEquals castGetHashCode + let tryGetFSharpArrayEqualityComparer (ty:Type) er comparer : obj = - if ty.Equals typeof then nullableEqualityComparer (fun x y -> GenericEqualityObjArray er comparer x y) (GenericHashObjArray fsEqualityComparerUnlimitedHashingPER) - elif ty.Equals typeof then nullableEqualityComparer GenericEqualityByteArray GenericHashByteArray - elif ty.Equals typeof then nullableEqualityComparer GenericEqualityInt32Array GenericHashInt32Array - elif ty.Equals typeof then nullableEqualityComparer GenericEqualityInt64Array GenericHashInt64Array + // the casts here between byte+sbyte, int32+uint32 and int64+uint64 are here to replicate the behaviour + // in GenericHashParamObj + if ty.Equals typeof then nullableEqualityComparer (fun x y -> GenericEqualityObjArray er comparer x y) (GenericHashObjArray fsEqualityComparerUnlimitedHashingPER) + elif ty.Equals typeof then nullableEqualityComparer GenericEqualityByteArray GenericHashByteArray + elif ty.Equals typeof then castNullableEqualityComparer GenericEqualityByteArray GenericHashByteArray + elif ty.Equals typeof then nullableEqualityComparer GenericEqualityInt32Array GenericHashInt32Array + elif ty.Equals typeof then castNullableEqualityComparer GenericEqualityInt32Array GenericHashInt32Array + elif ty.Equals typeof then nullableEqualityComparer GenericEqualityInt64Array GenericHashInt64Array + elif ty.Equals typeof then castNullableEqualityComparer GenericEqualityInt64Array GenericHashInt64Array else null let arrayEqualityComparer<'T> er comparer = From 3c58e1456739458107018e2916c7429ece737879 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sun, 1 Jul 2018 17:20:08 +1000 Subject: [PATCH 32/92] Similar treatment within prim-types for Comparer as #5112 was for EqualityComparer --- src/fsharp/FSharp.Core/local.fs | 9 +- src/fsharp/FSharp.Core/prim-types.fs | 289 +++++++++++------- src/fsharp/FSharp.Core/prim-types.fsi | 2 +- .../FSharp.Core/ComparersRegression.fs | 75 +++-- 4 files changed, 232 insertions(+), 143 deletions(-) diff --git a/src/fsharp/FSharp.Core/local.fs b/src/fsharp/FSharp.Core/local.fs index 42297795184..971c25d87d9 100644 --- a/src/fsharp/FSharp.Core/local.fs +++ b/src/fsharp/FSharp.Core/local.fs @@ -991,7 +991,7 @@ module internal Array = open System let inline fastComparerForArraySort<'t when 't : comparison> () = - LanguagePrimitives.FastGenericComparerCanBeNull<'t> + LanguagePrimitives.FastGenericComparerInternal<'t> // The input parameter should be checked by callers if necessary let inline zeroCreateUnchecked (count:int) = @@ -1141,13 +1141,12 @@ module internal Array = let len = array.Length if len < 2 then () else - let cFast = LanguagePrimitives.FastGenericComparerCanBeNull<'T> - match cFast with - | null -> + let cFast = LanguagePrimitives.FastGenericComparerInternal<'T> + if obj.ReferenceEquals (cFast, System.Collections.Generic.Comparer<'T>.Default) then // An optimization for the cases where the keys and values coincide and do not have identity, e.g. are integers // In this case an unstable sort is just as good as a stable sort (and faster) Array.Sort<_,_>(array, null) - | _ -> + else // 'keys' is an array storing the projected keys let keys = (array.Clone() :?> array<'T>) stableSortWithKeys array keys diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index 9da460dd5fa..b203689ce40 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -890,7 +890,6 @@ namespace Microsoft.FSharp.Core let inline PhysicalHashFast (input: 'T) = PhysicalHashIntrinsic input - //------------------------------------------------------------------------- // LanguagePrimitives.HashCompare: Comparison // @@ -906,7 +905,6 @@ namespace Microsoft.FSharp.Core let FailGenericComparison (obj: obj) = raise (new System.ArgumentException(String.Format(SR.GetString(SR.genericCompareFail1), obj.GetType().ToString()))) - /// This type has two instances - fsComparerER and fsComparerThrow. /// - fsComparerER = ER semantics = no throw on NaN comparison = new GenericComparer(false) = GenericComparer = GenericComparison @@ -921,7 +919,7 @@ namespace Microsoft.FSharp.Core /// Implements generic comparison between two objects. This corresponds to the pseudo-code in the F# /// specification. The treatment of NaNs is governed by "comp". - let rec GenericCompare (comp:GenericComparer) (xobj:obj,yobj:obj) = + let rec GenericCompare (comp:GenericComparer) (xobj:obj,yobj:obj) = (*if objEq xobj yobj then 0 else *) match xobj,yobj with | null,null -> 0 @@ -1145,11 +1143,177 @@ namespace Microsoft.FSharp.Core override c.Compare(x:obj,y:obj) = GenericCompare c (x,y) /// The unique object for comparing values in PER mode (where local exceptions are thrown when NaNs are compared) - let fsComparerPER = GenericComparer(true) + let fsComparerPER = GenericComparer(true) /// The unique object for comparing values in ER mode (where "0" is returned when NaNs are compared) let fsComparerER = GenericComparer(false) + let isStructuralComparable (ty:Type) = typeof.IsAssignableFrom ty + let isValueTypeStructuralComparable (ty:Type) = isStructuralComparable ty && ty.IsValueType + let isArray (ty:Type) = ty.IsArray || (typeof.IsAssignableFrom ty) + + let canUseDefaultComparer er (rootType:Type) = + let processed = System.Collections.Generic.HashSet () + + let rec checkType idx (types:Type[]) = + if idx = types.Length then true + else + let ty = get types idx + if not (processed.Add ty) then + checkType (idx+1) types + else + let isValidGenericType ifNotType fullname = + if not (ty.IsGenericType && ty.GetGenericTypeDefinition().FullName.Equals fullname) + then ifNotType + else checkType 0 (ty.GetGenericArguments ()) + let isTypeAndGenericArgumentsOK fullname = isValidGenericType false fullname + let isNotTypeOrIsTypeAndGenericArgumentsOK fullname = isValidGenericType true fullname + + // avoid any types that need special handling in GenericEqualityObj + // GenericEqualityObj handles string as a special cases, but internally routes to same equality + + ty.IsSealed // covers enum and value types + // ref types need to be sealed as derived class might implement IStructuralEquatable + && not (isArray ty) + && not (ty.Equals typeof) + && (er || (not (ty.Equals typeof))) + && (er || (not (ty.Equals typeof))) + && isNotTypeOrIsTypeAndGenericArgumentsOK "System.Nullable`1" + && not (isStructuralComparable ty + // we accept ValueTuple even though it supports IStructuralEquatable + // if all generic arguements pass check + && not ( isTypeAndGenericArgumentsOK "System.ValueTuple`1" + || isTypeAndGenericArgumentsOK "System.ValueTuple`2" + || isTypeAndGenericArgumentsOK "System.ValueTuple`3" + || isTypeAndGenericArgumentsOK "System.ValueTuple`4" + || isTypeAndGenericArgumentsOK "System.ValueTuple`5" + || isTypeAndGenericArgumentsOK "System.ValueTuple`6" + || isTypeAndGenericArgumentsOK "System.ValueTuple`7" + || isTypeAndGenericArgumentsOK "System.ValueTuple`8" + || isTypeAndGenericArgumentsOK "Microsoft.FSharp.Collections.FSharpList`1" + || isTypeAndGenericArgumentsOK "Microsoft.FSharp.Core.FSharpOption`1" + || isTypeAndGenericArgumentsOK "Microsoft.FSharp.Core.FSharpValueOption`1" + || isTypeAndGenericArgumentsOK "Microsoft.FSharp.Core.FSharpResult`2" + ) + ) + && checkType (idx+1) types + + checkType 0 [|rootType|] + + let tryGetFSharpComparer (externalUse:bool) (er:bool) (ty:Type) : obj = + match externalUse, er, ty with + | _, false, ty when ty.Equals typeof -> + box { new Comparer() with + member __.Compare (x,y) = + if (# "clt" x y : bool #) then (-1) + elif (# "cgt" x y : bool #) then (1) + elif (# "ceq" x y : bool #) then (0) + else (fsComparerPER:>IComparer).Compare (box x, box y) } + | _, false, ty when ty.Equals typeof -> + box { new Comparer() with + member __.Compare (x,y) = + if (# "clt" x y : bool #) then (-1) + elif (# "cgt" x y : bool #) then (1) + elif (# "ceq" x y : bool #) then (0) + else (fsComparerPER:>IComparer).Compare (box x, box y) } + | _, true, ty when ty.Equals typeof -> box Comparer.Default + | _, true, ty when ty.Equals typeof -> box Comparer.Default + + // the implemention of Comparer.Default returns a current culture specific comparer + | _, _, ty when ty.Equals typeof -> + box { new Comparer() with + member __.Compare (x,y) = System.String.CompareOrdinal(x, y) } + + // the implemention of the following comparers with Comparer<'T>.Default returns + // (int x)-(int y) rather than (sign (int x)-(int y)) + | true, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt.un" x y : bool #) then (-1) else (# "cgt.un" x y : int #) } + | true, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt.un" x y : bool #) then (-1) else (# "cgt.un" x y : int #) } + | true, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt.un" x y : bool #) then (-1) else (# "cgt.un" x y : int #) } + | _, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt.un" x y : bool #) then (-1) else (# "cgt.un" x y : int #) } + | true, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt" x y : bool #) then (-1) else (# "cgt" x y : int #) } + | true, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt" x y : bool #) then (-1) else (# "cgt" x y : int #) } + | _, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt" x y : bool #) then (-1) else (# "cgt" x y : int #) } + + | _ -> null + + let inline nullableComparer<'a when 'a : null> compare = + box { new Comparer<'a>() with + member __.Compare (x,y) = + match x, y with + | null, null -> 0 + | null, _ -> -1 + | _, null -> 1 + | _ -> compare x y } + + let tryGetFSharpArrayComparer (ty:Type) comparer : obj = + if ty.Equals typeof then nullableComparer (fun x y -> GenericComparisonObjArrayWithComparer comparer x y) + elif ty.Equals typeof then nullableComparer GenericComparisonByteArray + else null + + let arrayComparer<'T> comparer = + match tryGetFSharpArrayComparer typeof<'T> comparer with + | :? Comparer<'T> as arrayComparer -> arrayComparer + | _ -> + { new Comparer<'T>() with + member __.Compare (x, y) = + match box x, box y with + | null, null -> 0 + | null, _ -> -1 + | _, null -> 1 + | (:? System.Array as arr1), (:? System.Array as arr2) -> GenericComparisonArbArrayWithComparer comparer arr1 arr2 + | _ -> raise (Exception "invalid logic - expected System.Array") } + + let structuralComparer<'T> comparer = + { new Comparer<'T>() with + member __.Compare (x,y) = + match box x, box y with + | null, null -> 0 + | null, _ -> -1 + | _, null -> 1 + | (:? IStructuralComparable as x1), yobj -> x1.CompareTo (yobj, comparer) + | _ -> raise (Exception "invalid logic - expected IStructuralEquatable") } + + let structuralComparerValueType<'T> comparer = + { new Comparer<'T>() with + member __.Compare (x,y) = ((box x):?>IStructuralComparable).CompareTo (y, comparer) } + + let unknownComparer<'T> comparer = + { new Comparer<'T>() with + member __.Compare (x,y) = GenericCompare comparer (box x, box y) } + + let getGenericComparison<'T> externalUse er = + match tryGetFSharpComparer externalUse er typeof<'T> with + | :? Comparer<'T> as call -> call + | _ when canUseDefaultComparer er typeof<'T> -> Comparer<'T>.Default + | _ when isArray typeof<'T> && er -> arrayComparer fsComparerER + | _ when isArray typeof<'T> -> arrayComparer fsComparerPER + | _ when isValueTypeStructuralComparable typeof<'T> && er -> structuralComparerValueType fsComparerER + | _ when isValueTypeStructuralComparable typeof<'T> -> structuralComparerValueType fsComparerPER + | _ when isStructuralComparable typeof<'T> && er -> structuralComparer fsComparerER + | _ when isStructuralComparable typeof<'T> -> structuralComparer fsComparerPER + | _ when er -> unknownComparer fsComparerER + | _ -> unknownComparer fsComparerPER + + [] + type FSharpComparer_ER<'T> private () = + static let comparer = getGenericComparison<'T> true true + static member Comparer = comparer + + [] + type FSharpComparer_InternalUse_ER<'T> private () = + static let comparer = getGenericComparison<'T> false true + static member Comparer = comparer + + [] + type FSharpComparer_PER<'T> private () = + static let comparer = getGenericComparison<'T> true false + static member Comparer = comparer + + [] + type FSharpComparer_InternalUse_PER<'T> private () = + static let comparer = getGenericComparison<'T> false false + static member Comparer = comparer + /// Compare two values of the same generic type, using "comp". // // "comp" is assumed to be either fsComparerPER or fsComparerER (and hence 'Compare' is implemented via 'GenericCompare'). @@ -1157,7 +1321,12 @@ namespace Microsoft.FSharp.Core // NOTE: the compiler optimizer is aware of this function and devirtualizes in the // cases where it is known how a particular type implements generic comparison. let GenericComparisonWithComparerIntrinsic<'T> (comp:System.Collections.IComparer) (x:'T) (y:'T) : int = - comp.Compare(box x, box y) + if obj.ReferenceEquals (comp, fsComparerER) then + FSharpComparer_InternalUse_ER.Comparer.Compare (x, y) + elif obj.ReferenceEquals (comp, fsComparerPER) then + FSharpComparer_InternalUse_PER.Comparer.Compare (x, y) + else + comp.Compare (box x, box y) /// Compare two values of the same generic type, in either PER or ER mode, but include static optimizations /// for various well-known cases. @@ -1193,52 +1362,45 @@ namespace Microsoft.FSharp.Core System.String.CompareOrdinal((# "" x : string #) ,(# "" y : string #)) when 'T : decimal = System.Decimal.Compare((# "" x:decimal #), (# "" y:decimal #)) - /// Generic comparison. Implements ER mode (where "0" is returned when NaNs are compared) // // The compiler optimizer is aware of this function (see use of generic_comparison_inner_vref in opt.fs) // and devirtualizes calls to it based on "T". let GenericComparisonIntrinsic<'T> (x:'T) (y:'T) : int = - GenericComparisonWithComparerIntrinsic (fsComparerER :> IComparer) x y - + FSharpComparer_ER.Comparer.Compare (x, y) /// Generic less-than. Uses comparison implementation in PER mode but catches /// the local exception that is thrown when NaN's are compared. let GenericLessThanIntrinsic (x:'T) (y:'T) = try - (# "clt" (GenericComparisonWithComparerIntrinsic fsComparerPER x y) 0 : bool #) + (# "clt" (FSharpComparer_PER.Comparer.Compare (x, y)) 0 : bool #) with | e when System.Runtime.CompilerServices.RuntimeHelpers.Equals(e, NaNException) -> false - /// Generic greater-than. Uses comparison implementation in PER mode but catches /// the local exception that is thrown when NaN's are compared. let GenericGreaterThanIntrinsic (x:'T) (y:'T) = try - (# "cgt" (GenericComparisonWithComparerIntrinsic fsComparerPER x y) 0 : bool #) + (# "cgt" (FSharpComparer_PER.Comparer.Compare (x, y)) 0 : bool #) with | e when System.Runtime.CompilerServices.RuntimeHelpers.Equals(e, NaNException) -> false - /// Generic greater-than-or-equal. Uses comparison implementation in PER mode but catches /// the local exception that is thrown when NaN's are compared. let GenericGreaterOrEqualIntrinsic (x:'T) (y:'T) = try - (# "cgt" (GenericComparisonWithComparerIntrinsic fsComparerPER x y) (-1) : bool #) + (# "cgt" (FSharpComparer_PER.Comparer.Compare (x, y)) (-1) : bool #) with | e when System.Runtime.CompilerServices.RuntimeHelpers.Equals(e, NaNException) -> false - - /// Generic less-than-or-equal. Uses comparison implementation in PER mode but catches /// the local exception that is thrown when NaN's are compared. let GenericLessOrEqualIntrinsic (x:'T) (y:'T) = try - (# "clt" (GenericComparisonWithComparerIntrinsic fsComparerPER x y) 1 : bool #) + (# "clt" (FSharpComparer_PER.Comparer.Compare (x, y)) 1 : bool #) with | e when System.Runtime.CompilerServices.RuntimeHelpers.Equals(e, NaNException) -> false - /// Compare two values of the same generic type, in ER mode, with static optimizations /// for known cases. let inline GenericComparisonFast<'T> (x:'T) (y:'T) : int = @@ -1535,7 +1697,6 @@ namespace Microsoft.FSharp.Core let isStructuralEquatable (ty:Type) = typeof.IsAssignableFrom ty let isValueTypeStructuralEquatable (ty:Type) = isStructuralEquatable ty && ty.IsValueType - let isArray (ty:Type) = ty.IsArray || (typeof.IsAssignableFrom ty) let canUseDefaultEqualityComparer er (rootType:Type) = let processed = System.Collections.Generic.HashSet () @@ -1844,7 +2005,6 @@ namespace Microsoft.FSharp.Core /// Fill in the implementation of UnlimitedHasherER type UnlimitedHasherER with - interface System.Collections.IEqualityComparer with override iec.Equals(x:obj,y:obj) = GenericEqualityObj true iec (x,y) override iec.GetHashCode(x:obj) = GenericHashParamObj iec x @@ -2190,93 +2350,9 @@ namespace Microsoft.FSharp.Core let inline MakeGenericComparer<'T>() = { new System.Collections.Generic.IComparer<'T> with member __.Compare(x,y) = GenericComparison x y } - - let CharComparer = MakeGenericComparer() - let StringComparer = MakeGenericComparer() - let SByteComparer = MakeGenericComparer() - let Int16Comparer = MakeGenericComparer() - let Int32Comparer = MakeGenericComparer() - let Int64Comparer = MakeGenericComparer() - let IntPtrComparer = MakeGenericComparer() - let ByteComparer = MakeGenericComparer() - let UInt16Comparer = MakeGenericComparer() - let UInt32Comparer = MakeGenericComparer() - let UInt64Comparer = MakeGenericComparer() - let UIntPtrComparer = MakeGenericComparer() - let FloatComparer = MakeGenericComparer() - let Float32Comparer = MakeGenericComparer() - let DecimalComparer = MakeGenericComparer() - let BoolComparer = MakeGenericComparer() - - /// Use a type-indexed table to ensure we only create a single FastStructuralComparison function - /// for each type - [] - type FastGenericComparerTable<'T>() = - - // The CLI implementation of mscorlib optimizes array sorting - // when the comparer is either null or precisely - // reference-equals to System.Collections.Generic.Comparer<'T>.Default. - // This is an indication that a "fast" array sorting helper can be used. - // - // So, for all the types listed below, we want to pass in a value of "null" for - // the comparer object. Note that F# generic comparison coincides precisely with - // System.Collections.Generic.Comparer<'T>.Default for these types. - // - // A "null" comparer is only valid if the values do not have identity, e.g. integers. - // That is, an unstable sort of the array must be the semantically the - // same as a stable sort of the array. See Array.stableSortInPlace. - // - // REVIEW: in a future version we could extend this to include additional types - static let fCanBeNull : System.Collections.Generic.IComparer<'T> = - match typeof<'T> with - | ty when ty.Equals(typeof) -> unboxPrim (box IntPtrComparer) - | ty when ty.Equals(typeof) -> unboxPrim (box UIntPtrComparer) - | ty when ty.Equals(typeof) -> null - | ty when ty.Equals(typeof) -> null - | ty when ty.Equals(typeof) -> null - | ty when ty.Equals(typeof) -> null - | ty when ty.Equals(typeof) -> null - | ty when ty.Equals(typeof) -> null - | ty when ty.Equals(typeof) -> null - | ty when ty.Equals(typeof) -> null - | ty when ty.Equals(typeof) -> null - | ty when ty.Equals(typeof) -> null - | ty when ty.Equals(typeof) -> null - | ty when ty.Equals(typeof) -> null - | ty when ty.Equals(typeof) -> unboxPrim (box StringComparer) - | ty when ty.Equals(typeof) -> null - | _ -> MakeGenericComparer<'T>() - - static let f : System.Collections.Generic.IComparer<'T> = - match typeof<'T> with - | ty when ty.Equals(typeof) -> unboxPrim (box ByteComparer) - | ty when ty.Equals(typeof) -> unboxPrim (box CharComparer) - | ty when ty.Equals(typeof) -> unboxPrim (box SByteComparer) - | ty when ty.Equals(typeof) -> unboxPrim (box Int16Comparer) - | ty when ty.Equals(typeof) -> unboxPrim (box Int32Comparer) - | ty when ty.Equals(typeof) -> unboxPrim (box Int64Comparer) - | ty when ty.Equals(typeof) -> unboxPrim (box IntPtrComparer) - | ty when ty.Equals(typeof) -> unboxPrim (box UInt16Comparer) - | ty when ty.Equals(typeof) -> unboxPrim (box UInt32Comparer) - | ty when ty.Equals(typeof) -> unboxPrim (box UInt64Comparer) - | ty when ty.Equals(typeof) -> unboxPrim (box UIntPtrComparer) - | ty when ty.Equals(typeof) -> unboxPrim (box FloatComparer) - | ty when ty.Equals(typeof) -> unboxPrim (box Float32Comparer) - | ty when ty.Equals(typeof) -> unboxPrim (box DecimalComparer) - | ty when ty.Equals(typeof) -> unboxPrim (box StringComparer) - | ty when ty.Equals(typeof) -> unboxPrim (box BoolComparer) - | _ -> - // Review: There are situations where we should be able - // to return System.Collections.Generic.Comparer<'T>.Default here. - // For example, for any value type. - MakeGenericComparer<'T>() - - static member Value : System.Collections.Generic.IComparer<'T> = f - - static member ValueCanBeNullIfDefaultSemantics : System.Collections.Generic.IComparer<'T> = fCanBeNull - let FastGenericComparerFromTable<'T> = - FastGenericComparerTable<'T>.Value + let FastGenericComparerFromTable<'T> : IComparer<'T> = + HashCompare.FSharpComparer_ER<'T>.Comparer :> IComparer<'T> let inline FastGenericComparer<'T> = // This gets used is 'T can't be resolved to anything interesting @@ -2307,7 +2383,8 @@ namespace Microsoft.FSharp.Core // which are then optimized for the particular nominal type involved. when 'T : 'T = MakeGenericComparer<'T>() - let FastGenericComparerCanBeNull<'T> = FastGenericComparerTable<'T>.ValueCanBeNullIfDefaultSemantics + let FastGenericComparerInternal<'T> : Comparer<'T> = + HashCompare.FSharpComparer_InternalUse_ER<'T>.Comparer //------------------------------------------------------------------------- // LanguagePrimitives: ENUMS diff --git a/src/fsharp/FSharp.Core/prim-types.fsi b/src/fsharp/FSharp.Core/prim-types.fsi index 52b2139725d..1cd2364a345 100644 --- a/src/fsharp/FSharp.Core/prim-types.fsi +++ b/src/fsharp/FSharp.Core/prim-types.fsi @@ -952,7 +952,7 @@ namespace Microsoft.FSharp.Core val inline FastGenericComparer<'T> : System.Collections.Generic.IComparer<'T> when 'T : comparison /// Make an F# comparer object for the given type, where it can be null if System.Collections.Generic.Comparer<'T>.Default - val internal FastGenericComparerCanBeNull<'T> : System.Collections.Generic.IComparer<'T> when 'T : comparison + val internal FastGenericComparerInternal<'T> : System.Collections.Generic.Comparer<'T> when 'T : comparison /// Make an F# hash/equality object for the given type val inline FastGenericEqualityComparer<'T> : System.Collections.Generic.IEqualityComparer<'T> when 'T : equality diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core/ComparersRegression.fs b/tests/FSharp.Core.UnitTests/FSharp.Core/ComparersRegression.fs index 4333e5316af..b9aa3b5a290 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core/ComparersRegression.fs +++ b/tests/FSharp.Core.UnitTests/FSharp.Core/ComparersRegression.fs @@ -5183,41 +5183,47 @@ type GeneratedTestSuite () = [] member __.``SBytes.Collection.ArrayArray C.I.compare``() = validate (SBytes.Collection.ArrayArray) C.I.compare [| - 0;1;-1;1;1;-1;-1;-1;-1;-1;-1;0;-1;1;1;-1;-1;-1;-1;-1;1;1;0;1;1;-1;-1;-1;-1;-1;-1;-1;-1;0;-1;-1;-1;-1;-1;-1; - -1;-1;-1;1;0;-1;-1;-1;-1;-1;1;1;1;1;1;0;1;-1;1;1;1;1;1;1;1;-1;0;-1;1;1;1;1;1;1;1;1;1;0;1;1; - 1;1;1;1;1;-1;-1;-1;0;-1;1;1;1;1;1;-1;-1;-1;1;0 - |] + 0;-255;-127;-128;-129;-1;-1;-1;-1;-1;255;0;128;127;126;-1;-1; + -1;-1;-1;127;-128;0;-1;-2;-1;-1;-1;-1;-1;128;-127;1;0;-1;-1; + -1;-1;-1;-1;129;-126;2;1;0;-1;-1;-1;-1;-1;1;1;1;1;1;0;-255; + -127;-128;-129;1;1;1;1;1;255;0;128;127;126;1;1;1;1;1;127; + -128;0;-1;-2;1;1;1;1;1;128;-127;1;0;-1;1;1;1;1;1;129;-126; + 2;1;0|] [] member __.``SBytes.Collection.ArrayArray C.I.less_than``() = validate (SBytes.Collection.ArrayArray) C.I.less_than [| - 0;0;1;0;0;1;1;1;1;1;1;0;1;0;0;1;1;1;1;1;0;0;0;0;0;1;1;1;1;1;1;1;1;0;1;1;1;1;1;1; - 1;1;1;0;0;1;1;1;1;1;0;0;0;0;0;0;0;1;0;0;0;0;0;0;0;1;0;1;0;0;0;0;0;0;0;0;0;0;0;0; - 0;0;0;0;0;1;1;1;0;1;0;0;0;0;0;1;1;1;0;0 + 0;1;1;1;1;1;1;1;1;1;0;0;0;0;0;1;1;1;1;1;0;1;0;1;1;1; + 1;1;1;1;0;1;0;0;1;1;1;1;1;1;0;1;0;0;0;1;1;1;1;1;0;0; + 0;0;0;0;1;1;1;1;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;1;0; + 1;1;0;0;0;0;0;0;1;0;0;1;0;0;0;0;0;0;1;0;0;0 |] [] member __.``SBytes.Collection.ArrayArray C.I.less_or_equal``() = validate (SBytes.Collection.ArrayArray) C.I.less_or_equal [| - 1;0;1;0;0;1;1;1;1;1;1;1;1;0;0;1;1;1;1;1;0;0;1;0;0;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1; - 1;1;1;0;1;1;1;1;1;1;0;0;0;0;0;1;0;1;0;0;0;0;0;0;0;1;1;1;0;0;0;0;0;0;0;0;0;1;0;0; - 0;0;0;0;0;1;1;1;1;1;0;0;0;0;0;1;1;1;0;1 + 1;1;1;1;1;1;1;1;1;1;0;1;0;0;0;1;1;1;1;1;0;1;1;1;1;1; + 1;1;1;1;0;1;0;1;1;1;1;1;1;1;0;1;0;0;1;1;1;1;1;1;0;0; + 0;0;0;1;1;1;1;1;0;0;0;0;0;0;1;0;0;0;0;0;0;0;0;0;1;1; + 1;1;0;0;0;0;0;0;1;0;1;1;0;0;0;0;0;0;1;0;0;1 |] [] member __.``SBytes.Collection.ArrayArray C.I.greater_than``() = validate (SBytes.Collection.ArrayArray) C.I.greater_than [| - 0;1;0;1;1;0;0;0;0;0;0;0;0;1;1;0;0;0;0;0;1;1;0;1;1;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0; - 0;0;0;1;0;0;0;0;0;0;1;1;1;1;1;0;1;0;1;1;1;1;1;1;1;0;0;0;1;1;1;1;1;1;1;1;1;0;1;1; - 1;1;1;1;1;0;0;0;0;0;1;1;1;1;1;0;0;0;1;0 + 0;0;0;0;0;0;0;0;0;0;1;0;1;1;1;0;0;0;0;0;1;0;0;0;0;0; + 0;0;0;0;1;0;1;0;0;0;0;0;0;0;1;0;1;1;0;0;0;0;0;0;1;1; + 1;1;1;0;0;0;0;0;1;1;1;1;1;1;0;1;1;1;1;1;1;1;1;1;0;0; + 0;0;1;1;1;1;1;1;0;1;0;0;1;1;1;1;1;1;0;1;1;0 |] [] member __.``SBytes.Collection.ArrayArray C.I.greater_or_equal``() = validate (SBytes.Collection.ArrayArray) C.I.greater_or_equal [| - 1;1;0;1;1;0;0;0;0;0;0;1;0;1;1;0;0;0;0;0;1;1;1;1;1;0;0;0;0;0;0;0;0;1;0;0;0;0;0;0; - 0;0;0;1;1;0;0;0;0;0;1;1;1;1;1;1;1;0;1;1;1;1;1;1;1;0;1;0;1;1;1;1;1;1;1;1;1;1;1;1; - 1;1;1;1;1;0;0;0;1;0;1;1;1;1;1;0;0;0;1;1 + 1;0;0;0;0;0;0;0;0;0;1;1;1;1;1;0;0;0;0;0;1;0;1;0;0;0; + 0;0;0;0;1;0;1;1;0;0;0;0;0;0;1;0;1;1;1;0;0;0;0;0;1;1; + 1;1;1;1;0;0;0;0;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;0;1; + 0;0;1;1;1;1;1;1;0;1;1;0;1;1;1;1;1;1;0;1;1;1 |] [] @@ -5247,41 +5253,48 @@ type GeneratedTestSuite () = [] member __.``SBytes.Collection.ArrayArray C.N.compare``() = validate (SBytes.Collection.ArrayArray) C.N.compare [| - 0;1;-1;1;1;-1;-1;-1;-1;-1;-1;0;-1;1;1;-1;-1;-1;-1;-1;1;1;0;1;1;-1;-1;-1;-1;-1;-1;-1;-1;0;-1;-1;-1;-1;-1;-1; - -1;-1;-1;1;0;-1;-1;-1;-1;-1;1;1;1;1;1;0;1;-1;1;1;1;1;1;1;1;-1;0;-1;1;1;1;1;1;1;1;1;1;0;1;1; - 1;1;1;1;1;-1;-1;-1;0;-1;1;1;1;1;1;-1;-1;-1;1;0 + 0;-255;-127;-128;-129;-1;-1;-1;-1;-1;255;0;128;127;126;-1;-1; + -1;-1;-1;127;-128;0;-1;-2;-1;-1;-1;-1;-1;128;-127;1;0;-1;-1; + -1;-1;-1;-1;129;-126;2;1;0;-1;-1;-1;-1;-1;1;1;1;1;1;0;-255; + -127;-128;-129;1;1;1;1;1;255;0;128;127;126;1;1;1;1;1;127; + -128;0;-1;-2;1;1;1;1;1;128;-127;1;0;-1;1;1;1;1;1;129;-126; + 2;1;0 |] [] member __.``SBytes.Collection.ArrayArray C.N.less_than``() = validate (SBytes.Collection.ArrayArray) C.N.less_than [| - 0;0;1;0;0;1;1;1;1;1;1;0;1;0;0;1;1;1;1;1;0;0;0;0;0;1;1;1;1;1;1;1;1;0;1;1;1;1;1;1; - 1;1;1;0;0;1;1;1;1;1;0;0;0;0;0;0;0;1;0;0;0;0;0;0;0;1;0;1;0;0;0;0;0;0;0;0;0;0;0;0; - 0;0;0;0;0;1;1;1;0;1;0;0;0;0;0;1;1;1;0;0 + 0;1;1;1;1;1;1;1;1;1;0;0;0;0;0;1;1;1;1;1;0;1;0;1;1;1; + 1;1;1;1;0;1;0;0;1;1;1;1;1;1;0;1;0;0;0;1;1;1;1;1;0;0; + 0;0;0;0;1;1;1;1;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;1;0; + 1;1;0;0;0;0;0;0;1;0;0;1;0;0;0;0;0;0;1;0;0;0 |] [] member __.``SBytes.Collection.ArrayArray C.N.less_or_equal``() = validate (SBytes.Collection.ArrayArray) C.N.less_or_equal [| - 1;0;1;0;0;1;1;1;1;1;1;1;1;0;0;1;1;1;1;1;0;0;1;0;0;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1; - 1;1;1;0;1;1;1;1;1;1;0;0;0;0;0;1;0;1;0;0;0;0;0;0;0;1;1;1;0;0;0;0;0;0;0;0;0;1;0;0; - 0;0;0;0;0;1;1;1;1;1;0;0;0;0;0;1;1;1;0;1 + 1;1;1;1;1;1;1;1;1;1;0;1;0;0;0;1;1;1;1;1;0;1;1;1;1;1; + 1;1;1;1;0;1;0;1;1;1;1;1;1;1;0;1;0;0;1;1;1;1;1;1;0;0; + 0;0;0;1;1;1;1;1;0;0;0;0;0;0;1;0;0;0;0;0;0;0;0;0;1;1; + 1;1;0;0;0;0;0;0;1;0;1;1;0;0;0;0;0;0;1;0;0;1 |] [] member __.``SBytes.Collection.ArrayArray C.N.greater_than``() = validate (SBytes.Collection.ArrayArray) C.N.greater_than [| - 0;1;0;1;1;0;0;0;0;0;0;0;0;1;1;0;0;0;0;0;1;1;0;1;1;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0; - 0;0;0;1;0;0;0;0;0;0;1;1;1;1;1;0;1;0;1;1;1;1;1;1;1;0;0;0;1;1;1;1;1;1;1;1;1;0;1;1; - 1;1;1;1;1;0;0;0;0;0;1;1;1;1;1;0;0;0;1;0 + 0;0;0;0;0;0;0;0;0;0;1;0;1;1;1;0;0;0;0;0;1;0;0;0;0;0; + 0;0;0;0;1;0;1;0;0;0;0;0;0;0;1;0;1;1;0;0;0;0;0;0;1;1; + 1;1;1;0;0;0;0;0;1;1;1;1;1;1;0;1;1;1;1;1;1;1;1;1;0;0; + 0;0;1;1;1;1;1;1;0;1;0;0;1;1;1;1;1;1;0;1;1;0 |] [] member __.``SBytes.Collection.ArrayArray C.N.greater_or_equal``() = validate (SBytes.Collection.ArrayArray) C.N.greater_or_equal [| - 1;1;0;1;1;0;0;0;0;0;0;1;0;1;1;0;0;0;0;0;1;1;1;1;1;0;0;0;0;0;0;0;0;1;0;0;0;0;0;0; - 0;0;0;1;1;0;0;0;0;0;1;1;1;1;1;1;1;0;1;1;1;1;1;1;1;0;1;0;1;1;1;1;1;1;1;1;1;1;1;1; - 1;1;1;1;1;0;0;0;1;0;1;1;1;1;1;0;0;0;1;1 + 1;0;0;0;0;0;0;0;0;0;1;1;1;1;1;0;0;0;0;0;1;0;1;0;0;0; + 0;0;0;0;1;0;1;1;0;0;0;0;0;0;1;0;1;1;1;0;0;0;0;0;1;1; + 1;1;1;1;0;0;0;0;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;1;0;1; + 0;0;1;1;1;1;1;1;0;1;1;0;1;1;1;1;1;1;0;1;1;1 |] [] From 9dc65cc20090b5fd0964e7b8866c01e4b3c444d5 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Mon, 2 Jul 2018 19:13:47 +1000 Subject: [PATCH 33/92] Moved throwing exceptions closer --- src/fsharp/FSharp.Core/prim-types.fs | 42 ++++++++++++---------------- 1 file changed, 18 insertions(+), 24 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index b203689ce40..0f9ce795ab8 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -1205,34 +1205,33 @@ namespace Microsoft.FSharp.Core | _, false, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = - if (# "clt" x y : bool #) then (-1) - elif (# "cgt" x y : bool #) then (1) - elif (# "ceq" x y : bool #) then (0) - else (fsComparerPER:>IComparer).Compare (box x, box y) } + if (# "clt" x y : bool #) then -1 + elif (# "cgt" x y : bool #) then 1 + elif (# "ceq" x y : bool #) then 0 + else raise NaNException } | _, false, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = - if (# "clt" x y : bool #) then (-1) - elif (# "cgt" x y : bool #) then (1) - elif (# "ceq" x y : bool #) then (0) - else (fsComparerPER:>IComparer).Compare (box x, box y) } + if (# "clt" x y : bool #) then -1 + elif (# "cgt" x y : bool #) then 1 + elif (# "ceq" x y : bool #) then 0 + else raise NaNException } | _, true, ty when ty.Equals typeof -> box Comparer.Default | _, true, ty when ty.Equals typeof -> box Comparer.Default // the implemention of Comparer.Default returns a current culture specific comparer - | _, _, ty when ty.Equals typeof -> - box { new Comparer() with - member __.Compare (x,y) = System.String.CompareOrdinal(x, y) } + | _, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = System.String.CompareOrdinal(x, y) } + + | _, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt.un" x y : bool #) then -1 else (# "cgt.un" x y : int #) } + | _, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt" x y : bool #) then -1 else (# "cgt" x y : int #) } // the implemention of the following comparers with Comparer<'T>.Default returns // (int x)-(int y) rather than (sign (int x)-(int y)) - | true, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt.un" x y : bool #) then (-1) else (# "cgt.un" x y : int #) } - | true, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt.un" x y : bool #) then (-1) else (# "cgt.un" x y : int #) } - | true, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt.un" x y : bool #) then (-1) else (# "cgt.un" x y : int #) } - | _, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt.un" x y : bool #) then (-1) else (# "cgt.un" x y : int #) } - | true, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt" x y : bool #) then (-1) else (# "cgt" x y : int #) } - | true, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt" x y : bool #) then (-1) else (# "cgt" x y : int #) } - | _, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt" x y : bool #) then (-1) else (# "cgt" x y : int #) } + | true, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt.un" x y : bool #) then -1 else (# "cgt.un" x y : int #) } + | true, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt.un" x y : bool #) then -1 else (# "cgt.un" x y : int #) } + | true, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt.un" x y : bool #) then -1 else (# "cgt.un" x y : int #) } + | true, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt" x y : bool #) then -1 else (# "cgt" x y : int #) } + | true, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt" x y : bool #) then -1 else (# "cgt" x y : int #) } | _ -> null @@ -1306,11 +1305,6 @@ namespace Microsoft.FSharp.Core [] type FSharpComparer_PER<'T> private () = - static let comparer = getGenericComparison<'T> true false - static member Comparer = comparer - - [] - type FSharpComparer_InternalUse_PER<'T> private () = static let comparer = getGenericComparison<'T> false false static member Comparer = comparer @@ -1324,7 +1318,7 @@ namespace Microsoft.FSharp.Core if obj.ReferenceEquals (comp, fsComparerER) then FSharpComparer_InternalUse_ER.Comparer.Compare (x, y) elif obj.ReferenceEquals (comp, fsComparerPER) then - FSharpComparer_InternalUse_PER.Comparer.Compare (x, y) + FSharpComparer_PER.Comparer.Compare (x, y) else comp.Compare (box x, box y) From c17904232e80d05b6280748d31335c61510dc2e5 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Mon, 2 Jul 2018 20:09:55 +1000 Subject: [PATCH 34/92] Added comparison usage, so could remove exception catching logic when unnecessary --- src/fsharp/FSharp.Core/prim-types.fs | 156 ++++++++++++++++++--------- 1 file changed, 103 insertions(+), 53 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index 0f9ce795ab8..80b77f37281 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -1200,38 +1200,73 @@ namespace Microsoft.FSharp.Core checkType 0 [|rootType|] - let tryGetFSharpComparer (externalUse:bool) (er:bool) (ty:Type) : obj = - match externalUse, er, ty with - | _, false, ty when ty.Equals typeof -> + type ComparisonUsage = + | NormalUsage = 0 + | LessThanUsage = 1 + | GreaterThanUsage = 2 + + let tryGetFSharpComparer (usage:ComparisonUsage) (externalUse:bool) (er:bool) (ty:Type) : obj = + match usage, externalUse, er, ty with + | ComparisonUsage.NormalUsage, _, false, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt" x y : bool #) then -1 elif (# "cgt" x y : bool #) then 1 elif (# "ceq" x y : bool #) then 0 else raise NaNException } - | _, false, ty when ty.Equals typeof -> + | ComparisonUsage.LessThanUsage, _, false, ty when ty.Equals typeof -> + box { new Comparer() with + member __.Compare (x,y) = + if (# "clt" x y : bool #) then -1 + elif (# "cgt" x y : bool #) then 1 + elif (# "ceq" x y : bool #) then 0 + else 1 } + | ComparisonUsage.GreaterThanUsage, _, false, ty when ty.Equals typeof -> + System.Console.WriteLine "ComparisonUsage.GreaterThanUsage" + box { new Comparer() with + member __.Compare (x,y) = + if (# "clt" x y : bool #) then -1 + elif (# "cgt" x y : bool #) then 1 + elif (# "ceq" x y : bool #) then 0 + else -1 } + | ComparisonUsage.NormalUsage, _, false, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt" x y : bool #) then -1 elif (# "cgt" x y : bool #) then 1 elif (# "ceq" x y : bool #) then 0 else raise NaNException } - | _, true, ty when ty.Equals typeof -> box Comparer.Default - | _, true, ty when ty.Equals typeof -> box Comparer.Default + | ComparisonUsage.LessThanUsage, _, false, ty when ty.Equals typeof -> + box { new Comparer() with + member __.Compare (x,y) = + if (# "clt" x y : bool #) then -1 + elif (# "cgt" x y : bool #) then 1 + elif (# "ceq" x y : bool #) then 0 + else 1 } + | ComparisonUsage.GreaterThanUsage, _, false, ty when ty.Equals typeof -> + box { new Comparer() with + member __.Compare (x,y) = + if (# "clt" x y : bool #) then -1 + elif (# "cgt" x y : bool #) then 1 + elif (# "ceq" x y : bool #) then 0 + else -1 } + + | _, _, true, ty when ty.Equals typeof -> box Comparer.Default + | _, _, true, ty when ty.Equals typeof -> box Comparer.Default // the implemention of Comparer.Default returns a current culture specific comparer - | _, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = System.String.CompareOrdinal(x, y) } + | _, _, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = System.String.CompareOrdinal(x, y) } - | _, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt.un" x y : bool #) then -1 else (# "cgt.un" x y : int #) } - | _, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt" x y : bool #) then -1 else (# "cgt" x y : int #) } + | _, _, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt.un" x y : bool #) then -1 else (# "cgt.un" x y : int #) } + | _, _, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt" x y : bool #) then -1 else (# "cgt" x y : int #) } // the implemention of the following comparers with Comparer<'T>.Default returns // (int x)-(int y) rather than (sign (int x)-(int y)) - | true, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt.un" x y : bool #) then -1 else (# "cgt.un" x y : int #) } - | true, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt.un" x y : bool #) then -1 else (# "cgt.un" x y : int #) } - | true, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt.un" x y : bool #) then -1 else (# "cgt.un" x y : int #) } - | true, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt" x y : bool #) then -1 else (# "cgt" x y : int #) } - | true, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt" x y : bool #) then -1 else (# "cgt" x y : int #) } + | _, true, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt.un" x y : bool #) then -1 else (# "cgt.un" x y : int #) } + | _, true, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt.un" x y : bool #) then -1 else (# "cgt.un" x y : int #) } + | _, true, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt.un" x y : bool #) then -1 else (# "cgt.un" x y : int #) } + | _, true, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt" x y : bool #) then -1 else (# "cgt" x y : int #) } + | _, true, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt" x y : bool #) then -1 else (# "cgt" x y : int #) } | _ -> null @@ -1280,32 +1315,63 @@ namespace Microsoft.FSharp.Core { new Comparer<'T>() with member __.Compare (x,y) = GenericCompare comparer (box x, box y) } - let getGenericComparison<'T> externalUse er = - match tryGetFSharpComparer externalUse er typeof<'T> with - | :? Comparer<'T> as call -> call - | _ when canUseDefaultComparer er typeof<'T> -> Comparer<'T>.Default - | _ when isArray typeof<'T> && er -> arrayComparer fsComparerER - | _ when isArray typeof<'T> -> arrayComparer fsComparerPER - | _ when isValueTypeStructuralComparable typeof<'T> && er -> structuralComparerValueType fsComparerER - | _ when isValueTypeStructuralComparable typeof<'T> -> structuralComparerValueType fsComparerPER - | _ when isStructuralComparable typeof<'T> && er -> structuralComparer fsComparerER - | _ when isStructuralComparable typeof<'T> -> structuralComparer fsComparerPER - | _ when er -> unknownComparer fsComparerER - | _ -> unknownComparer fsComparerPER + let getGenericComparison<'T> usage externalUse er = + match tryGetFSharpComparer usage externalUse er typeof<'T> with + | :? Comparer<'T> as comparer -> comparer + | _ when canUseDefaultComparer er typeof<'T> -> Comparer<'T>.Default + | _ -> + if er then + if isArray typeof<'T> then arrayComparer fsComparerER + elif isValueTypeStructuralComparable typeof<'T> then structuralComparerValueType fsComparerER + elif isStructuralComparable typeof<'T> then structuralComparer fsComparerER + else unknownComparer fsComparerER + else + let comparer = + if isArray typeof<'T> then arrayComparer fsComparerPER + elif isValueTypeStructuralComparable typeof<'T> then structuralComparerValueType fsComparerPER + elif isStructuralComparable typeof<'T> then structuralComparer fsComparerPER + else unknownComparer fsComparerPER + + match usage with + | ComparisonUsage.LessThanUsage -> + { new Comparer<'T>() with + member __.Compare (x,y) = + try + comparer.Compare (x,y) + with + e when System.Runtime.CompilerServices.RuntimeHelpers.Equals(e, NaNException) -> 1 } + | ComparisonUsage.GreaterThanUsage -> + { new Comparer<'T>() with + member __.Compare (x,y) = + try + comparer.Compare (x,y) + with + e when System.Runtime.CompilerServices.RuntimeHelpers.Equals(e, NaNException) -> -1 } + | _ -> comparer [] type FSharpComparer_ER<'T> private () = - static let comparer = getGenericComparison<'T> true true + static let comparer = getGenericComparison<'T> ComparisonUsage.NormalUsage true true static member Comparer = comparer [] type FSharpComparer_InternalUse_ER<'T> private () = - static let comparer = getGenericComparison<'T> false true + static let comparer = getGenericComparison<'T> ComparisonUsage.NormalUsage false true static member Comparer = comparer [] type FSharpComparer_PER<'T> private () = - static let comparer = getGenericComparison<'T> false false + static let comparer = getGenericComparison<'T> ComparisonUsage.NormalUsage false false + static member Comparer = comparer + + [] + type FSharpComparer_ForLessThanComparison<'T> private () = + static let comparer = getGenericComparison<'T> ComparisonUsage.LessThanUsage false false + static member Comparer = comparer + + [] + type FSharpComparer_ForGreaterThanComparison<'T> private () = + static let comparer = getGenericComparison<'T> ComparisonUsage.GreaterThanUsage false false static member Comparer = comparer /// Compare two values of the same generic type, using "comp". @@ -1363,37 +1429,21 @@ namespace Microsoft.FSharp.Core let GenericComparisonIntrinsic<'T> (x:'T) (y:'T) : int = FSharpComparer_ER.Comparer.Compare (x, y) - /// Generic less-than. Uses comparison implementation in PER mode but catches - /// the local exception that is thrown when NaN's are compared. + /// Generic less-than. let GenericLessThanIntrinsic (x:'T) (y:'T) = - try - (# "clt" (FSharpComparer_PER.Comparer.Compare (x, y)) 0 : bool #) - with - | e when System.Runtime.CompilerServices.RuntimeHelpers.Equals(e, NaNException) -> false + (# "clt" (FSharpComparer_ForLessThanComparison.Comparer.Compare (x, y)) 0 : bool #) - /// Generic greater-than. Uses comparison implementation in PER mode but catches - /// the local exception that is thrown when NaN's are compared. + /// Generic greater-than. let GenericGreaterThanIntrinsic (x:'T) (y:'T) = - try - (# "cgt" (FSharpComparer_PER.Comparer.Compare (x, y)) 0 : bool #) - with - | e when System.Runtime.CompilerServices.RuntimeHelpers.Equals(e, NaNException) -> false + (# "cgt" (FSharpComparer_ForGreaterThanComparison.Comparer.Compare (x, y)) 0 : bool #) - /// Generic greater-than-or-equal. Uses comparison implementation in PER mode but catches - /// the local exception that is thrown when NaN's are compared. + /// Generic greater-than-or-equal. let GenericGreaterOrEqualIntrinsic (x:'T) (y:'T) = - try - (# "cgt" (FSharpComparer_PER.Comparer.Compare (x, y)) (-1) : bool #) - with - | e when System.Runtime.CompilerServices.RuntimeHelpers.Equals(e, NaNException) -> false + (# "cgt" (FSharpComparer_ForGreaterThanComparison.Comparer.Compare (x, y)) -1 : bool #) - /// Generic less-than-or-equal. Uses comparison implementation in PER mode but catches - /// the local exception that is thrown when NaN's are compared. + /// Generic less-than-or-equal. let GenericLessOrEqualIntrinsic (x:'T) (y:'T) = - try - (# "clt" (FSharpComparer_PER.Comparer.Compare (x, y)) 1 : bool #) - with - | e when System.Runtime.CompilerServices.RuntimeHelpers.Equals(e, NaNException) -> false + (# "clt" (FSharpComparer_ForLessThanComparison.Comparer.Compare (x, y)) 1 : bool #) /// Compare two values of the same generic type, in ER mode, with static optimizations /// for known cases. From 553efd9b8ae0760cfccf2fb6b7aa0ba291761446 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Tue, 3 Jul 2018 16:20:33 +1000 Subject: [PATCH 35/92] Consolidated functions --- src/fsharp/FSharp.Core/prim-types.fs | 178 +++++++++++++-------------- 1 file changed, 86 insertions(+), 92 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index 80b77f37281..77aeeb887c4 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -1201,72 +1201,64 @@ namespace Microsoft.FSharp.Core checkType 0 [|rootType|] type ComparisonUsage = - | NormalUsage = 0 - | LessThanUsage = 1 - | GreaterThanUsage = 2 - - let tryGetFSharpComparer (usage:ComparisonUsage) (externalUse:bool) (er:bool) (ty:Type) : obj = - match usage, externalUse, er, ty with - | ComparisonUsage.NormalUsage, _, false, ty when ty.Equals typeof -> - box { new Comparer() with - member __.Compare (x,y) = - if (# "clt" x y : bool #) then -1 - elif (# "cgt" x y : bool #) then 1 - elif (# "ceq" x y : bool #) then 0 - else raise NaNException } - | ComparisonUsage.LessThanUsage, _, false, ty when ty.Equals typeof -> - box { new Comparer() with - member __.Compare (x,y) = - if (# "clt" x y : bool #) then -1 - elif (# "cgt" x y : bool #) then 1 - elif (# "ceq" x y : bool #) then 0 - else 1 } - | ComparisonUsage.GreaterThanUsage, _, false, ty when ty.Equals typeof -> - System.Console.WriteLine "ComparisonUsage.GreaterThanUsage" - box { new Comparer() with - member __.Compare (x,y) = - if (# "clt" x y : bool #) then -1 - elif (# "cgt" x y : bool #) then 1 - elif (# "ceq" x y : bool #) then 0 - else -1 } - | ComparisonUsage.NormalUsage, _, false, ty when ty.Equals typeof -> - box { new Comparer() with - member __.Compare (x,y) = - if (# "clt" x y : bool #) then -1 - elif (# "cgt" x y : bool #) then 1 - elif (# "ceq" x y : bool #) then 0 - else raise NaNException } - | ComparisonUsage.LessThanUsage, _, false, ty when ty.Equals typeof -> - box { new Comparer() with - member __.Compare (x,y) = - if (# "clt" x y : bool #) then -1 - elif (# "cgt" x y : bool #) then 1 - elif (# "ceq" x y : bool #) then 0 - else 1 } - | ComparisonUsage.GreaterThanUsage, _, false, ty when ty.Equals typeof -> - box { new Comparer() with + | ERUsage = 0 + | PERUsage = 1 + | LessThanUsage = 2 + | GreaterThanUsage = 3 + + [] + let LessThanUsageReturnFalse = 1 + [] + let GreaterThanUsageReturnFalse = -1 + + let inline signedComparer<'T> () = + box { new Comparer<'T>() with + member __.Compare (x,y) = + if (# "clt" x y : bool #) then -1 + else (# "cgt" x y : int #) } + + let inline unsignedComparer<'T> () = + box { new Comparer<'T>() with + member __.Compare (x,y) = + if (# "clt.un" x y : bool #) then -1 + else (# "cgt.un" x y : int #) } + + let inline floatingPointComparer<'T> onNaN = + box { new Comparer<'T>() with + member __.Compare (x,y) = + if (# "clt" x y : bool #) then -1 + elif (# "cgt" x y : bool #) then 1 + elif (# "ceq" x y : bool #) then 0 + else onNaN () } + + let tryGetFSharpComparer (usage:ComparisonUsage) (externalUse:bool) (ty:Type) : obj = + match usage, externalUse, ty with + | ComparisonUsage.ERUsage, _, ty when ty.Equals typeof -> box Comparer.Default + | ComparisonUsage.ERUsage, _, ty when ty.Equals typeof -> box Comparer.Default + + | ComparisonUsage.PERUsage, _, ty when ty.Equals typeof -> floatingPointComparer (fun () -> raise NaNException) + | ComparisonUsage.LessThanUsage, _, ty when ty.Equals typeof -> floatingPointComparer (fun () -> LessThanUsageReturnFalse) + | ComparisonUsage.GreaterThanUsage, _, ty when ty.Equals typeof -> floatingPointComparer (fun () -> GreaterThanUsageReturnFalse) + + | ComparisonUsage.PERUsage, _, ty when ty.Equals typeof -> floatingPointComparer (fun () -> raise NaNException) + | ComparisonUsage.LessThanUsage, _, ty when ty.Equals typeof -> floatingPointComparer (fun () -> LessThanUsageReturnFalse) + | ComparisonUsage.GreaterThanUsage, _, ty when ty.Equals typeof -> floatingPointComparer (fun () -> GreaterThanUsageReturnFalse) + + // the implemention of Comparer.Default returns a current culture specific comparer + | _, _, ty when ty.Equals typeof -> + box { new Comparer() with member __.Compare (x,y) = - if (# "clt" x y : bool #) then -1 - elif (# "cgt" x y : bool #) then 1 - elif (# "ceq" x y : bool #) then 0 - else -1 } + System.String.CompareOrdinal (x, y) } - | _, _, true, ty when ty.Equals typeof -> box Comparer.Default - | _, _, true, ty when ty.Equals typeof -> box Comparer.Default + | _, _, ty when ty.Equals typeof -> unsignedComparer () + | _, _, ty when ty.Equals typeof -> signedComparer () - // the implemention of Comparer.Default returns a current culture specific comparer - | _, _, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = System.String.CompareOrdinal(x, y) } - - | _, _, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt.un" x y : bool #) then -1 else (# "cgt.un" x y : int #) } - | _, _, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt" x y : bool #) then -1 else (# "cgt" x y : int #) } - - // the implemention of the following comparers with Comparer<'T>.Default returns - // (int x)-(int y) rather than (sign (int x)-(int y)) - | _, true, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt.un" x y : bool #) then -1 else (# "cgt.un" x y : int #) } - | _, true, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt.un" x y : bool #) then -1 else (# "cgt.un" x y : int #) } - | _, true, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt.un" x y : bool #) then -1 else (# "cgt.un" x y : int #) } - | _, true, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt" x y : bool #) then -1 else (# "cgt" x y : int #) } - | _, true, _, ty when ty.Equals typeof -> box { new Comparer() with member __.Compare (x,y) = if (# "clt" x y : bool #) then -1 else (# "cgt" x y : int #) } + // these are used as external facing comparers for compatability (they always return -1/0/+1) + | _, true, ty when ty.Equals typeof -> unsignedComparer () + | _, true, ty when ty.Equals typeof -> signedComparer () + | _, true, ty when ty.Equals typeof -> signedComparer () + | _, true, ty when ty.Equals typeof -> unsignedComparer () + | _, true, ty when ty.Equals typeof -> unsignedComparer () | _ -> null @@ -1309,69 +1301,71 @@ namespace Microsoft.FSharp.Core let structuralComparerValueType<'T> comparer = { new Comparer<'T>() with - member __.Compare (x,y) = ((box x):?>IStructuralComparable).CompareTo (y, comparer) } + member __.Compare (x,y) = + ((box x):?>IStructuralComparable).CompareTo (y, comparer) } let unknownComparer<'T> comparer = { new Comparer<'T>() with - member __.Compare (x,y) = GenericCompare comparer (box x, box y) } + member __.Compare (x,y) = + GenericCompare comparer (box x, box y) } + + // this wrapper is used with the comparison operators to cause a false result when a NaNException + // has been thrown somewhere in the tested objects hierarchy + let maybeNaNExceptionComparer<'T> (comparer:Comparer<'T>) valueToCauseFalse = + { new Comparer<'T>() with + member __.Compare (x,y) = + try + comparer.Compare (x,y) + with + e when System.Runtime.CompilerServices.RuntimeHelpers.Equals(e, NaNException) -> valueToCauseFalse } + + let getGenericComparison<'T> usage externalUse = + let er = match usage with ComparisonUsage.ERUsage -> true | _ -> false - let getGenericComparison<'T> usage externalUse er = - match tryGetFSharpComparer usage externalUse er typeof<'T> with + match tryGetFSharpComparer usage externalUse typeof<'T> with | :? Comparer<'T> as comparer -> comparer | _ when canUseDefaultComparer er typeof<'T> -> Comparer<'T>.Default | _ -> if er then - if isArray typeof<'T> then arrayComparer fsComparerER + if isArray typeof<'T> then arrayComparer fsComparerER elif isValueTypeStructuralComparable typeof<'T> then structuralComparerValueType fsComparerER - elif isStructuralComparable typeof<'T> then structuralComparer fsComparerER - else unknownComparer fsComparerER + elif isStructuralComparable typeof<'T> then structuralComparer fsComparerER + else unknownComparer fsComparerER else let comparer = - if isArray typeof<'T> then arrayComparer fsComparerPER + if isArray typeof<'T> then arrayComparer fsComparerPER elif isValueTypeStructuralComparable typeof<'T> then structuralComparerValueType fsComparerPER - elif isStructuralComparable typeof<'T> then structuralComparer fsComparerPER - else unknownComparer fsComparerPER + elif isStructuralComparable typeof<'T> then structuralComparer fsComparerPER + else unknownComparer fsComparerPER match usage with - | ComparisonUsage.LessThanUsage -> - { new Comparer<'T>() with - member __.Compare (x,y) = - try - comparer.Compare (x,y) - with - e when System.Runtime.CompilerServices.RuntimeHelpers.Equals(e, NaNException) -> 1 } - | ComparisonUsage.GreaterThanUsage -> - { new Comparer<'T>() with - member __.Compare (x,y) = - try - comparer.Compare (x,y) - with - e when System.Runtime.CompilerServices.RuntimeHelpers.Equals(e, NaNException) -> -1 } + | ComparisonUsage.LessThanUsage -> maybeNaNExceptionComparer comparer LessThanUsageReturnFalse + | ComparisonUsage.GreaterThanUsage -> maybeNaNExceptionComparer comparer GreaterThanUsageReturnFalse | _ -> comparer [] type FSharpComparer_ER<'T> private () = - static let comparer = getGenericComparison<'T> ComparisonUsage.NormalUsage true true + static let comparer = getGenericComparison<'T> ComparisonUsage.ERUsage true static member Comparer = comparer [] type FSharpComparer_InternalUse_ER<'T> private () = - static let comparer = getGenericComparison<'T> ComparisonUsage.NormalUsage false true + static let comparer = getGenericComparison<'T> ComparisonUsage.ERUsage false static member Comparer = comparer [] type FSharpComparer_PER<'T> private () = - static let comparer = getGenericComparison<'T> ComparisonUsage.NormalUsage false false + static let comparer = getGenericComparison<'T> ComparisonUsage.PERUsage false static member Comparer = comparer [] type FSharpComparer_ForLessThanComparison<'T> private () = - static let comparer = getGenericComparison<'T> ComparisonUsage.LessThanUsage false false + static let comparer = getGenericComparison<'T> ComparisonUsage.LessThanUsage false static member Comparer = comparer [] type FSharpComparer_ForGreaterThanComparison<'T> private () = - static let comparer = getGenericComparison<'T> ComparisonUsage.GreaterThanUsage false false + static let comparer = getGenericComparison<'T> ComparisonUsage.GreaterThanUsage false static member Comparer = comparer /// Compare two values of the same generic type, using "comp". From 76d191fde081d8a8245050a3f53d2d56fd50da86 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Tue, 3 Jul 2018 17:53:57 +1000 Subject: [PATCH 36/92] Consolidated ArrayComparisons and addressed issue #5263 --- src/fsharp/FSharp.Core/prim-types.fs | 53 +++++++++++----------------- 1 file changed, 20 insertions(+), 33 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index 77aeeb887c4..73396ce7081 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -917,6 +917,17 @@ namespace Microsoft.FSharp.Core /// This exception should never be observed by user code. let NaNException = new System.Exception() + let inline ArrayComparison<'T> (f:'T->'T->int) (x:'T[]) (y:'T[]) : int = + let lenx = x.Length + let leny = y.Length + let rec loop c i = + if c <> 0 then Math.Sign c + elif i = lenx then 0 + else loop (f (get x i) (get y i)) (i+1) + loop (lenx-leny) 0 + + let GenericComparisonByteArray (x:byte[]) (y:byte[]) : int = ArrayComparison (fun x y -> (# "conv.i4" x : int32 #)-(# "conv.i4" y : int32 #)) x y + /// Implements generic comparison between two objects. This corresponds to the pseudo-code in the F# /// specification. The treatment of NaNs is governed by "comp". let rec GenericCompare (comp:GenericComparer) (xobj:obj,yobj:obj) = @@ -930,10 +941,13 @@ namespace Microsoft.FSharp.Core // Permit structural comparison on arrays | (:? System.Array as arr1),_ -> match arr1,yobj with - // Fast path - | (:? (obj[]) as arr1), (:? (obj[]) as arr2) -> GenericComparisonObjArrayWithComparer comp arr1 arr2 - // Fast path - | (:? (byte[]) as arr1), (:? (byte[]) as arr2) -> GenericComparisonByteArray arr1 arr2 + | (:? (obj[]) as arr1), (:? (obj[]) as arr2)-> GenericComparisonObjArrayWithComparer comp arr1 arr2 + + // The additional equality check is required here because .net treats byte[] and sbyte[] as cast-compatible + // (but comparison is different) + | (:? (byte[]) as arr1), (:? (byte[]) as arr2) + when typeof.Equals (arr1.GetType ()) && typeof.Equals (arr2.GetType ()) -> GenericComparisonByteArray arr1 arr2 + | _ , (:? System.Array as arr2) -> GenericComparisonArbArrayWithComparer comp arr1 arr2 | _ -> FailGenericComparison xobj // Check for IStructuralComparable @@ -1108,35 +1122,8 @@ namespace Microsoft.FSharp.Core check 0 #endif - /// optimized case: Core implementation of structural comparison on object arrays. - and GenericComparisonObjArrayWithComparer (comp:GenericComparer) (x:obj[]) (y:obj[]) : int = - let lenx = x.Length - let leny = y.Length - let c = intOrder lenx leny - if c <> 0 then c - else - let mutable i = 0 - let mutable res = 0 - while i < lenx do - let c = GenericCompare comp ((get x i), (get y i)) - if c <> 0 then (res <- c; i <- lenx) - else i <- i + 1 - res - - /// optimized case: Core implementation of structural comparison on arrays. - and GenericComparisonByteArray (x:byte[]) (y:byte[]) : int = - let lenx = x.Length - let leny = y.Length - let c = intOrder lenx leny - if c <> 0 then c - else - let mutable i = 0 - let mutable res = 0 - while i < lenx do - let c = byteOrder (get x i) (get y i) - if c <> 0 then (res <- c; i <- lenx) - else i <- i + 1 - res + and GenericComparisonObjArrayWithComparer (comp:GenericComparer) (x:obj[]) (y:obj[]) : int = + ArrayComparison (fun x y -> GenericCompare comp (x, y)) x y type GenericComparer with interface System.Collections.IComparer with From 0f42ffa6f2966872eb83da901e8e05b3df3f6ba6 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Wed, 18 Jul 2018 19:17:34 +1000 Subject: [PATCH 37/92] Fixed bug introduced in #5278 where an unstable sort could be used where a stable one was required --- src/fsharp/FSharp.Core/local.fs | 3 +-- src/fsharp/FSharp.Core/prim-types.fs | 19 +++++++++++++++++++ src/fsharp/FSharp.Core/prim-types.fsi | 3 +++ 3 files changed, 23 insertions(+), 2 deletions(-) diff --git a/src/fsharp/FSharp.Core/local.fs b/src/fsharp/FSharp.Core/local.fs index 971c25d87d9..56d6a20cbdd 100644 --- a/src/fsharp/FSharp.Core/local.fs +++ b/src/fsharp/FSharp.Core/local.fs @@ -1141,8 +1141,7 @@ module internal Array = let len = array.Length if len < 2 then () else - let cFast = LanguagePrimitives.FastGenericComparerInternal<'T> - if obj.ReferenceEquals (cFast, System.Collections.Generic.Comparer<'T>.Default) then + if LanguagePrimitives.EquivalentForStableAndUnstableSort<'T> then // An optimization for the cases where the keys and values coincide and do not have identity, e.g. are integers // In this case an unstable sort is just as good as a stable sort (and faster) Array.Sort<_,_>(array, null) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index 73396ce7081..f7b7cef961f 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -1330,6 +1330,21 @@ namespace Microsoft.FSharp.Core | ComparisonUsage.GreaterThanUsage -> maybeNaNExceptionComparer comparer GreaterThanUsageReturnFalse | _ -> comparer + /// As an optimization, determine if a fast unstable sort can be used with equivalent results + let equivalentForStableAndUnstableSort (ty:Type) = + ty.Equals(typeof) + || ty.Equals(typeof) + || ty.Equals(typeof) + || ty.Equals(typeof) + || ty.Equals(typeof) + || ty.Equals(typeof) + || ty.Equals(typeof) + || ty.Equals(typeof) + || ty.Equals(typeof) + || ty.Equals(typeof) + || ty.Equals(typeof) + || ty.Equals(typeof) + [] type FSharpComparer_ER<'T> private () = static let comparer = getGenericComparison<'T> ComparisonUsage.ERUsage true @@ -1337,8 +1352,10 @@ namespace Microsoft.FSharp.Core [] type FSharpComparer_InternalUse_ER<'T> private () = + static let equivalentForStableAndUnstableSort = equivalentForStableAndUnstableSort typeof<'T> static let comparer = getGenericComparison<'T> ComparisonUsage.ERUsage false static member Comparer = comparer + static member EquivalentForStableAndUnstableSort = equivalentForStableAndUnstableSort [] type FSharpComparer_PER<'T> private () = @@ -2410,6 +2427,8 @@ namespace Microsoft.FSharp.Core let FastGenericComparerInternal<'T> : Comparer<'T> = HashCompare.FSharpComparer_InternalUse_ER<'T>.Comparer + let EquivalentForStableAndUnstableSort<'T> : bool = + HashCompare.FSharpComparer_InternalUse_ER<'T>.EquivalentForStableAndUnstableSort //------------------------------------------------------------------------- // LanguagePrimitives: ENUMS diff --git a/src/fsharp/FSharp.Core/prim-types.fsi b/src/fsharp/FSharp.Core/prim-types.fsi index 1cd2364a345..5b5d228d9e5 100644 --- a/src/fsharp/FSharp.Core/prim-types.fsi +++ b/src/fsharp/FSharp.Core/prim-types.fsi @@ -954,6 +954,9 @@ namespace Microsoft.FSharp.Core /// Make an F# comparer object for the given type, where it can be null if System.Collections.Generic.Comparer<'T>.Default val internal FastGenericComparerInternal<'T> : System.Collections.Generic.Comparer<'T> when 'T : comparison + /// As an optimization, determine if a fast unstable sort can be used with equivalent results + val internal EquivalentForStableAndUnstableSort<'T> : bool + /// Make an F# hash/equality object for the given type val inline FastGenericEqualityComparer<'T> : System.Collections.Generic.IEqualityComparer<'T> when 'T : equality From c62d5b2450082827bbb8fc71467c1869431715e5 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Thu, 19 Jul 2018 15:49:09 +1000 Subject: [PATCH 38/92] Removed now unnecessary optimization from stableSortWithKeysAndComparer --- src/fsharp/FSharp.Core/local.fs | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) diff --git a/src/fsharp/FSharp.Core/local.fs b/src/fsharp/FSharp.Core/local.fs index 56d6a20cbdd..343b0409c26 100644 --- a/src/fsharp/FSharp.Core/local.fs +++ b/src/fsharp/FSharp.Core/local.fs @@ -990,7 +990,11 @@ module internal Array = open System - let inline fastComparerForArraySort<'t when 't : comparison> () = + let inline getInternalComparer<'t when 't : comparison> () = + // Previously a "comparer" was returned the could be null, which was for optimized Array.Sort + // but we now mainly return Comparer.Default (and FastGenericComparerInternal more so) + // which is also optimized in Array.Sort + // ** this comment can be destroyed sometime in the future, it is just as a breadcrumb for review ** LanguagePrimitives.FastGenericComparerInternal<'t> // The input parameter should be checked by callers if necessary @@ -1089,26 +1093,26 @@ module internal Array = let keys = zeroCreateUnchecked array.Length for i = 0 to array.Length - 1 do keys.[i] <- projection array.[i] - Array.Sort<_,_>(keys, array, fastComparerForArraySort()) + Array.Sort<_,_>(keys, array, getInternalComparer()) let unstableSortInPlace (array : array<'T>) = let len = array.Length if len < 2 then () - else Array.Sort<_>(array, fastComparerForArraySort()) + else Array.Sort<_>(array, getInternalComparer()) - let stableSortWithKeysAndComparer (cFast:IComparer<'Key>) (c:IComparer<'Key>) (array:array<'T>) (keys:array<'Key>) = + let stableSortWithKeysAndComparer (c:IComparer<'Key>) (array:array<'T>) (keys:array<'Key>) = // 'places' is an array or integers storing the permutation performed by the sort let places = zeroCreateUnchecked array.Length for i = 0 to array.Length - 1 do places.[i] <- i - System.Array.Sort<_,_>(keys, places, cFast) + System.Array.Sort<_,_>(keys, places, c) // 'array2' is a copy of the original values let array2 = (array.Clone() :?> array<'T>) // Walk through any chunks where the keys are equal let mutable i = 0 let len = array.Length - let intCompare = fastComparerForArraySort() + let intCompare = getInternalComparer() while i < len do let mutable j = i @@ -1123,9 +1127,8 @@ module internal Array = i <- j let stableSortWithKeys (array:array<'T>) (keys:array<'Key>) = - let cFast = fastComparerForArraySort() - let c = LanguagePrimitives.FastGenericComparer<'Key> - stableSortWithKeysAndComparer cFast c array keys + let c = getInternalComparer() + stableSortWithKeysAndComparer c array keys let stableSortInPlaceBy (projection: 'T -> 'U) (array : array<'T>) = let len = array.Length @@ -1156,7 +1159,7 @@ module internal Array = let keys = (array.Clone() :?> array<'T>) let comparer = OptimizedClosures.FSharpFunc<_,_,_>.Adapt(comparer) let c = { new IComparer<'T> with member __.Compare(x,y) = comparer.Invoke(x,y) } - stableSortWithKeysAndComparer c c array keys + stableSortWithKeysAndComparer c array keys let inline subUnchecked startIndex count (array : 'T[]) = let res = zeroCreateUnchecked count : 'T[] From 0420e6d433ba105d64d7c3a8500ca1826e64026c Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sun, 8 Jul 2018 12:55:30 +1000 Subject: [PATCH 39/92] Moved isRecordType down to prim-types.fs (internal only) --- src/fsharp/FSharp.Core/prim-types.fs | 99 +++++++++++++++++++++++++++ src/fsharp/FSharp.Core/prim-types.fsi | 13 ++++ src/fsharp/FSharp.Core/reflect.fs | 93 +++++++------------------ 3 files changed, 136 insertions(+), 69 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index f7b7cef961f..1b512c5da43 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -770,6 +770,105 @@ namespace Microsoft.FSharp.Core let anyToStringShowingNull x = anyToString "null" x + module internal Reflection = + let tupleNames = [| + "System.Tuple`1"; "System.Tuple`2"; "System.Tuple`3"; + "System.Tuple`4"; "System.Tuple`5"; "System.Tuple`6"; + "System.Tuple`7"; "System.Tuple`8"; "System.Tuple" + "System.ValueTuple`1"; "System.ValueTuple`2"; "System.ValueTuple`3"; + "System.ValueTuple`4"; "System.ValueTuple`5"; "System.ValueTuple`6"; + "System.ValueTuple`7"; "System.ValueTuple`8"; "System.ValueTuple" |] + + let simpleTupleNames = [| + "Tuple`1"; "Tuple`2"; "Tuple`3"; + "Tuple`4"; "Tuple`5"; "Tuple`6"; + "Tuple`7"; "Tuple`8"; + "ValueTuple`1"; "ValueTuple`2"; "ValueTuple`3"; + "ValueTuple`4"; "ValueTuple`5"; "ValueTuple`6"; + "ValueTuple`7"; "ValueTuple`8"; |] + + let isTupleType (typ:Type) = + // We need to be careful that we only rely typ.IsGenericType, typ.Namespace and typ.Name here. + // + // Historically the FSharp.Core reflection utilities get used on implementations of + // System.Type that don't have functionality such as .IsEnum and .FullName fully implemented. + // This happens particularly over TypeBuilderInstantiation types in the ProvideTypes implementation of System.TYpe + // used in F# type providers. + typ.IsGenericType && + System.String.Equals(typ.Namespace, "System") && + Array.Exists (simpleTupleNames, Predicate typ.Name.StartsWith) + +#if !FX_NO_REFLECTION_ONLY + let cmaName = typeof.FullName + + let tryFindCompilationMappingAttributeFromData (attrs:System.Collections.Generic.IList, res:byref) : bool = + match attrs with + | null -> false + | _ -> + let mutable found = false + for a in attrs do + if a.Constructor.DeclaringType.FullName.Equals cmaName then + let args = a.ConstructorArguments + let flags = + match args.Count with + | 1 -> ((let x = args.[0] in x.Value :?> SourceConstructFlags), 0, 0) + | 2 -> ((let x = args.[0] in x.Value :?> SourceConstructFlags), (let x = args.[1] in x.Value :?> int), 0) + | 3 -> ((let x = args.[0] in x.Value :?> SourceConstructFlags), (let x = args.[1] in x.Value :?> int), (let x = args.[2] in x.Value :?> int)) + | _ -> (SourceConstructFlags.None, 0, 0) + res <- flags + found <- true + found +#endif + + let tryFindCompilationMappingAttribute (attrs:obj[], res:byref) : bool = + match attrs with + | null | [||] -> false + | [| :? CompilationMappingAttribute as a |] -> + res <- a.SourceConstructFlags, a.SequenceNumber, a.VariantNumber + true + | _ -> raise (System.InvalidOperationException (SR.GetString(SR.multipleCompilationMappings))) + + let tryFindCompilationMappingAttributeFromType (typ:Type, res:byref) : bool = +#if !FX_NO_REFLECTION_ONLY + let assem = typ.Assembly + if (not (obj.ReferenceEquals(assem, null))) && assem.ReflectionOnly then + tryFindCompilationMappingAttributeFromData (typ.GetCustomAttributesData(), &res) + else +#endif + tryFindCompilationMappingAttribute (typ.GetCustomAttributes (typeof,false), &res) + + let tryFindSourceConstructFlagsOfType (typ:Type, res:byref) : bool = + let mutable x = unsafeDefault<_> + if tryFindCompilationMappingAttributeFromType (typ, &x) then + let flags,_n,_vn = x + res <- flags + true + else + false + + let inline flagsAnd<'a> (lhs:'a) (rhs:'a) = + (# "and" lhs rhs : 'a #) + + let inline flagsContains<'a when 'a : equality> (flags:'a) (mask:'a) (value:'a) = + (flagsAnd flags mask).Equals value + + let inline flagsIsSet<'a when 'a : equality> (flags:'a) (value:'a) = + flagsContains flags value value + + let isRecordType (typ:Type, bindingFlags:BindingFlags) = + let mutable flags = unsafeDefault<_> + match tryFindSourceConstructFlagsOfType (typ, &flags) with + | false -> false + | true -> + (flagsContains flags SourceConstructFlags.KindMask SourceConstructFlags.RecordType) && + // We see private representations only if BindingFlags.NonPublic is set + (if flagsIsSet flags SourceConstructFlags.NonPublicRepresentation then + flagsIsSet bindingFlags BindingFlags.NonPublic + else + true) + + + module HashCompare = //------------------------------------------------------------------------- // LanguagePrimitives.HashCompare: HASHING. diff --git a/src/fsharp/FSharp.Core/prim-types.fsi b/src/fsharp/FSharp.Core/prim-types.fsi index 5b5d228d9e5..67d260082ce 100644 --- a/src/fsharp/FSharp.Core/prim-types.fsi +++ b/src/fsharp/FSharp.Core/prim-types.fsi @@ -1239,6 +1239,19 @@ namespace Microsoft.FSharp.Core //[] val inline SetArray4D : target:'T[,,,] -> index1:int -> index2:int -> index3:int -> index4:int -> value:'T -> unit + module internal Reflection = + val internal tupleNames : string [] + val internal isTupleType : Type -> bool + +#if !FX_NO_REFLECTION_ONLY + val internal tryFindCompilationMappingAttributeFromData : System.Collections.Generic.IList * byref -> bool +#endif + + val internal tryFindCompilationMappingAttribute : obj[] * byref -> bool + val internal tryFindCompilationMappingAttributeFromType : Type * byref -> bool + val internal tryFindSourceConstructFlagsOfType : Type * byref -> bool + val internal isRecordType : Type * System.Reflection.BindingFlags -> bool + /// The F# compiler emits calls to some of the functions in this module as part of the compiled form of some language constructs module HashCompare = [] diff --git a/src/fsharp/FSharp.Core/reflect.fs b/src/fsharp/FSharp.Core/reflect.fs index 78528294f5c..ca385db43c7 100644 --- a/src/fsharp/FSharp.Core/reflect.fs +++ b/src/fsharp/FSharp.Core/reflect.fs @@ -83,11 +83,11 @@ module internal Impl = //----------------------------------------------------------------- // ATTRIBUTE DECOMPILATION - let tryFindCompilationMappingAttribute (attrs:obj[]) = - match attrs with - | null | [| |] -> None - | [| res |] -> let a = (res :?> CompilationMappingAttribute) in Some (a.SourceConstructFlags, a.SequenceNumber, a.VariantNumber) - | _ -> raise <| System.InvalidOperationException (SR.GetString(SR.multipleCompilationMappings)) + let tryFindCompilationMappingAttribute (attrs:obj[]) = + let mutable result = Unchecked.defaultof<_> + if LanguagePrimitives.Reflection.tryFindCompilationMappingAttribute (attrs, &result) + then Some result + else None let findCompilationMappingAttribute (attrs:obj[]) = match tryFindCompilationMappingAttribute attrs with @@ -95,26 +95,14 @@ module internal Impl = | Some a -> a #if !FX_NO_REFLECTION_ONLY - let cmaName = typeof.FullName let assemblyName = typeof.Assembly.GetName().Name let _ = assert (assemblyName = "FSharp.Core") let tryFindCompilationMappingAttributeFromData (attrs:System.Collections.Generic.IList) = - match attrs with - | null -> None - | _ -> - let mutable res = None - for a in attrs do - if a.Constructor.DeclaringType.FullName = cmaName then - let args = a.ConstructorArguments - let flags = - match args.Count with - | 1 -> ((let x = args.[0] in x.Value :?> SourceConstructFlags), 0, 0) - | 2 -> ((let x = args.[0] in x.Value :?> SourceConstructFlags), (let x = args.[1] in x.Value :?> int), 0) - | 3 -> ((let x = args.[0] in x.Value :?> SourceConstructFlags), (let x = args.[1] in x.Value :?> int), (let x = args.[2] in x.Value :?> int)) - | _ -> (enum 0, 0, 0) - res <- Some flags - res + let mutable result = Unchecked.defaultof<_> + if LanguagePrimitives.Reflection.tryFindCompilationMappingAttributeFromData (attrs, &result) + then Some result + else None let findCompilationMappingAttributeFromData attrs = match tryFindCompilationMappingAttributeFromData attrs with @@ -122,14 +110,11 @@ module internal Impl = | Some a -> a #endif - let tryFindCompilationMappingAttributeFromType (typ:Type) = -#if !FX_NO_REFLECTION_ONLY - let assem = typ.Assembly - if (not (isNull assem)) && assem.ReflectionOnly then - tryFindCompilationMappingAttributeFromData ( typ.GetCustomAttributesData()) - else -#endif - tryFindCompilationMappingAttribute ( typ.GetCustomAttributes (typeof,false)) + let tryFindCompilationMappingAttributeFromType (typ:Type) = + let mutable result = Unchecked.defaultof<_> + if LanguagePrimitives.Reflection.tryFindCompilationMappingAttributeFromType (typ, &result) + then Some result + else None let tryFindCompilationMappingAttributeFromMemberInfo (info:MemberInfo) = #if !FX_NO_REFLECTION_ONLY @@ -159,10 +144,12 @@ module internal Impl = | None -> false | Some (flags,_n,_vn) -> (flags &&& SourceConstructFlags.KindMask) = SourceConstructFlags.Field - let tryFindSourceConstructFlagsOfType (typ:Type) = - match tryFindCompilationMappingAttributeFromType typ with - | None -> None - | Some (flags,_n,_vn) -> Some flags + let tryFindSourceConstructFlagsOfType (typ:Type) = + let mutable res = Unchecked.defaultof<_> + if LanguagePrimitives.Reflection.tryFindSourceConstructFlagsOfType (typ, &res) then + Some res + else + None //----------------------------------------------------------------- // UNION DECOMPILATION @@ -349,32 +336,9 @@ module internal Impl = //----------------------------------------------------------------- // TUPLE DECOMPILATION - let tupleNames = [| - "System.Tuple`1"; "System.Tuple`2"; "System.Tuple`3"; - "System.Tuple`4"; "System.Tuple`5"; "System.Tuple`6"; - "System.Tuple`7"; "System.Tuple`8"; "System.Tuple" - "System.ValueTuple`1"; "System.ValueTuple`2"; "System.ValueTuple`3"; - "System.ValueTuple`4"; "System.ValueTuple`5"; "System.ValueTuple`6"; - "System.ValueTuple`7"; "System.ValueTuple`8"; "System.ValueTuple" |] - - let simpleTupleNames = [| - "Tuple`1"; "Tuple`2"; "Tuple`3"; - "Tuple`4"; "Tuple`5"; "Tuple`6"; - "Tuple`7"; "Tuple`8"; - "ValueTuple`1"; "ValueTuple`2"; "ValueTuple`3"; - "ValueTuple`4"; "ValueTuple`5"; "ValueTuple`6"; - "ValueTuple`7"; "ValueTuple`8"; |] - - let isTupleType (typ:Type) = - // We need to be careful that we only rely typ.IsGenericType, typ.Namespace and typ.Name here. - // - // Historically the FSharp.Core reflection utilities get used on implementations of - // System.Type that don't have functionality such as .IsEnum and .FullName fully implemented. - // This happens particularly over TypeBuilderInstantiation types in the ProvideTypes implementation of System.TYpe - // used in F# type providers. - typ.IsGenericType && - typ.Namespace = "System" && - simpleTupleNames |> Seq.exists typ.Name.StartsWith + let tupleNames = LanguagePrimitives.Reflection.tupleNames + + let isTupleType (typ:Type) = LanguagePrimitives.Reflection.isTupleType typ let maxTuple = 8 // Which field holds the nested tuple? @@ -598,16 +562,7 @@ module internal Impl = //----------------------------------------------------------------- // RECORD DECOMPILATION - let isRecordType (typ:Type,bindingFlags:BindingFlags) = - match tryFindSourceConstructFlagsOfType(typ) with - | None -> false - | Some(flags) -> - (flags &&& SourceConstructFlags.KindMask) = SourceConstructFlags.RecordType && - // We see private representations only if BindingFlags.NonPublic is set - (if (flags &&& SourceConstructFlags.NonPublicRepresentation) <> enum(0) then - (bindingFlags &&& BindingFlags.NonPublic) <> enum(0) - else - true) + let isRecordType (typ:Type,bindingFlags:BindingFlags) = LanguagePrimitives.Reflection.isRecordType (typ, bindingFlags) let fieldPropsOfRecordType(typ:Type,bindingFlags) = typ.GetProperties(instancePropertyFlags ||| bindingFlags) From e6ef7fba45b8ade897ce91949697b6a97250ef45 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sun, 8 Jul 2018 15:29:24 +1000 Subject: [PATCH 40/92] Moved enough of reflect.fs to get Record fields --- src/fsharp/FSharp.Core/prim-types.fs | 145 ++++++++++++++++++++++++-- src/fsharp/FSharp.Core/prim-types.fsi | 9 ++ src/fsharp/FSharp.Core/reflect.fs | 61 +++-------- 3 files changed, 159 insertions(+), 56 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index 1b512c5da43..b5128924b8c 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -771,6 +771,72 @@ namespace Microsoft.FSharp.Core let anyToStringShowingNull x = anyToString "null" x module internal Reflection = + let inline flagsOr<'a> (lhs:'a) (rhs:'a) = + (# "or" lhs rhs : 'a #) + + let inline flagsAnd<'a> (lhs:'a) (rhs:'a) = + (# "and" lhs rhs : 'a #) + + let inline flagsContains<'a when 'a : equality> (flags:'a) (mask:'a) (value:'a) = + (flagsAnd flags mask).Equals value + + let inline flagsIsSet<'a when 'a : equality> (flags:'a) (value:'a) = + flagsContains flags value value + +#if FX_RESHAPED_REFLECTION + module internal ReflectionAdapters = + let toArray<'a> (s:System.Collections.Generic.IEnumerable<'a>) = + (System.Collections.Generic.List<'a> s).ToArray () + + open System + + let inline hasFlag (flag : BindingFlags) f = flagsIsSet f flag + let isDeclaredFlag f = hasFlag BindingFlags.DeclaredOnly f + let isPublicFlag f = hasFlag BindingFlags.Public f + let isStaticFlag f = hasFlag BindingFlags.Static f + let isInstanceFlag f = hasFlag BindingFlags.Instance f + let isNonPublicFlag f = hasFlag BindingFlags.NonPublic f + + let isAcceptable bindingFlags isStatic isPublic = + // 1. check if member kind (static\instance) was specified in flags + ((isStaticFlag bindingFlags && isStatic) || (isInstanceFlag bindingFlags && not isStatic)) && + // 2. check if member accessibility was specified in flags + ((isPublicFlag bindingFlags && isPublic) || (isNonPublicFlag bindingFlags && not isPublic)) + + type System.Type with + // use different sources based on Declared flag + member this.GetProperties (bindingFlags) = + let properties = + if isDeclaredFlag bindingFlags then + this.GetTypeInfo().DeclaredProperties + else + this.GetRuntimeProperties () + + Array.FindAll (toArray properties, Predicate (fun pi -> + let mi = + match pi.GetMethod with + | null -> pi.SetMethod + | _ -> pi.GetMethod + if obj.ReferenceEquals (mi, null) then + false + else + isAcceptable bindingFlags mi.IsStatic mi.IsPublic)) + + type System.Reflection.MemberInfo with + member this.GetCustomAttributes(attrTy, inherits) : obj[] = + downcast box(toArray (CustomAttributeExtensions.GetCustomAttributes(this, attrTy, inherits))) + + open ReflectionAdapters + open PrimReflectionAdapters +#endif + + +#if FX_RESHAPED_REFLECTION + let instancePropertyFlags = BindingFlags.Instance +#else + let instancePropertyFlags = flagsOr BindingFlags.GetProperty BindingFlags.Instance +#endif + let tupleNames = [| "System.Tuple`1"; "System.Tuple`2"; "System.Tuple`3"; "System.Tuple`4"; "System.Tuple`5"; "System.Tuple`6"; @@ -799,6 +865,8 @@ namespace Microsoft.FSharp.Core Array.Exists (simpleTupleNames, Predicate typ.Name.StartsWith) #if !FX_NO_REFLECTION_ONLY + let assemblyName = typeof.Assembly.GetName().Name + let _ = assert (System.String.Equals (assemblyName, "FSharp.Core")) let cmaName = typeof.FullName let tryFindCompilationMappingAttributeFromData (attrs:System.Collections.Generic.IList, res:byref) : bool = @@ -818,6 +886,12 @@ namespace Microsoft.FSharp.Core res <- flags found <- true found + + let findCompilationMappingAttributeFromData attrs = + let mutable x = unsafeDefault<_> + match tryFindCompilationMappingAttributeFromData (attrs, &x) with + | false -> raise (Exception "no compilation mapping attribute") + | true -> x #endif let tryFindCompilationMappingAttribute (attrs:obj[], res:byref) : bool = @@ -828,6 +902,12 @@ namespace Microsoft.FSharp.Core true | _ -> raise (System.InvalidOperationException (SR.GetString(SR.multipleCompilationMappings))) + let findCompilationMappingAttribute (attrs:obj[]) = + let mutable x = unsafeDefault<_> + match tryFindCompilationMappingAttribute (attrs, &x) with + | false -> raise (Exception "no compilation mapping attribute") + | true -> x + let tryFindCompilationMappingAttributeFromType (typ:Type, res:byref) : bool = #if !FX_NO_REFLECTION_ONLY let assem = typ.Assembly @@ -837,6 +917,24 @@ namespace Microsoft.FSharp.Core #endif tryFindCompilationMappingAttribute (typ.GetCustomAttributes (typeof,false), &res) + let tryFindCompilationMappingAttributeFromMemberInfo (info:MemberInfo, res:byref) : bool = +#if !FX_NO_REFLECTION_ONLY + let assem = info.DeclaringType.Assembly + if (not (obj.ReferenceEquals (assem, null))) && assem.ReflectionOnly then + tryFindCompilationMappingAttributeFromData (info.GetCustomAttributesData(), &res) + else +#endif + tryFindCompilationMappingAttribute (info.GetCustomAttributes (typeof,false), &res) + + let findCompilationMappingAttributeFromMemberInfo (info:MemberInfo) = +#if !FX_NO_REFLECTION_ONLY + let assem = info.DeclaringType.Assembly + if (not (obj.ReferenceEquals (assem, null))) && assem.ReflectionOnly then + findCompilationMappingAttributeFromData (info.GetCustomAttributesData()) + else +#endif + findCompilationMappingAttribute (info.GetCustomAttributes (typeof,false)) + let tryFindSourceConstructFlagsOfType (typ:Type, res:byref) : bool = let mutable x = unsafeDefault<_> if tryFindCompilationMappingAttributeFromType (typ, &x) then @@ -846,15 +944,6 @@ namespace Microsoft.FSharp.Core else false - let inline flagsAnd<'a> (lhs:'a) (rhs:'a) = - (# "and" lhs rhs : 'a #) - - let inline flagsContains<'a when 'a : equality> (flags:'a) (mask:'a) (value:'a) = - (flagsAnd flags mask).Equals value - - let inline flagsIsSet<'a when 'a : equality> (flags:'a) (value:'a) = - flagsContains flags value value - let isRecordType (typ:Type, bindingFlags:BindingFlags) = let mutable flags = unsafeDefault<_> match tryFindSourceConstructFlagsOfType (typ, &flags) with @@ -867,7 +956,43 @@ namespace Microsoft.FSharp.Core else true) - + let isFieldProperty (prop : PropertyInfo) = + let mutable res = unsafeDefault<_> + match tryFindCompilationMappingAttributeFromMemberInfo(prop:>MemberInfo, &res) with + | false -> false + | true -> + let (flags,_n,_vn) = res + flagsContains flags SourceConstructFlags.KindMask SourceConstructFlags.Field + + let sequenceNumberOfMember (x:MemberInfo) = let (_,n,_) = findCompilationMappingAttributeFromMemberInfo x in n + let variantNumberOfMember (x:MemberInfo) = let (_,_,vn) = findCompilationMappingAttributeFromMemberInfo x in vn + + // Although this funciton is called sortFreshArray (and was so in it's previously life in reflect.fs) + // it does not create a fresh array, but rather uses the existing array. + let sortFreshArray (f:'a->int) (arr:'a[]) = + let comparer = System.Collections.Generic.Comparer.Default + System.Array.Sort (arr, { + new IComparer<'a> with + member __.Compare (lhs:'a, rhs:'a) = + comparer.Compare (f lhs, f rhs) }) + arr + + let fieldPropsOfRecordType (typ:Type, bindingFlags) = + let properties = typ.GetProperties (flagsOr instancePropertyFlags bindingFlags) + let fields = System.Array.FindAll (properties, Predicate isFieldProperty) + sortFreshArray sequenceNumberOfMember fields + + let isUnionType (typ:Type,bindingFlags:BindingFlags) = + let mutable flags = unsafeDefault<_> + match tryFindSourceConstructFlagsOfType(typ, &flags) with + | false -> false + | true -> + (flagsContains flags SourceConstructFlags.KindMask SourceConstructFlags.SumType) && + // We see private representations only if BindingFlags.NonPublic is set + (if flagsIsSet flags SourceConstructFlags.NonPublicRepresentation then + flagsIsSet bindingFlags BindingFlags.NonPublic + else + true) module HashCompare = //------------------------------------------------------------------------- diff --git a/src/fsharp/FSharp.Core/prim-types.fsi b/src/fsharp/FSharp.Core/prim-types.fsi index 67d260082ce..901914636a4 100644 --- a/src/fsharp/FSharp.Core/prim-types.fsi +++ b/src/fsharp/FSharp.Core/prim-types.fsi @@ -1245,12 +1245,21 @@ namespace Microsoft.FSharp.Core #if !FX_NO_REFLECTION_ONLY val internal tryFindCompilationMappingAttributeFromData : System.Collections.Generic.IList * byref -> bool + val internal findCompilationMappingAttributeFromData : System.Collections.Generic.IList -> SourceConstructFlags*int*int #endif val internal tryFindCompilationMappingAttribute : obj[] * byref -> bool + val internal findCompilationMappingAttribute : obj[] -> SourceConstructFlags*int*int val internal tryFindCompilationMappingAttributeFromType : Type * byref -> bool + val internal tryFindCompilationMappingAttributeFromMemberInfo : System.Reflection.MemberInfo * byref -> bool + val internal findCompilationMappingAttributeFromMemberInfo : System.Reflection.MemberInfo -> SourceConstructFlags*int*int val internal tryFindSourceConstructFlagsOfType : Type * byref -> bool + val internal sequenceNumberOfMember : System.Reflection.MemberInfo -> int + val internal variantNumberOfMember : System.Reflection.MemberInfo -> int + val internal isFieldProperty : System.Reflection.PropertyInfo -> bool + val internal fieldPropsOfRecordType : Type * System.Reflection.BindingFlags -> System.Reflection.PropertyInfo[] val internal isRecordType : Type * System.Reflection.BindingFlags -> bool + val internal isUnionType : Type * System.Reflection.BindingFlags -> bool /// The F# compiler emits calls to some of the functions in this module as part of the compiled form of some language constructs module HashCompare = diff --git a/src/fsharp/FSharp.Core/reflect.fs b/src/fsharp/FSharp.Core/reflect.fs index ca385db43c7..027713b34ee 100644 --- a/src/fsharp/FSharp.Core/reflect.fs +++ b/src/fsharp/FSharp.Core/reflect.fs @@ -89,25 +89,16 @@ module internal Impl = then Some result else None - let findCompilationMappingAttribute (attrs:obj[]) = - match tryFindCompilationMappingAttribute attrs with - | None -> failwith "no compilation mapping attribute" - | Some a -> a + let findCompilationMappingAttribute (attrs:obj[]) = LanguagePrimitives.Reflection.findCompilationMappingAttribute attrs #if !FX_NO_REFLECTION_ONLY - let assemblyName = typeof.Assembly.GetName().Name - let _ = assert (assemblyName = "FSharp.Core") - let tryFindCompilationMappingAttributeFromData (attrs:System.Collections.Generic.IList) = let mutable result = Unchecked.defaultof<_> if LanguagePrimitives.Reflection.tryFindCompilationMappingAttributeFromData (attrs, &result) then Some result else None - let findCompilationMappingAttributeFromData attrs = - match tryFindCompilationMappingAttributeFromData attrs with - | None -> failwith "no compilation mapping attribute" - | Some a -> a + let findCompilationMappingAttributeFromData attrs = LanguagePrimitives.Reflection.findCompilationMappingAttributeFromData attrs #endif let tryFindCompilationMappingAttributeFromType (typ:Type) = @@ -117,32 +108,19 @@ module internal Impl = else None let tryFindCompilationMappingAttributeFromMemberInfo (info:MemberInfo) = -#if !FX_NO_REFLECTION_ONLY - let assem = info.DeclaringType.Assembly - if (not (isNull assem)) && assem.ReflectionOnly then - tryFindCompilationMappingAttributeFromData (info.GetCustomAttributesData()) - else -#endif - tryFindCompilationMappingAttribute (info.GetCustomAttributes (typeof,false)) + let mutable result = Unchecked.defaultof<_> + if LanguagePrimitives.Reflection.tryFindCompilationMappingAttributeFromMemberInfo (info, &result) + then Some result + else None - let findCompilationMappingAttributeFromMemberInfo (info:MemberInfo) = -#if !FX_NO_REFLECTION_ONLY - let assem = info.DeclaringType.Assembly - if (not (isNull assem)) && assem.ReflectionOnly then - findCompilationMappingAttributeFromData (info.GetCustomAttributesData()) - else -#endif - findCompilationMappingAttribute (info.GetCustomAttributes (typeof,false)) + let findCompilationMappingAttributeFromMemberInfo (info:MemberInfo) = LanguagePrimitives.Reflection.findCompilationMappingAttributeFromMemberInfo info - let sequenceNumberOfMember (x: MemberInfo) = let (_,n,_) = findCompilationMappingAttributeFromMemberInfo x in n - let variantNumberOfMember (x: MemberInfo) = let (_,_,vn) = findCompilationMappingAttributeFromMemberInfo x in vn + let sequenceNumberOfMember (x:MemberInfo) = LanguagePrimitives.Reflection.sequenceNumberOfMember x + let variantNumberOfMember (x:MemberInfo) = LanguagePrimitives.Reflection.variantNumberOfMember x let sortFreshArray f arr = Array.sortInPlaceWith f arr; arr - let isFieldProperty (prop : PropertyInfo) = - match tryFindCompilationMappingAttributeFromMemberInfo(prop) with - | None -> false - | Some (flags,_n,_vn) -> (flags &&& SourceConstructFlags.KindMask) = SourceConstructFlags.Field + let isFieldProperty (prop : PropertyInfo) = LanguagePrimitives.Reflection.isFieldProperty prop let tryFindSourceConstructFlagsOfType (typ:Type) = let mutable res = Unchecked.defaultof<_> @@ -226,17 +204,11 @@ module internal Impl = (fun tag -> tagfieldmap.[tag]) let isUnionType (typ:Type,bindingFlags:BindingFlags) = + // isOptionType & isListType are not necessary. There were here before the code was refactored into prim-types + // presumably as an optimization, so have not been removed (no performance testing run at this time) isOptionType typ || - isListType typ || - match tryFindSourceConstructFlagsOfType(typ) with - | None -> false - | Some(flags) -> - (flags &&& SourceConstructFlags.KindMask) = SourceConstructFlags.SumType && - // We see private representations only if BindingFlags.NonPublic is set - (if (flags &&& SourceConstructFlags.NonPublicRepresentation) <> enum(0) then - (bindingFlags &&& BindingFlags.NonPublic) <> enum(0) - else - true) + isListType typ || + LanguagePrimitives.Reflection.isUnionType (typ, bindingFlags) // Check the base type - if it is also an F# type then // for the moment we know it is a Discriminated Union @@ -564,10 +536,7 @@ module internal Impl = let isRecordType (typ:Type,bindingFlags:BindingFlags) = LanguagePrimitives.Reflection.isRecordType (typ, bindingFlags) - let fieldPropsOfRecordType(typ:Type,bindingFlags) = - typ.GetProperties(instancePropertyFlags ||| bindingFlags) - |> Array.filter isFieldProperty - |> sortFreshArray (fun p1 p2 -> compare (sequenceNumberOfMember p1) (sequenceNumberOfMember p2)) + let fieldPropsOfRecordType (typ:Type, bindingFlags) = LanguagePrimitives.Reflection.fieldPropsOfRecordType (typ, bindingFlags) let getRecordReader(typ:Type,bindingFlags) = let props = fieldPropsOfRecordType(typ,bindingFlags) From 5472606fd2dcf724ff94cae7f8d5ae8e09a05a59 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Mon, 9 Jul 2018 10:35:50 +1000 Subject: [PATCH 41/92] Moved reflection functions for Union types into prim-types.fs --- src/fsharp/FSharp.Core/prim-types.fs | 136 +++++++++++++++++++++++++- src/fsharp/FSharp.Core/prim-types.fsi | 3 + src/fsharp/FSharp.Core/reflect.fs | 75 +------------- 3 files changed, 142 insertions(+), 72 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index b5128924b8c..30fedc7b044 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -804,6 +804,49 @@ namespace Microsoft.FSharp.Core ((isPublicFlag bindingFlags && isPublic) || (isNonPublicFlag bindingFlags && not isPublic)) type System.Type with + member this.GetNestedType (name, bindingFlags) = + // MSDN: http://msdn.microsoft.com/en-us/library/0dcb3ad5.aspx + // The following BindingFlags filter flags can be used to define which nested types to include in the search: + // You must specify either BindingFlags.Public or BindingFlags.NonPublic to get a return. + // Specify BindingFlags.Public to include public nested types in the search. + // Specify BindingFlags.NonPublic to include non-public nested types (that is, private, internal, and protected nested types) in the search. + // This method returns only the nested types of the current type. It does not search the base classes of the current type. + // To find types that are nested in base classes, you must walk the inheritance hierarchy, calling GetNestedType at each level. + let e = this.GetTypeInfo().DeclaredNestedTypes.GetEnumerator () + let rec f () = + if not (e.MoveNext ()) then null + else + let nestedTy = e.Current + if (String.Equals (nestedTy.Name, name)) && + ((isPublicFlag bindingFlags && nestedTy.IsNestedPublic) || + (isNonPublicFlag bindingFlags && (nestedTy.IsNestedPrivate || nestedTy.IsNestedFamily || nestedTy.IsNestedAssembly || nestedTy.IsNestedFamORAssem || nestedTy.IsNestedFamANDAssem))) then + nestedTy.AsType () + else + f () + f () + + // use different sources based on Declared flag + member this.GetMethods (bindingFlags) = + let methods = + if isDeclaredFlag bindingFlags then + this.GetTypeInfo().DeclaredMethods + else + this.GetRuntimeMethods() + + Array.FindAll (toArray methods, Predicate (fun m -> + isAcceptable bindingFlags m.IsStatic m.IsPublic)) + + // use different sources based on Declared flag + member this.GetFields (bindingFlags) = + let fields = + if isDeclaredFlag bindingFlags then + this.GetTypeInfo().DeclaredFields + else + this.GetRuntimeFields() + + Array.FindAll (toArray fields, Predicate (fun f -> + isAcceptable bindingFlags f.IsStatic f.IsPublic)) + // use different sources based on Declared flag member this.GetProperties (bindingFlags) = let properties = @@ -821,20 +864,37 @@ namespace Microsoft.FSharp.Core false else isAcceptable bindingFlags mi.IsStatic mi.IsPublic)) + + member this.IsGenericTypeDefinition = this.GetTypeInfo().IsGenericTypeDefinition type System.Reflection.MemberInfo with member this.GetCustomAttributes(attrTy, inherits) : obj[] = downcast box(toArray (CustomAttributeExtensions.GetCustomAttributes(this, attrTy, inherits))) - open ReflectionAdapters + module internal SystemAdapters = + type Converter<'TInput, 'TOutput> = delegate of 'TInput -> 'TOutput + + type System.Array with + static member ConvertAll<'TInput, 'TOutput>(input:'TInput[], conv:Converter<'TInput, 'TOutput>) = + let output = (# "newarr !0" type ('TOutput) input.Length : 'TOutput array #) + for i = 0 to input.Length-1 do + set output i (conv.Invoke (get input i)) + output + open PrimReflectionAdapters + open ReflectionAdapters + open SystemAdapters #endif #if FX_RESHAPED_REFLECTION let instancePropertyFlags = BindingFlags.Instance + let staticFieldFlags = BindingFlags.Static + let staticMethodFlags = BindingFlags.Static #else let instancePropertyFlags = flagsOr BindingFlags.GetProperty BindingFlags.Instance + let staticFieldFlags = flagsOr BindingFlags.GetField BindingFlags.Static + let staticMethodFlags = BindingFlags.Static #endif let tupleNames = [| @@ -982,6 +1042,80 @@ namespace Microsoft.FSharp.Core let fields = System.Array.FindAll (properties, Predicate isFieldProperty) sortFreshArray sequenceNumberOfMember fields + let getUnionTypeTagNameMap (typ:Type,bindingFlags:BindingFlags) : (int*string)[] = + let enumTyp = typ.GetNestedType ("Tags", bindingFlags) + // Unions with a singleton case do not get a Tags type (since there is only one tag), hence enumTyp may be null in this case + match enumTyp with + | null -> + let methods = typ.GetMethods (flagsOr staticMethodFlags bindingFlags) + let maybeTagNames = + Array.ConvertAll (methods, Converter (fun minfo -> + let mutable res = unsafeDefault<_> + match tryFindCompilationMappingAttributeFromMemberInfo (minfo:>MemberInfo, &res) with + | false -> unsafeDefault<_> + | true -> + let flags,n,_vn = res + if flagsContains flags SourceConstructFlags.KindMask SourceConstructFlags.UnionCase then + // chop "get_" or "New" off the front + let nm = + let nm = minfo.Name + if nm.StartsWith "get_" then nm.Substring 4 + elif nm.StartsWith "New" then nm.Substring 3 + else nm + (n, nm) + else + unsafeDefault<_> )) + Array.FindAll (maybeTagNames, Predicate (fun maybeTagName -> not (obj.ReferenceEquals (maybeTagName, null)))) + | _ -> + let fields = enumTyp.GetFields (flagsOr staticFieldFlags bindingFlags) + let filtered = Array.FindAll (fields, (fun (f:FieldInfo) -> f.IsStatic && f.IsLiteral)) + let sorted = sortFreshArray (fun (f:FieldInfo) -> (f.GetValue null) :?> int) filtered + Array.ConvertAll (sorted, Converter (fun tagfield -> (tagfield.GetValue(null) :?> int),tagfield.Name)) + + let getUnionCasesTyp (typ: Type, _bindingFlags) = +#if CASES_IN_NESTED_CLASS + let casesTyp = typ.GetNestedType("Cases", bindingFlags) + if casesTyp.IsGenericTypeDefinition then casesTyp.MakeGenericType(typ.GetGenericArguments()) + else casesTyp +#else + typ +#endif + + let getUnionCaseTyp (typ: Type, tag: int, bindingFlags) = + let tagFields = getUnionTypeTagNameMap(typ,bindingFlags) + let tagField = let _,f = Array.Find (tagFields, Predicate (fun (i,_) -> i = tag)) in f + + if tagFields.Length = 1 then + typ + else + // special case: two-cased DU annotated with CompilationRepresentation(UseNullAsTrueValue) + // in this case it will be compiled as one class: return self type for non-nullary case and null for nullary + let isTwoCasedDU = + if tagFields.Length = 2 then + match typ.GetCustomAttributes(typeof, false) with + | [|:? CompilationRepresentationAttribute as attr|] -> + flagsIsSet attr.Flags CompilationRepresentationFlags.UseNullAsTrueValue + | _ -> false + else + false + if isTwoCasedDU then + typ + else + let casesTyp = getUnionCasesTyp (typ, bindingFlags) + let caseTyp = casesTyp.GetNestedType(tagField, bindingFlags) // if this is null then the union is nullary + match caseTyp with + | null -> null + | _ when caseTyp.IsGenericTypeDefinition -> caseTyp.MakeGenericType(casesTyp.GetGenericArguments()) + | _ -> caseTyp + + let fieldsPropsOfUnionCase(typ:Type, tag:int, bindingFlags) = + // Lookup the type holding the fields for the union case + let caseTyp = getUnionCaseTyp (typ, tag, bindingFlags) + let caseTyp = match caseTyp with null -> typ | _ -> caseTyp + let properties = caseTyp.GetProperties (flagsOr instancePropertyFlags bindingFlags) + let filtered = Array.FindAll (properties, Predicate (fun p -> if isFieldProperty p then (variantNumberOfMember (p:>MemberInfo)) = tag else false)) + sortFreshArray (fun (p:PropertyInfo) -> sequenceNumberOfMember p) filtered + let isUnionType (typ:Type,bindingFlags:BindingFlags) = let mutable flags = unsafeDefault<_> match tryFindSourceConstructFlagsOfType(typ, &flags) with diff --git a/src/fsharp/FSharp.Core/prim-types.fsi b/src/fsharp/FSharp.Core/prim-types.fsi index 901914636a4..994495accbb 100644 --- a/src/fsharp/FSharp.Core/prim-types.fsi +++ b/src/fsharp/FSharp.Core/prim-types.fsi @@ -1259,6 +1259,9 @@ namespace Microsoft.FSharp.Core val internal isFieldProperty : System.Reflection.PropertyInfo -> bool val internal fieldPropsOfRecordType : Type * System.Reflection.BindingFlags -> System.Reflection.PropertyInfo[] val internal isRecordType : Type * System.Reflection.BindingFlags -> bool + val internal getUnionTypeTagNameMap : Type * System.Reflection.BindingFlags -> (int*string)[] + val internal getUnionCaseTyp : Type * int * System.Reflection.BindingFlags -> Type + val internal fieldsPropsOfUnionCase : Type * int* System.Reflection.BindingFlags -> System.Reflection.PropertyInfo[] val internal isUnionType : Type * System.Reflection.BindingFlags -> bool /// The F# compiler emits calls to some of the functions in this module as part of the compiled form of some language constructs diff --git a/src/fsharp/FSharp.Core/reflect.fs b/src/fsharp/FSharp.Core/reflect.fs index 027713b34ee..498cc0e01ad 100644 --- a/src/fsharp/FSharp.Core/reflect.fs +++ b/src/fsharp/FSharp.Core/reflect.fs @@ -132,69 +132,9 @@ module internal Impl = //----------------------------------------------------------------- // UNION DECOMPILATION - // Get the type where the type definitions are stored - let getUnionCasesTyp (typ: Type, _bindingFlags) = -#if CASES_IN_NESTED_CLASS - let casesTyp = typ.GetNestedType("Cases", bindingFlags) - if casesTyp.IsGenericTypeDefinition then casesTyp.MakeGenericType(typ.GetGenericArguments()) - else casesTyp -#else - typ -#endif - - let getUnionTypeTagNameMap (typ:Type,bindingFlags) = - let enumTyp = typ.GetNestedType("Tags", bindingFlags) - // Unions with a singleton case do not get a Tags type (since there is only one tag), hence enumTyp may be null in this case - match enumTyp with - | null -> - typ.GetMethods(staticMethodFlags ||| bindingFlags) - |> Array.choose (fun minfo -> - match tryFindCompilationMappingAttributeFromMemberInfo(minfo) with - | None -> None - | Some (flags,n,_vn) -> - if (flags &&& SourceConstructFlags.KindMask) = SourceConstructFlags.UnionCase then - let nm = minfo.Name - // chop "get_" or "New" off the front - let nm = - if not (isListType typ) && not (isOptionType typ) then - if nm.Length > 4 && nm.[0..3] = "get_" then nm.[4..] - elif nm.Length > 3 && nm.[0..2] = "New" then nm.[3..] - else nm - else nm - Some (n, nm) - else - None) - | _ -> - enumTyp.GetFields(staticFieldFlags ||| bindingFlags) - |> Array.filter (fun (f:FieldInfo) -> f.IsStatic && f.IsLiteral) - |> sortFreshArray (fun f1 f2 -> compare (f1.GetValue(null) :?> int) (f2.GetValue(null) :?> int)) - |> Array.map (fun tagfield -> (tagfield.GetValue(null) :?> int),tagfield.Name) - - let getUnionCaseTyp (typ: Type, tag: int, bindingFlags) = - let tagFields = getUnionTypeTagNameMap(typ,bindingFlags) - let tagField = tagFields |> Array.pick (fun (i,f) -> if i = tag then Some f else None) - if tagFields.Length = 1 then - typ - else - // special case: two-cased DU annotated with CompilationRepresentation(UseNullAsTrueValue) - // in this case it will be compiled as one class: return self type for non-nullary case and null for nullary - let isTwoCasedDU = - if tagFields.Length = 2 then - match typ.GetCustomAttributes(typeof, false) with - | [|:? CompilationRepresentationAttribute as attr|] -> - (attr.Flags &&& CompilationRepresentationFlags.UseNullAsTrueValue) = CompilationRepresentationFlags.UseNullAsTrueValue - | _ -> false - else - false - if isTwoCasedDU then - typ - else - let casesTyp = getUnionCasesTyp (typ, bindingFlags) - let caseTyp = casesTyp.GetNestedType(tagField, bindingFlags) // if this is null then the union is nullary - match caseTyp with - | null -> null - | _ when caseTyp.IsGenericTypeDefinition -> caseTyp.MakeGenericType(casesTyp.GetGenericArguments()) - | _ -> caseTyp + let getUnionTypeTagNameMap (typ:Type,bindingFlags) = LanguagePrimitives.Reflection.getUnionTypeTagNameMap (typ, bindingFlags) + + let getUnionCaseTyp (typ: Type, tag: int, bindingFlags) = LanguagePrimitives.Reflection.getUnionCaseTyp (typ, tag, bindingFlags) let getUnionTagConverter (typ:Type,bindingFlags) = if isOptionType typ then (fun tag -> match tag with 0 -> "None" | 1 -> "Some" | _ -> invalidArg "tag" (SR.GetString(SR.outOfRange))) @@ -232,14 +172,7 @@ module internal Impl = | 1 (* Cons *) -> getInstancePropertyInfos (typ,[| "Head"; "Tail" |],bindingFlags) | _ -> failwith "fieldsPropsOfUnionCase" else - // Lookup the type holding the fields for the union case - let caseTyp = getUnionCaseTyp (typ, tag, bindingFlags) - let caseTyp = match caseTyp with null -> typ | _ -> caseTyp - caseTyp.GetProperties(instancePropertyFlags ||| bindingFlags) - |> Array.filter isFieldProperty - |> Array.filter (fun prop -> variantNumberOfMember prop = tag) - |> sortFreshArray (fun p1 p2 -> compare (sequenceNumberOfMember p1) (sequenceNumberOfMember p2)) - + LanguagePrimitives.Reflection.fieldsPropsOfUnionCase (typ, tag, bindingFlags) let getUnionCaseRecordReader (typ:Type,tag:int,bindingFlags) = let props = fieldsPropsOfUnionCase(typ,tag,bindingFlags) From 5c0785da309be57fd75407710bf5603e89cb4b23 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Mon, 9 Jul 2018 10:43:22 +1000 Subject: [PATCH 42/92] Removed methods from prim-types.fsi that are now just used internally --- src/fsharp/FSharp.Core/prim-types.fsi | 15 ---------- src/fsharp/FSharp.Core/reflect.fs | 41 --------------------------- 2 files changed, 56 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fsi b/src/fsharp/FSharp.Core/prim-types.fsi index 994495accbb..c233f80d23f 100644 --- a/src/fsharp/FSharp.Core/prim-types.fsi +++ b/src/fsharp/FSharp.Core/prim-types.fsi @@ -1242,25 +1242,10 @@ namespace Microsoft.FSharp.Core module internal Reflection = val internal tupleNames : string [] val internal isTupleType : Type -> bool - -#if !FX_NO_REFLECTION_ONLY - val internal tryFindCompilationMappingAttributeFromData : System.Collections.Generic.IList * byref -> bool - val internal findCompilationMappingAttributeFromData : System.Collections.Generic.IList -> SourceConstructFlags*int*int -#endif - - val internal tryFindCompilationMappingAttribute : obj[] * byref -> bool - val internal findCompilationMappingAttribute : obj[] -> SourceConstructFlags*int*int - val internal tryFindCompilationMappingAttributeFromType : Type * byref -> bool - val internal tryFindCompilationMappingAttributeFromMemberInfo : System.Reflection.MemberInfo * byref -> bool - val internal findCompilationMappingAttributeFromMemberInfo : System.Reflection.MemberInfo -> SourceConstructFlags*int*int val internal tryFindSourceConstructFlagsOfType : Type * byref -> bool - val internal sequenceNumberOfMember : System.Reflection.MemberInfo -> int - val internal variantNumberOfMember : System.Reflection.MemberInfo -> int - val internal isFieldProperty : System.Reflection.PropertyInfo -> bool val internal fieldPropsOfRecordType : Type * System.Reflection.BindingFlags -> System.Reflection.PropertyInfo[] val internal isRecordType : Type * System.Reflection.BindingFlags -> bool val internal getUnionTypeTagNameMap : Type * System.Reflection.BindingFlags -> (int*string)[] - val internal getUnionCaseTyp : Type * int * System.Reflection.BindingFlags -> Type val internal fieldsPropsOfUnionCase : Type * int* System.Reflection.BindingFlags -> System.Reflection.PropertyInfo[] val internal isUnionType : Type * System.Reflection.BindingFlags -> bool diff --git a/src/fsharp/FSharp.Core/reflect.fs b/src/fsharp/FSharp.Core/reflect.fs index 498cc0e01ad..ef019303f61 100644 --- a/src/fsharp/FSharp.Core/reflect.fs +++ b/src/fsharp/FSharp.Core/reflect.fs @@ -83,45 +83,6 @@ module internal Impl = //----------------------------------------------------------------- // ATTRIBUTE DECOMPILATION - let tryFindCompilationMappingAttribute (attrs:obj[]) = - let mutable result = Unchecked.defaultof<_> - if LanguagePrimitives.Reflection.tryFindCompilationMappingAttribute (attrs, &result) - then Some result - else None - - let findCompilationMappingAttribute (attrs:obj[]) = LanguagePrimitives.Reflection.findCompilationMappingAttribute attrs - -#if !FX_NO_REFLECTION_ONLY - let tryFindCompilationMappingAttributeFromData (attrs:System.Collections.Generic.IList) = - let mutable result = Unchecked.defaultof<_> - if LanguagePrimitives.Reflection.tryFindCompilationMappingAttributeFromData (attrs, &result) - then Some result - else None - - let findCompilationMappingAttributeFromData attrs = LanguagePrimitives.Reflection.findCompilationMappingAttributeFromData attrs -#endif - - let tryFindCompilationMappingAttributeFromType (typ:Type) = - let mutable result = Unchecked.defaultof<_> - if LanguagePrimitives.Reflection.tryFindCompilationMappingAttributeFromType (typ, &result) - then Some result - else None - - let tryFindCompilationMappingAttributeFromMemberInfo (info:MemberInfo) = - let mutable result = Unchecked.defaultof<_> - if LanguagePrimitives.Reflection.tryFindCompilationMappingAttributeFromMemberInfo (info, &result) - then Some result - else None - - let findCompilationMappingAttributeFromMemberInfo (info:MemberInfo) = LanguagePrimitives.Reflection.findCompilationMappingAttributeFromMemberInfo info - - let sequenceNumberOfMember (x:MemberInfo) = LanguagePrimitives.Reflection.sequenceNumberOfMember x - let variantNumberOfMember (x:MemberInfo) = LanguagePrimitives.Reflection.variantNumberOfMember x - - let sortFreshArray f arr = Array.sortInPlaceWith f arr; arr - - let isFieldProperty (prop : PropertyInfo) = LanguagePrimitives.Reflection.isFieldProperty prop - let tryFindSourceConstructFlagsOfType (typ:Type) = let mutable res = Unchecked.defaultof<_> if LanguagePrimitives.Reflection.tryFindSourceConstructFlagsOfType (typ, &res) then @@ -134,8 +95,6 @@ module internal Impl = let getUnionTypeTagNameMap (typ:Type,bindingFlags) = LanguagePrimitives.Reflection.getUnionTypeTagNameMap (typ, bindingFlags) - let getUnionCaseTyp (typ: Type, tag: int, bindingFlags) = LanguagePrimitives.Reflection.getUnionCaseTyp (typ, tag, bindingFlags) - let getUnionTagConverter (typ:Type,bindingFlags) = if isOptionType typ then (fun tag -> match tag with 0 -> "None" | 1 -> "Some" | _ -> invalidArg "tag" (SR.GetString(SR.outOfRange))) elif isListType typ then (fun tag -> match tag with 0 -> "Empty" | 1 -> "Cons" | _ -> invalidArg "tag" (SR.GetString(SR.outOfRange))) From 951a3bee88b9c6cf8595f5ae55e5009460237a5f Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Mon, 9 Jul 2018 14:49:54 +1000 Subject: [PATCH 43/92] Used the reflection functions to handle records and unions --- src/fsharp/FSharp.Core/prim-types.fs | 179 +++++++++++++-------------- 1 file changed, 85 insertions(+), 94 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index 30fedc7b044..534ca97e9cb 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -953,6 +953,13 @@ namespace Microsoft.FSharp.Core | false -> raise (Exception "no compilation mapping attribute") | true -> x #endif + let hasCustomEquality (typ:Type) = + let arr = typ.GetCustomAttributes (typeof, false) + arr.Length > 0 + + let hasCustomComparison (typ:Type) = + let arr = typ.GetCustomAttributes (typeof, false) + arr.Length > 0 let tryFindCompilationMappingAttribute (attrs:obj[], res:byref) : bool = match attrs with @@ -1128,7 +1135,79 @@ namespace Microsoft.FSharp.Core else true) - module HashCompare = + module HashCompare = +#if FX_RESHAPED_REFLECTION + open Reflection.SystemAdapters +#endif + let isArray (ty:Type) = + ty.IsArray || (typeof.IsAssignableFrom ty) + + let canUseDotnetDefaultComparisonOrEquality isCustom hasStructuralInterface stringsRequireHandling er (rootType:Type) = + let processed = System.Collections.Generic.HashSet () + + let bindingPublicOrNonPublic = + Reflection.flagsOr BindingFlags.Public BindingFlags.NonPublic + + let rec isSuitableNullableTypeOrNotNullable (ty:Type) = + // although nullables not explicitly handled previously, they need special handling + // due to the implicit casting to their underlying generic type (i.e. could be a float) + let isNullableType = + ty.IsGenericType + && ty.GetGenericTypeDefinition().Equals typedefof> + if isNullableType then + checkType 0 (ty.GetGenericArguments ()) + else + true + + and isSuitableTupleType (ty:Type) = + Reflection.isTupleType ty + && ty.IsValueType // Tuple<...> don't have implementation, but ValueTuple<...> does + && checkType 0 (ty.GetGenericArguments ()) + + and isSuitableRecordType (ty:Type) = + Reflection.isRecordType (ty, bindingPublicOrNonPublic) && + (not (isCustom ty)) && + ( let fields = Reflection.fieldPropsOfRecordType (ty, bindingPublicOrNonPublic) + let fieldTypes = Array.ConvertAll (fields, Converter (fun f -> f.PropertyType)) + checkType 0 fieldTypes) + + and isSuitableUnionType (ty:Type) = + Reflection.isUnionType (ty, bindingPublicOrNonPublic) && + (not (isCustom ty)) && + ( let cases = Reflection.getUnionTypeTagNameMap (ty, bindingPublicOrNonPublic) + let rec checkCases idx = + if idx = cases.Length then true + else + let tag,_ = get cases idx + let fields = Reflection.fieldsPropsOfUnionCase (ty, tag, bindingPublicOrNonPublic) + let fieldTypes = Array.ConvertAll (fields, Converter (fun f -> f.PropertyType)) + if checkType 0 fieldTypes then + checkCases (idx+1) + else + false + checkCases 0) + + and checkType idx (types:Type[]) = + if idx = types.Length then true + else + let ty = get types idx + if not (processed.Add ty) then + checkType (idx+1) types + else + ty.IsSealed // covers enum and value types; derived ref types might implement from hasStructuralInterface + && not (isArray ty) + && (not stringsRequireHandling || (not (ty.Equals typeof))) + && (er || (not (ty.Equals typeof))) + && (er || (not (ty.Equals typeof))) + && isSuitableNullableTypeOrNotNullable ty + && ( isSuitableTupleType ty + || isSuitableRecordType ty + || isSuitableUnionType ty + || not (hasStructuralInterface ty)) + && checkType (idx+1) types + + checkType 0 [|rootType|] + //------------------------------------------------------------------------- // LanguagePrimitives.HashCompare: HASHING. //------------------------------------------------------------------------- @@ -1495,55 +1574,10 @@ namespace Microsoft.FSharp.Core let isStructuralComparable (ty:Type) = typeof.IsAssignableFrom ty let isValueTypeStructuralComparable (ty:Type) = isStructuralComparable ty && ty.IsValueType - let isArray (ty:Type) = ty.IsArray || (typeof.IsAssignableFrom ty) - let canUseDefaultComparer er (rootType:Type) = - let processed = System.Collections.Generic.HashSet () - - let rec checkType idx (types:Type[]) = - if idx = types.Length then true - else - let ty = get types idx - if not (processed.Add ty) then - checkType (idx+1) types - else - let isValidGenericType ifNotType fullname = - if not (ty.IsGenericType && ty.GetGenericTypeDefinition().FullName.Equals fullname) - then ifNotType - else checkType 0 (ty.GetGenericArguments ()) - let isTypeAndGenericArgumentsOK fullname = isValidGenericType false fullname - let isNotTypeOrIsTypeAndGenericArgumentsOK fullname = isValidGenericType true fullname - - // avoid any types that need special handling in GenericEqualityObj - // GenericEqualityObj handles string as a special cases, but internally routes to same equality - - ty.IsSealed // covers enum and value types - // ref types need to be sealed as derived class might implement IStructuralEquatable - && not (isArray ty) - && not (ty.Equals typeof) - && (er || (not (ty.Equals typeof))) - && (er || (not (ty.Equals typeof))) - && isNotTypeOrIsTypeAndGenericArgumentsOK "System.Nullable`1" - && not (isStructuralComparable ty - // we accept ValueTuple even though it supports IStructuralEquatable - // if all generic arguements pass check - && not ( isTypeAndGenericArgumentsOK "System.ValueTuple`1" - || isTypeAndGenericArgumentsOK "System.ValueTuple`2" - || isTypeAndGenericArgumentsOK "System.ValueTuple`3" - || isTypeAndGenericArgumentsOK "System.ValueTuple`4" - || isTypeAndGenericArgumentsOK "System.ValueTuple`5" - || isTypeAndGenericArgumentsOK "System.ValueTuple`6" - || isTypeAndGenericArgumentsOK "System.ValueTuple`7" - || isTypeAndGenericArgumentsOK "System.ValueTuple`8" - || isTypeAndGenericArgumentsOK "Microsoft.FSharp.Collections.FSharpList`1" - || isTypeAndGenericArgumentsOK "Microsoft.FSharp.Core.FSharpOption`1" - || isTypeAndGenericArgumentsOK "Microsoft.FSharp.Core.FSharpValueOption`1" - || isTypeAndGenericArgumentsOK "Microsoft.FSharp.Core.FSharpResult`2" - ) - ) - && checkType (idx+1) types - - checkType 0 [|rootType|] + let canUseDefaultComparer er (rootType:Type) = + // "Default" equality for strings is culturally sensitive, so needs special handling + canUseDotnetDefaultComparisonOrEquality Reflection.hasCustomComparison isStructuralComparable true er rootType type ComparisonUsage = | ERUsage = 0 @@ -2099,51 +2133,8 @@ namespace Microsoft.FSharp.Core let isValueTypeStructuralEquatable (ty:Type) = isStructuralEquatable ty && ty.IsValueType let canUseDefaultEqualityComparer er (rootType:Type) = - let processed = System.Collections.Generic.HashSet () - - let rec checkType idx (types:Type[]) = - if idx = types.Length then true - else - let ty = get types idx - if not (processed.Add ty) then - checkType (idx+1) types - else - let isValidGenericType ifNotType fullname = - if not (ty.IsGenericType && ty.GetGenericTypeDefinition().FullName.Equals fullname) - then ifNotType - else checkType 0 (ty.GetGenericArguments ()) - let isTypeAndGenericArgumentsOK fullname = isValidGenericType false fullname - let isNotTypeOrIsTypeAndGenericArgumentsOK fullname = isValidGenericType true fullname - - // avoid any types that need special handling in GenericEqualityObj - // GenericEqualityObj handles string as a special cases, but internally routes to same equality - - ty.IsSealed // covers enum and value types - // ref types need to be sealed as derived class might implement IStructuralEquatable - && not (isArray ty) - && (er || (not (ty.Equals typeof))) - && (er || (not (ty.Equals typeof))) - && isNotTypeOrIsTypeAndGenericArgumentsOK "System.Nullable`1" - && not (isStructuralEquatable ty - // we accept ValueTuple even though it supports IStructuralEquatable - // if all generic arguements pass check - && not ( isTypeAndGenericArgumentsOK "System.ValueTuple`1" - || isTypeAndGenericArgumentsOK "System.ValueTuple`2" - || isTypeAndGenericArgumentsOK "System.ValueTuple`3" - || isTypeAndGenericArgumentsOK "System.ValueTuple`4" - || isTypeAndGenericArgumentsOK "System.ValueTuple`5" - || isTypeAndGenericArgumentsOK "System.ValueTuple`6" - || isTypeAndGenericArgumentsOK "System.ValueTuple`7" - || isTypeAndGenericArgumentsOK "System.ValueTuple`8" - || isTypeAndGenericArgumentsOK "Microsoft.FSharp.Collections.FSharpList`1" - || isTypeAndGenericArgumentsOK "Microsoft.FSharp.Core.FSharpOption`1" - || isTypeAndGenericArgumentsOK "Microsoft.FSharp.Core.FSharpValueOption`1" - || isTypeAndGenericArgumentsOK "Microsoft.FSharp.Core.FSharpResult`2" - ) - ) - && checkType (idx+1) types - - checkType 0 [|rootType|] + // "Default" equality for strings is by ordinal, so needs special handling required + canUseDotnetDefaultComparisonOrEquality Reflection.hasCustomEquality isStructuralEquatable false er rootType let tryGetFSharpEqualityComparer (er:bool) (ty:Type) : obj = match er, ty with From 12372c54f99993fe3d624ea316d00a46df6003f1 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Mon, 9 Jul 2018 18:44:10 +1000 Subject: [PATCH 44/92] Added check for fsharp value types --- src/fsharp/FSharp.Core/prim-types.fs | 42 +++++++++++++++++++--------- 1 file changed, 29 insertions(+), 13 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index 534ca97e9cb..d90150a41bb 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -825,6 +825,13 @@ namespace Microsoft.FSharp.Core f () f () + member this.GetConstructors(bindingFlags) = + // type initializer will also be included in resultset + let constructors = this.GetTypeInfo().DeclaredConstructors + + Array.FindAll (toArray constructors, Predicate (fun ci -> + isAcceptable bindingFlags ci.IsStatic ci.IsPublic)) + // use different sources based on Declared flag member this.GetMethods (bindingFlags) = let methods = @@ -1011,18 +1018,22 @@ namespace Microsoft.FSharp.Core else false - let isRecordType (typ:Type, bindingFlags:BindingFlags) = + let isKnownType (typ:Type, bindingFlags:BindingFlags, knownType:SourceConstructFlags) = let mutable flags = unsafeDefault<_> match tryFindSourceConstructFlagsOfType (typ, &flags) with | false -> false | true -> - (flagsContains flags SourceConstructFlags.KindMask SourceConstructFlags.RecordType) && + (flagsContains flags SourceConstructFlags.KindMask knownType) && // We see private representations only if BindingFlags.NonPublic is set (if flagsIsSet flags SourceConstructFlags.NonPublicRepresentation then flagsIsSet bindingFlags BindingFlags.NonPublic else true) + let isRecordType (typ:Type, bindingFlags:BindingFlags) = isKnownType (typ, bindingFlags, SourceConstructFlags.RecordType) + let isObjectType (typ:Type, bindingFlags:BindingFlags) = isKnownType (typ, bindingFlags, SourceConstructFlags.ObjectType) + let isUnionType (typ:Type, bindingFlags:BindingFlags) = isKnownType (typ, bindingFlags, SourceConstructFlags.SumType) + let isFieldProperty (prop : PropertyInfo) = let mutable res = unsafeDefault<_> match tryFindCompilationMappingAttributeFromMemberInfo(prop:>MemberInfo, &res) with @@ -1123,17 +1134,13 @@ namespace Microsoft.FSharp.Core let filtered = Array.FindAll (properties, Predicate (fun p -> if isFieldProperty p then (variantNumberOfMember (p:>MemberInfo)) = tag else false)) sortFreshArray (fun (p:PropertyInfo) -> sequenceNumberOfMember p) filtered - let isUnionType (typ:Type,bindingFlags:BindingFlags) = - let mutable flags = unsafeDefault<_> - match tryFindSourceConstructFlagsOfType(typ, &flags) with - | false -> false - | true -> - (flagsContains flags SourceConstructFlags.KindMask SourceConstructFlags.SumType) && - // We see private representations only if BindingFlags.NonPublic is set - (if flagsIsSet flags SourceConstructFlags.NonPublicRepresentation then - flagsIsSet bindingFlags BindingFlags.NonPublic - else - true) + let tryGetSingleConstructorArgumentTypes (typ:Type, types:byref) = + match typ.GetConstructors (flagsOr BindingFlags.Instance (flagsOr BindingFlags.Public BindingFlags.NonPublic)) with + | [| single |] -> + types <- Array.ConvertAll (single.GetParameters (), Converter (fun p -> p.ParameterType)) + true + | _ -> + false module HashCompare = #if FX_RESHAPED_REFLECTION @@ -1164,6 +1171,14 @@ namespace Microsoft.FSharp.Core && ty.IsValueType // Tuple<...> don't have implementation, but ValueTuple<...> does && checkType 0 (ty.GetGenericArguments ()) + and isSuitableStructType (ty:Type) = + Reflection.isObjectType (ty, bindingPublicOrNonPublic) && + ty.IsValueType && + (not (isCustom ty)) && + ( let mutable types = unsafeDefault<_> + Reflection.tryGetSingleConstructorArgumentTypes (ty, &types) + && checkType 0 types) + and isSuitableRecordType (ty:Type) = Reflection.isRecordType (ty, bindingPublicOrNonPublic) && (not (isCustom ty)) && @@ -1201,6 +1216,7 @@ namespace Microsoft.FSharp.Core && (er || (not (ty.Equals typeof))) && isSuitableNullableTypeOrNotNullable ty && ( isSuitableTupleType ty + || isSuitableStructType ty || isSuitableRecordType ty || isSuitableUnionType ty || not (hasStructuralInterface ty)) From 3887b727e6edbe943bcb0d33e0672f62a9cf8aa4 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Tue, 10 Jul 2018 16:36:25 +1000 Subject: [PATCH 45/92] Fixed struct check where a [] field is used. --- src/fsharp/FSharp.Core/prim-types.fs | 21 ++++----------------- 1 file changed, 4 insertions(+), 17 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index d90150a41bb..ce3c3c61dbe 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -825,13 +825,6 @@ namespace Microsoft.FSharp.Core f () f () - member this.GetConstructors(bindingFlags) = - // type initializer will also be included in resultset - let constructors = this.GetTypeInfo().DeclaredConstructors - - Array.FindAll (toArray constructors, Predicate (fun ci -> - isAcceptable bindingFlags ci.IsStatic ci.IsPublic)) - // use different sources based on Declared flag member this.GetMethods (bindingFlags) = let methods = @@ -1134,13 +1127,9 @@ namespace Microsoft.FSharp.Core let filtered = Array.FindAll (properties, Predicate (fun p -> if isFieldProperty p then (variantNumberOfMember (p:>MemberInfo)) = tag else false)) sortFreshArray (fun (p:PropertyInfo) -> sequenceNumberOfMember p) filtered - let tryGetSingleConstructorArgumentTypes (typ:Type, types:byref) = - match typ.GetConstructors (flagsOr BindingFlags.Instance (flagsOr BindingFlags.Public BindingFlags.NonPublic)) with - | [| single |] -> - types <- Array.ConvertAll (single.GetParameters (), Converter (fun p -> p.ParameterType)) - true - | _ -> - false + let getAllInstanceFields (typ:Type) = + let fields = typ.GetFields (flagsOr BindingFlags.Instance (flagsOr BindingFlags.Public BindingFlags.NonPublic)) + Array.ConvertAll (fields, Converter (fun p -> p.FieldType)) module HashCompare = #if FX_RESHAPED_REFLECTION @@ -1175,9 +1164,7 @@ namespace Microsoft.FSharp.Core Reflection.isObjectType (ty, bindingPublicOrNonPublic) && ty.IsValueType && (not (isCustom ty)) && - ( let mutable types = unsafeDefault<_> - Reflection.tryGetSingleConstructorArgumentTypes (ty, &types) - && checkType 0 types) + checkType 0 (Reflection.getAllInstanceFields ty) and isSuitableRecordType (ty:Type) = Reflection.isRecordType (ty, bindingPublicOrNonPublic) && From 225e3efa5720d08bb96590f002f7ae3ce2aae1d9 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Wed, 11 Jul 2018 18:47:19 +1000 Subject: [PATCH 46/92] Minor shift in logic order for less comparisons --- src/fsharp/FSharp.Core/prim-types.fs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index ce3c3c61dbe..14e82785bdc 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -1156,13 +1156,13 @@ namespace Microsoft.FSharp.Core true and isSuitableTupleType (ty:Type) = - Reflection.isTupleType ty - && ty.IsValueType // Tuple<...> don't have implementation, but ValueTuple<...> does - && checkType 0 (ty.GetGenericArguments ()) + ty.IsValueType && // Tuple<...> don't have implementation, but ValueTuple<...> does + Reflection.isTupleType ty && + checkType 0 (ty.GetGenericArguments ()) and isSuitableStructType (ty:Type) = - Reflection.isObjectType (ty, bindingPublicOrNonPublic) && ty.IsValueType && + Reflection.isObjectType (ty, bindingPublicOrNonPublic) && (not (isCustom ty)) && checkType 0 (Reflection.getAllInstanceFields ty) @@ -1202,11 +1202,11 @@ namespace Microsoft.FSharp.Core && (er || (not (ty.Equals typeof))) && (er || (not (ty.Equals typeof))) && isSuitableNullableTypeOrNotNullable ty - && ( isSuitableTupleType ty + && ((not (hasStructuralInterface ty)) + || isSuitableTupleType ty || isSuitableStructType ty || isSuitableRecordType ty - || isSuitableUnionType ty - || not (hasStructuralInterface ty)) + || isSuitableUnionType ty) && checkType (idx+1) types checkType 0 [|rootType|] From b0b64f633b2a1d597443c534aeb3fd2dd8f37daf Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Thu, 19 Jul 2018 16:07:53 +1000 Subject: [PATCH 47/92] Removed MapOne case for performance. Now with only two cases, one of which can be represented as null due to [], no type checking or casting needs to be performed on each node access. This does come at the expense of more memory usage, where each leaf node now carries an extra (2*sizeof+sizeof) --- src/fsharp/FSharp.Core/map.fs | 57 ++++++----------------------------- 1 file changed, 10 insertions(+), 47 deletions(-) diff --git a/src/fsharp/FSharp.Core/map.fs b/src/fsharp/FSharp.Core/map.fs index 97c747e4ae5..02c5559bb78 100644 --- a/src/fsharp/FSharp.Core/map.fs +++ b/src/fsharp/FSharp.Core/map.fs @@ -12,10 +12,7 @@ namespace Microsoft.FSharp.Collections [] type MapTree<'Key,'Value when 'Key : comparison > = | MapEmpty - | MapOne of 'Key * 'Value | MapNode of 'Key * 'Value * MapTree<'Key,'Value> * MapTree<'Key,'Value> * int - // REVIEW: performance rumour has it that the data held in MapNode and MapOne should be - // exactly one cache line. It is currently ~7 and 4 words respectively. [] module MapTree = @@ -23,12 +20,10 @@ namespace Microsoft.FSharp.Collections let rec sizeAux acc m = match m with | MapEmpty -> acc - | MapOne _ -> acc + 1 | MapNode(_,_,l,r,_) -> sizeAux (sizeAux (acc+1) l) r let size x = sizeAux 0 x - #if TRACE_SETS_AND_MAPS let mutable traceCount = 0 let mutable numOnes = 0 @@ -64,9 +59,10 @@ namespace Microsoft.FSharp.Collections let empty = MapEmpty + let makeLeafNode k v = MapNode(k,v,MapEmpty,MapEmpty,1) + let height = function | MapEmpty -> 0 - | MapOne _ -> 1 | MapNode(_,_,_,_,h) -> h let isEmpty m = @@ -76,7 +72,7 @@ namespace Microsoft.FSharp.Collections let mk l k v r = match l,r with - | MapEmpty,MapEmpty -> MapOne(k,v) + | MapEmpty,MapEmpty -> makeLeafNode k v | _ -> let hl = height l let hr = height r @@ -116,12 +112,7 @@ namespace Microsoft.FSharp.Collections let rec add (comparer: IComparer<'Value>) k v m = match m with - | MapEmpty -> MapOne(k,v) - | MapOne(k2,_) -> - let c = comparer.Compare(k,k2) - if c < 0 then MapNode (k,v,MapEmpty,m,2) - elif c = 0 then MapOne(k,v) - else MapNode (k,v,m,MapEmpty,2) + | MapEmpty -> makeLeafNode k v | MapNode(k2,v2,l,r,h) -> let c = comparer.Compare(k,k2) if c < 0 then rebalance (add comparer k v l) k2 v2 r @@ -131,10 +122,6 @@ namespace Microsoft.FSharp.Collections let rec find (comparer: IComparer<'Value>) k m = match m with | MapEmpty -> raise (KeyNotFoundException()) - | MapOne(k2,v2) -> - let c = comparer.Compare(k,k2) - if c = 0 then v2 - else raise (KeyNotFoundException()) | MapNode(k2,v2,l,r,_) -> let c = comparer.Compare(k,k2) if c < 0 then find comparer k l @@ -144,10 +131,6 @@ namespace Microsoft.FSharp.Collections let rec tryFind (comparer: IComparer<'Value>) k m = match m with | MapEmpty -> None - | MapOne(k2,v2) -> - let c = comparer.Compare(k,k2) - if c = 0 then Some v2 - else None | MapNode(k2,v2,l,r,_) -> let c = comparer.Compare(k,k2) if c < 0 then tryFind comparer k l @@ -160,7 +143,6 @@ namespace Microsoft.FSharp.Collections let rec partitionAux (comparer: IComparer<'Value>) (f:OptimizedClosures.FSharpFunc<_,_,_>) s acc = match s with | MapEmpty -> acc - | MapOne(k,v) -> partition1 comparer f k v acc | MapNode(k,v,l,r,_) -> let acc = partitionAux comparer f r acc let acc = partition1 comparer f k v acc @@ -173,7 +155,6 @@ namespace Microsoft.FSharp.Collections let rec filterAux (comparer: IComparer<'Value>) (f:OptimizedClosures.FSharpFunc<_,_,_>) s acc = match s with | MapEmpty -> acc - | MapOne(k,v) -> filter1 comparer f k v acc | MapNode(k,v,l,r,_) -> let acc = filterAux comparer f l acc let acc = filter1 comparer f k v acc @@ -184,7 +165,6 @@ namespace Microsoft.FSharp.Collections let rec spliceOutSuccessor m = match m with | MapEmpty -> failwith "internal error: Map.spliceOutSuccessor" - | MapOne(k2,v2) -> k2,v2,MapEmpty | MapNode(k2,v2,l,r,_) -> match l with | MapEmpty -> k2,v2,r @@ -193,9 +173,6 @@ namespace Microsoft.FSharp.Collections let rec remove (comparer: IComparer<'Value>) k m = match m with | MapEmpty -> empty - | MapOne(k2,_) -> - let c = comparer.Compare(k,k2) - if c = 0 then MapEmpty else m | MapNode(k2,v2,l,r,_) -> let c = comparer.Compare(k,k2) if c < 0 then rebalance (remove comparer k l) k2 v2 r @@ -211,7 +188,6 @@ namespace Microsoft.FSharp.Collections let rec mem (comparer: IComparer<'Value>) k m = match m with | MapEmpty -> false - | MapOne(k2,_) -> (comparer.Compare(k,k2) = 0) | MapNode(k2,_,l,r,_) -> let c = comparer.Compare(k,k2) if c < 0 then mem comparer k l @@ -220,7 +196,6 @@ namespace Microsoft.FSharp.Collections let rec iterOpt (f:OptimizedClosures.FSharpFunc<_,_,_>) m = match m with | MapEmpty -> () - | MapOne(k2,v2) -> f.Invoke(k2, v2) | MapNode(k2,v2,l,r,_) -> iterOpt f l; f.Invoke(k2, v2); iterOpt f r let iter f m = iterOpt (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) m @@ -228,7 +203,6 @@ namespace Microsoft.FSharp.Collections let rec tryPickOpt (f:OptimizedClosures.FSharpFunc<_,_,_>) m = match m with | MapEmpty -> None - | MapOne(k2,v2) -> f.Invoke(k2, v2) | MapNode(k2,v2,l,r,_) -> match tryPickOpt f l with | Some _ as res -> res @@ -243,7 +217,6 @@ namespace Microsoft.FSharp.Collections let rec existsOpt (f:OptimizedClosures.FSharpFunc<_,_,_>) m = match m with | MapEmpty -> false - | MapOne(k2,v2) -> f.Invoke(k2, v2) | MapNode(k2,v2,l,r,_) -> existsOpt f l || f.Invoke(k2, v2) || existsOpt f r let exists f m = existsOpt (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) m @@ -251,7 +224,6 @@ namespace Microsoft.FSharp.Collections let rec forallOpt (f:OptimizedClosures.FSharpFunc<_,_,_>) m = match m with | MapEmpty -> true - | MapOne(k2,v2) -> f.Invoke(k2, v2) | MapNode(k2,v2,l,r,_) -> forallOpt f l && f.Invoke(k2, v2) && forallOpt f r let forall f m = forallOpt (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) m @@ -259,7 +231,6 @@ namespace Microsoft.FSharp.Collections let rec map f m = match m with | MapEmpty -> empty - | MapOne(k,v) -> MapOne(k,f v) | MapNode(k,v,l,r,h) -> let l2 = map f l let v2 = f v @@ -269,7 +240,6 @@ namespace Microsoft.FSharp.Collections let rec mapiOpt (f:OptimizedClosures.FSharpFunc<_,_,_>) m = match m with | MapEmpty -> empty - | MapOne(k,v) -> MapOne(k, f.Invoke(k, v)) | MapNode(k,v,l,r,h) -> let l2 = mapiOpt f l let v2 = f.Invoke(k, v) @@ -281,7 +251,6 @@ namespace Microsoft.FSharp.Collections let rec foldBackOpt (f:OptimizedClosures.FSharpFunc<_,_,_,_>) m x = match m with | MapEmpty -> x - | MapOne(k,v) -> f.Invoke(k,v,x) | MapNode(k,v,l,r,_) -> let x = foldBackOpt f r x let x = f.Invoke(k,v,x) @@ -292,7 +261,6 @@ namespace Microsoft.FSharp.Collections let rec foldOpt (f:OptimizedClosures.FSharpFunc<_,_,_,_>) x m = match m with | MapEmpty -> x - | MapOne(k,v) -> f.Invoke(x,k,v) | MapNode(k,v,l,r,_) -> let x = foldOpt f x l let x = f.Invoke(x,k,v) @@ -304,11 +272,6 @@ namespace Microsoft.FSharp.Collections let rec foldFromTo (f:OptimizedClosures.FSharpFunc<_,_,_,_>) m x = match m with | MapEmpty -> x - | MapOne(k,v) -> - let cLoKey = comparer.Compare(lo,k) - let cKeyHi = comparer.Compare(k,hi) - let x = if cLoKey <= 0 && cKeyHi <= 0 then f.Invoke(k, v, x) else x - x | MapNode(k,v,l,r,_) -> let cLoKey = comparer.Compare(lo,k) let cKeyHi = comparer.Compare(k,hi) @@ -326,7 +289,6 @@ namespace Microsoft.FSharp.Collections let rec loop m acc = match m with | MapEmpty -> acc - | MapOne(k,v) -> (k,v)::acc | MapNode(k,v,l,r,_) -> loop l ((k,v)::loop r acc) loop m [] let toArray m = m |> toList |> Array.ofList @@ -373,8 +335,8 @@ namespace Microsoft.FSharp.Collections match stack with | [] -> [] | MapEmpty :: rest -> collapseLHS rest - | MapOne _ :: _ -> stack - | (MapNode(k,v,l,r,_)) :: rest -> collapseLHS (l :: MapOne (k,v) :: r :: rest) + | MapNode(_,_,MapEmpty,MapEmpty,_) :: _ -> stack + | (MapNode(k,v,l,r,_)) :: rest -> collapseLHS (l :: (makeLeafNode k v) :: r :: rest) let mkIterator s = { stack = collapseLHS [s]; started = false } @@ -384,7 +346,7 @@ namespace Microsoft.FSharp.Collections let current i = if i.started then match i.stack with - | MapOne (k,v) :: _ -> new KeyValuePair<_,_>(k,v) + | MapNode(k,v,MapEmpty,MapEmpty,_) :: _ -> new KeyValuePair<_,_>(k,v) | [] -> alreadyFinished() | _ -> failwith "Please report error: Map iterator, unexpected stack for current" else @@ -393,8 +355,9 @@ namespace Microsoft.FSharp.Collections let rec moveNext i = if i.started then match i.stack with - | MapOne _ :: rest -> i.stack <- collapseLHS rest - not i.stack.IsEmpty + | MapNode(_,_,MapEmpty,MapEmpty,_) :: rest -> + i.stack <- collapseLHS rest + not i.stack.IsEmpty | [] -> false | _ -> failwith "Please report error: Map iterator, unexpected stack for moveNext" else From cc3435f2b144c3ed99ced43e2c9422d79942b12e Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Fri, 20 Jul 2018 17:30:54 +1000 Subject: [PATCH 48/92] Converted Map.Count from O(n) to O(1) --- src/fsharp/FSharp.Core/map.fs | 44 +++++++++++++---------------------- 1 file changed, 16 insertions(+), 28 deletions(-) diff --git a/src/fsharp/FSharp.Core/map.fs b/src/fsharp/FSharp.Core/map.fs index 02c5559bb78..6a4a17ddd46 100644 --- a/src/fsharp/FSharp.Core/map.fs +++ b/src/fsharp/FSharp.Core/map.fs @@ -16,14 +16,6 @@ namespace Microsoft.FSharp.Collections [] module MapTree = - - let rec sizeAux acc m = - match m with - | MapEmpty -> acc - | MapNode(_,_,l,r,_) -> sizeAux (sizeAux (acc+1) l) r - - let size x = sizeAux 0 x - #if TRACE_SETS_AND_MAPS let mutable traceCount = 0 let mutable numOnes = 0 @@ -59,34 +51,30 @@ namespace Microsoft.FSharp.Collections let empty = MapEmpty - let makeLeafNode k v = MapNode(k,v,MapEmpty,MapEmpty,1) + let mkLeaf k v = + MapNode (k, v, MapEmpty, MapEmpty, 1) - let height = function - | MapEmpty -> 0 - | MapNode(_,_,_,_,h) -> h + let size x = + match x with + | MapEmpty -> 0 + | MapNode (_,_,_,_,h) -> h let isEmpty m = match m with | MapEmpty -> true | _ -> false - let mk l k v r = - match l,r with - | MapEmpty,MapEmpty -> makeLeafNode k v - | _ -> - let hl = height l - let hr = height r - let m = if hl < hr then hr else hl - MapNode(k,v,l,r,m+1) + let mk l k v r = + MapNode (k,v,l,r,size l + size r + 1) let rebalance t1 k v t2 = - let t1h = height t1 - let t2h = height t2 - if t2h > t1h + 2 then (* right is heavier than left *) + let t1h = size t1 + let t2h = size t2 + if (t2h >>> 1) > t1h then (* right is heavier than left *) match t2 with | MapNode(t2k,t2v,t2l,t2r,_) -> (* one of the nodes must have height > height t1 + 1 *) - if height t2l > t1h + 1 then (* balance left: combination *) + if size t2l > t1h then (* balance left: combination *) match t2l with | MapNode(t2lk,t2lv,t2ll,t2lr,_) -> mk (mk t1 k v t2ll) t2lk t2lv (mk t2lr t2k t2v t2r) @@ -95,11 +83,11 @@ namespace Microsoft.FSharp.Collections mk (mk t1 k v t2l) t2k t2v t2r | _ -> failwith "rebalance" else - if t1h > t2h + 2 then (* left is heavier than right *) + if (t1h >>> 1) > t2h then (* left is heavier than right *) match t1 with | MapNode(t1k,t1v,t1l,t1r,_) -> (* one of the nodes must have height > height t2 + 1 *) - if height t1r > t2h + 1 then + if size t1r > t2h then (* balance right: combination *) match t1r with | MapNode(t1rk,t1rv,t1rl,t1rr,_) -> @@ -112,7 +100,7 @@ namespace Microsoft.FSharp.Collections let rec add (comparer: IComparer<'Value>) k v m = match m with - | MapEmpty -> makeLeafNode k v + | MapEmpty -> mkLeaf k v | MapNode(k2,v2,l,r,h) -> let c = comparer.Compare(k,k2) if c < 0 then rebalance (add comparer k v l) k2 v2 r @@ -336,7 +324,7 @@ namespace Microsoft.FSharp.Collections | [] -> [] | MapEmpty :: rest -> collapseLHS rest | MapNode(_,_,MapEmpty,MapEmpty,_) :: _ -> stack - | (MapNode(k,v,l,r,_)) :: rest -> collapseLHS (l :: (makeLeafNode k v) :: r :: rest) + | (MapNode(k,v,l,r,_)) :: rest -> collapseLHS (l :: (mkLeaf k v) :: r :: rest) let mkIterator s = { stack = collapseLHS [s]; started = false } From c25e03801a85ee5e4f2cceb6b36df9cd8390e9ad Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sat, 21 Jul 2018 11:46:12 +1000 Subject: [PATCH 49/92] inlined mk/mkLeaf --- src/fsharp/FSharp.Core/map.fs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/fsharp/FSharp.Core/map.fs b/src/fsharp/FSharp.Core/map.fs index 6a4a17ddd46..3c93518507b 100644 --- a/src/fsharp/FSharp.Core/map.fs +++ b/src/fsharp/FSharp.Core/map.fs @@ -51,9 +51,6 @@ namespace Microsoft.FSharp.Collections let empty = MapEmpty - let mkLeaf k v = - MapNode (k, v, MapEmpty, MapEmpty, 1) - let size x = match x with | MapEmpty -> 0 @@ -64,8 +61,11 @@ namespace Microsoft.FSharp.Collections | MapEmpty -> true | _ -> false - let mk l k v r = - MapNode (k,v,l,r,size l + size r + 1) + let inline mk l k v r = + MapNode (k,v,l,r, size l + size r + 1) + + let inline mkLeaf k v = + MapNode (k, v, MapEmpty, MapEmpty, 1) let rebalance t1 k v t2 = let t1h = size t1 From a27cc2468e423fb9b7b7a89f7e87791fdf2ba64d Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sat, 21 Jul 2018 15:58:11 +1000 Subject: [PATCH 50/92] optimize ofSeq, ofList, ofArray via a temporary sorted ResizeArray and direct tree construction --- src/fsharp/FSharp.Core/local.fsi | 2 + src/fsharp/FSharp.Core/map.fs | 106 +++++++++++++++++++++++++++---- 2 files changed, 97 insertions(+), 11 deletions(-) diff --git a/src/fsharp/FSharp.Core/local.fsi b/src/fsharp/FSharp.Core/local.fsi index 3181dcbc6ec..3106c1bbc35 100644 --- a/src/fsharp/FSharp.Core/local.fsi +++ b/src/fsharp/FSharp.Core/local.fsi @@ -101,3 +101,5 @@ module internal Array = val stableSortInPlaceWith: comparer:('T -> 'T -> int) -> array:'T[] -> unit val stableSortInPlace: array:'T[] -> unit when 'T : comparison + + val stableSortWithKeysAndComparer : System.Collections.Generic.IComparer<'Key> -> array<'T> -> array<'Key> -> unit when 'Key : comparison \ No newline at end of file diff --git a/src/fsharp/FSharp.Core/map.fs b/src/fsharp/FSharp.Core/map.fs index 3c93518507b..81e1b2f66bc 100644 --- a/src/fsharp/FSharp.Core/map.fs +++ b/src/fsharp/FSharp.Core/map.fs @@ -273,26 +273,110 @@ namespace Microsoft.FSharp.Collections let foldSection (comparer: IComparer<'Value>) lo hi f m x = foldSectionOpt comparer lo hi (OptimizedClosures.FSharpFunc<_,_,_,_>.Adapt(f)) m x + // create a mapping function which indexes the array, but with duplicate values removed + let private getLatestAccessor (comparer:IComparer<'Key>) (keys:IReadOnlyList<'Key>) (array:IReadOnlyList<'T>) = + let rec getFirstDuplicateKey i = + if i >= array.Count-1 then None + elif comparer.Compare (keys.[i], keys.[i+1]) = 0 then Some i + else getFirstDuplicateKey (i+1) + + match getFirstDuplicateKey 0 with + | None -> (fun i -> array.[i]), array.Count + | Some idx -> + let indexes = ResizeArray (array.Count-idx) + indexes.Add (idx+1) + for i = idx+2 to array.Count-1 do + if comparer.Compare (keys.[i-1], keys.[i]) = 0 then + indexes.[indexes.Count-1] <- i + else + indexes.Add i + (fun i -> if i < idx then array.[i] else array.[indexes.[i-idx]]), idx+indexes.Count + + let constructViaArray comparer (data:seq<'Key*'Value>) = + let array = data |> Seq.toArray + if array.Length = 0 then MapEmpty + else + let keys = array |> Array.map fst + + Microsoft.FSharp.Primitives.Basics.Array.stableSortWithKeysAndComparer comparer array keys + + let getKV, count = + getLatestAccessor comparer keys array + + let rec loop lower upper = + assert (lower <= upper) + let mid = lower + (upper-lower)/2 + let k,v = getKV mid + if mid = upper then + mkLeaf k v + else + let right = loop (mid+1) upper + if mid = lower then + mk MapEmpty k v right + else + let left = loop lower (mid-1) + mk left k v right + + loop 0 (count-1) + let toList m = let rec loop m acc = match m with | MapEmpty -> acc | MapNode(k,v,l,r,_) -> loop l ((k,v)::loop r acc) loop m [] + let toArray m = m |> toList |> Array.ofList - let ofList comparer l = List.fold (fun acc (k,v) -> add comparer k v acc) empty l - let rec mkFromEnumerator comparer acc (e : IEnumerator<_>) = - if e.MoveNext() then - let (x,y) = e.Current - mkFromEnumerator comparer (add comparer x y acc) e - else acc + [] + let largeObjectHeapBytes = 85000 + + let maxInitializationObjectCount<'Key, 'Value> () = + largeObjectHeapBytes * 10 / 9 / sizeof<'Key*'Value> / 2 + + let ofList comparer (l:list<'Key*'Value>) = + if l |> List.isEmpty then empty + else + let chunk = ResizeArray () + let maxCount = maxInitializationObjectCount<'Key, 'Value> () + let rec populate x = + match x with + | [] -> x + | hd::tl -> + chunk.Add hd + if chunk.Count = maxCount then tl + else populate tl + let remainder = populate l + let chunkTree = constructViaArray comparer chunk + remainder |> List.fold (fun acc (k,v) -> add comparer k v acc) chunkTree + + let ofSeqlImpl comparer (e:IEnumerator<'Key*'Value>) = + if not (e.MoveNext()) then empty + else + let chunk = ResizeArray () + let maxCount = maxInitializationObjectCount<'Key, 'Value> () + let rec populate () = + chunk.Add e.Current + if chunk.Count = maxCount then true + elif e.MoveNext () then populate () + else false + + let more = populate () + let chunkTree = constructViaArray comparer chunk + + if not more then + chunkTree + else + let rec addRemainder acc = + if e.MoveNext () then + let x, y = e.Current + addRemainder (add comparer x y acc) + else + acc + addRemainder chunkTree let ofArray comparer (arr : array<_>) = - let mutable res = empty - for (x,y) in arr do - res <- add comparer x y res - res + constructViaArray comparer arr let ofSeq comparer (c : seq<'Key * 'T>) = match c with @@ -300,7 +384,7 @@ namespace Microsoft.FSharp.Collections | :? list<'Key * 'T> as xs -> ofList comparer xs | _ -> use ie = c.GetEnumerator() - mkFromEnumerator comparer empty ie + ofSeqlImpl comparer ie let copyToArray s (arr: _[]) i = From 16ba0ac06c5d86e68a9c064bbcd9379947a2d419 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Tue, 24 Jul 2018 17:39:43 +1000 Subject: [PATCH 51/92] Split rebalance so as to inline decision logic --- src/fsharp/FSharp.Core/map.fs | 68 +++++++++++++++++------------------ 1 file changed, 34 insertions(+), 34 deletions(-) diff --git a/src/fsharp/FSharp.Core/map.fs b/src/fsharp/FSharp.Core/map.fs index 81e1b2f66bc..a7266013c6c 100644 --- a/src/fsharp/FSharp.Core/map.fs +++ b/src/fsharp/FSharp.Core/map.fs @@ -67,45 +67,45 @@ namespace Microsoft.FSharp.Collections let inline mkLeaf k v = MapNode (k, v, MapEmpty, MapEmpty, 1) - let rebalance t1 k v t2 = - let t1h = size t1 - let t2h = size t2 - if (t2h >>> 1) > t1h then (* right is heavier than left *) - match t2 with - | MapNode(t2k,t2v,t2l,t2r,_) -> - (* one of the nodes must have height > height t1 + 1 *) - if size t2l > t1h then (* balance left: combination *) - match t2l with - | MapNode(t2lk,t2lv,t2ll,t2lr,_) -> - mk (mk t1 k v t2ll) t2lk t2lv (mk t2lr t2k t2v t2r) - | _ -> failwith "rebalance" - else (* rotate left *) - mk (mk t1 k v t2l) t2k t2v t2r - | _ -> failwith "rebalance" - else - if (t1h >>> 1) > t2h then (* left is heavier than right *) - match t1 with - | MapNode(t1k,t1v,t1l,t1r,_) -> - (* one of the nodes must have height > height t2 + 1 *) - if size t1r > t2h then - (* balance right: combination *) - match t1r with - | MapNode(t1rk,t1rv,t1rl,t1rr,_) -> - mk (mk t1l t1k t1v t1rl) t1rk t1rv (mk t1rr k v t2) - | _ -> failwith "rebalance" - else - mk t1l t1k t1v (mk t1r k v t2) - | _ -> failwith "rebalance" - else mk t1 k v t2 + let private rebalanceRight l k v r = + match r with + | MapEmpty -> failwith "rebalance" + | MapNode(rk,rv,rl,rr,_) -> + (* one of the nodes must have height > height t1 + 1 *) + if size rl > size l then (* balance left: combination *) + match rl with + | MapEmpty -> failwith "rebalance" + | MapNode(rlk,rlv,rll,rlr,_) -> mk (mk l k v rll) rlk rlv (mk rlr rk rv rr) + else (* rotate left *) + mk (mk l k v rl) rk rv rr + + let private rebalanceLeft l k v r = + match l with + | MapEmpty -> failwith "rebalance" + | MapNode(lk,lv,ll,lr,_) -> + (* one of the nodes must have height > height t2 + 1 *) + if size lr > size r then + (* balance right: combination *) + match lr with + | MapEmpty -> failwith "rebalance" + | MapNode(lrk,lrv,lrl,lrr,_) -> mk (mk ll lk lv lrl) lrk lrv (mk lrr k v r) + else + mk ll lk lv (mk lr k v r) + + let inline rebalance l k v r = + let ls, rs = size l, size r + if (rs >>> 1) > ls then rebalanceRight l k v r + elif (ls >>> 1) > rs then rebalanceLeft l k v r + else MapNode (k,v,l,r, ls+rs+1) let rec add (comparer: IComparer<'Value>) k v m = match m with | MapEmpty -> mkLeaf k v - | MapNode(k2,v2,l,r,h) -> + | MapNode(k2,v2,l,r,s) -> let c = comparer.Compare(k,k2) - if c < 0 then rebalance (add comparer k v l) k2 v2 r - elif c = 0 then MapNode(k,v,l,r,h) - else rebalance l k2 v2 (add comparer k v r) + if c < 0 then rebalance (add comparer k v l) k2 v2 r + elif c > 0 then rebalance l k2 v2 (add comparer k v r) + else MapNode(k,v,l,r,s) let rec find (comparer: IComparer<'Value>) k m = match m with From 9bd6af7919785972e81e3ed69e608ef8dff127ea Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Thu, 26 Jul 2018 17:23:36 +1000 Subject: [PATCH 52/92] Removed MapEmpty --- src/fsharp/FSharp.Core/map.fs | 132 +++++++++++++++------------------- 1 file changed, 59 insertions(+), 73 deletions(-) diff --git a/src/fsharp/FSharp.Core/map.fs b/src/fsharp/FSharp.Core/map.fs index a7266013c6c..d7c7c0aefe1 100644 --- a/src/fsharp/FSharp.Core/map.fs +++ b/src/fsharp/FSharp.Core/map.fs @@ -8,10 +8,8 @@ namespace Microsoft.FSharp.Collections open Microsoft.FSharp.Core open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators - [] [] type MapTree<'Key,'Value when 'Key : comparison > = - | MapEmpty | MapNode of 'Key * 'Value * MapTree<'Key,'Value> * MapTree<'Key,'Value> * int [] @@ -49,48 +47,37 @@ namespace Microsoft.FSharp.Collections n #endif - let empty = MapEmpty + [] + type Constants<'Key, 'Value when 'Key : comparison> private () = + static let empty = MapNode(Unchecked.defaultof<'Key>, Unchecked.defaultof<'Value>, Unchecked.defaultof>, Unchecked.defaultof>, 0) + static member Empty = empty - let size x = - match x with - | MapEmpty -> 0 - | MapNode (_,_,_,_,h) -> h + let inline size (MapNode(_,_,_,_,s)) = s - let isEmpty m = - match m with - | MapEmpty -> true - | _ -> false + let inline isEmpty (MapNode(_,_,_,_,s)) = s = 0 let inline mk l k v r = MapNode (k,v,l,r, size l + size r + 1) let inline mkLeaf k v = - MapNode (k, v, MapEmpty, MapEmpty, 1) - - let private rebalanceRight l k v r = - match r with - | MapEmpty -> failwith "rebalance" - | MapNode(rk,rv,rl,rr,_) -> - (* one of the nodes must have height > height t1 + 1 *) - if size rl > size l then (* balance left: combination *) - match rl with - | MapEmpty -> failwith "rebalance" - | MapNode(rlk,rlv,rll,rlr,_) -> mk (mk l k v rll) rlk rlv (mk rlr rk rv rr) - else (* rotate left *) - mk (mk l k v rl) rk rv rr - - let private rebalanceLeft l k v r = - match l with - | MapEmpty -> failwith "rebalance" - | MapNode(lk,lv,ll,lr,_) -> - (* one of the nodes must have height > height t2 + 1 *) - if size lr > size r then - (* balance right: combination *) - match lr with - | MapEmpty -> failwith "rebalance" - | MapNode(lrk,lrv,lrl,lrr,_) -> mk (mk ll lk lv lrl) lrk lrv (mk lrr k v r) - else - mk ll lk lv (mk lr k v r) + MapNode (k, v, Constants.Empty, Constants.Empty, 1) + + let private rebalanceRight l k v (MapNode(rk,rv,rl,rr,_)) = + (* one of the nodes must have height > height t1 + 1 *) + if size rl > size l then (* balance left: combination *) + match rl with + | MapNode(rlk,rlv,rll,rlr,_) -> mk (mk l k v rll) rlk rlv (mk rlr rk rv rr) + else (* rotate left *) + mk (mk l k v rl) rk rv rr + + let private rebalanceLeft (MapNode(lk,lv,ll,lr,_)) k v r = + (* one of the nodes must have height > height t2 + 1 *) + if size lr > size r then + (* balance right: combination *) + match lr with + | MapNode(lrk,lrv,lrl,lrr,_) -> mk (mk ll lk lv lrl) lrk lrv (mk lrr k v r) + else + mk ll lk lv (mk lr k v r) let inline rebalance l k v r = let ls, rs = size l, size r @@ -98,10 +85,9 @@ namespace Microsoft.FSharp.Collections elif (ls >>> 1) > rs then rebalanceLeft l k v r else MapNode (k,v,l,r, ls+rs+1) - let rec add (comparer: IComparer<'Value>) k v m = - match m with - | MapEmpty -> mkLeaf k v - | MapNode(k2,v2,l,r,s) -> + let rec add (comparer: IComparer<'Value>) k v (MapNode(k2,v2,l,r,s)) = + if s = 0 then mkLeaf k v + else let c = comparer.Compare(k,k2) if c < 0 then rebalance (add comparer k v l) k2 v2 r elif c > 0 then rebalance l k2 v2 (add comparer k v r) @@ -109,7 +95,7 @@ namespace Microsoft.FSharp.Collections let rec find (comparer: IComparer<'Value>) k m = match m with - | MapEmpty -> raise (KeyNotFoundException()) + | MapNode(_,_,_,_,0) -> raise (KeyNotFoundException()) | MapNode(k2,v2,l,r,_) -> let c = comparer.Compare(k,k2) if c < 0 then find comparer k l @@ -118,7 +104,7 @@ namespace Microsoft.FSharp.Collections let rec tryFind (comparer: IComparer<'Value>) k m = match m with - | MapEmpty -> None + | MapNode(_,_,_,_,0) -> None | MapNode(k2,v2,l,r,_) -> let c = comparer.Compare(k,k2) if c < 0 then tryFind comparer k l @@ -130,44 +116,44 @@ namespace Microsoft.FSharp.Collections let rec partitionAux (comparer: IComparer<'Value>) (f:OptimizedClosures.FSharpFunc<_,_,_>) s acc = match s with - | MapEmpty -> acc + | MapNode(_,_,_,_,0) -> acc | MapNode(k,v,l,r,_) -> let acc = partitionAux comparer f r acc let acc = partition1 comparer f k v acc partitionAux comparer f l acc - let partition (comparer: IComparer<'Value>) f s = partitionAux comparer (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) s (empty,empty) + let partition (comparer: IComparer<'Value>) f s = partitionAux comparer (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) s (Constants.Empty,Constants.Empty) let filter1 (comparer: IComparer<'Value>) (f:OptimizedClosures.FSharpFunc<_,_,_>) k v acc = if f.Invoke(k, v) then add comparer k v acc else acc let rec filterAux (comparer: IComparer<'Value>) (f:OptimizedClosures.FSharpFunc<_,_,_>) s acc = match s with - | MapEmpty -> acc + | MapNode(_,_,_,_,0) -> acc | MapNode(k,v,l,r,_) -> let acc = filterAux comparer f l acc let acc = filter1 comparer f k v acc filterAux comparer f r acc - let filter (comparer: IComparer<'Value>) f s = filterAux comparer (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) s empty + let filter (comparer: IComparer<'Value>) f s = filterAux comparer (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) s Constants.Empty let rec spliceOutSuccessor m = match m with - | MapEmpty -> failwith "internal error: Map.spliceOutSuccessor" + | MapNode(_,_,_,_,0) -> failwith "internal error: Map.spliceOutSuccessor" | MapNode(k2,v2,l,r,_) -> match l with - | MapEmpty -> k2,v2,r + | MapNode(_,_,_,_,0) -> k2,v2,r | _ -> let k3,v3,l' = spliceOutSuccessor l in k3,v3,mk l' k2 v2 r let rec remove (comparer: IComparer<'Value>) k m = match m with - | MapEmpty -> empty + | MapNode(_,_,_,_,0) -> Constants.Empty | MapNode(k2,v2,l,r,_) -> let c = comparer.Compare(k,k2) if c < 0 then rebalance (remove comparer k l) k2 v2 r elif c = 0 then match l,r with - | MapEmpty,_ -> r - | _,MapEmpty -> l + | MapNode(_,_,_,_,0),_ -> r + | _,MapNode(_,_,_,_,0) -> l | _ -> let sk,sv,r' = spliceOutSuccessor r mk l sk sv r' @@ -175,7 +161,7 @@ namespace Microsoft.FSharp.Collections let rec mem (comparer: IComparer<'Value>) k m = match m with - | MapEmpty -> false + | MapNode(_,_,_,_,0) -> false | MapNode(k2,_,l,r,_) -> let c = comparer.Compare(k,k2) if c < 0 then mem comparer k l @@ -183,14 +169,14 @@ namespace Microsoft.FSharp.Collections let rec iterOpt (f:OptimizedClosures.FSharpFunc<_,_,_>) m = match m with - | MapEmpty -> () + | MapNode(_,_,_,_,0) -> () | MapNode(k2,v2,l,r,_) -> iterOpt f l; f.Invoke(k2, v2); iterOpt f r let iter f m = iterOpt (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) m let rec tryPickOpt (f:OptimizedClosures.FSharpFunc<_,_,_>) m = match m with - | MapEmpty -> None + | MapNode(_,_,_,_,0) -> None | MapNode(k2,v2,l,r,_) -> match tryPickOpt f l with | Some _ as res -> res @@ -204,21 +190,21 @@ namespace Microsoft.FSharp.Collections let rec existsOpt (f:OptimizedClosures.FSharpFunc<_,_,_>) m = match m with - | MapEmpty -> false + | MapNode(_,_,_,_,0) -> false | MapNode(k2,v2,l,r,_) -> existsOpt f l || f.Invoke(k2, v2) || existsOpt f r let exists f m = existsOpt (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) m let rec forallOpt (f:OptimizedClosures.FSharpFunc<_,_,_>) m = match m with - | MapEmpty -> true + | MapNode(_,_,_,_,0) -> true | MapNode(k2,v2,l,r,_) -> forallOpt f l && f.Invoke(k2, v2) && forallOpt f r let forall f m = forallOpt (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) m let rec map f m = match m with - | MapEmpty -> empty + | MapNode(_,_,_,_,0) -> Constants.Empty | MapNode(k,v,l,r,h) -> let l2 = map f l let v2 = f v @@ -227,7 +213,7 @@ namespace Microsoft.FSharp.Collections let rec mapiOpt (f:OptimizedClosures.FSharpFunc<_,_,_>) m = match m with - | MapEmpty -> empty + | MapNode(_,_,_,_,0) -> Constants.Empty | MapNode(k,v,l,r,h) -> let l2 = mapiOpt f l let v2 = f.Invoke(k, v) @@ -238,7 +224,7 @@ namespace Microsoft.FSharp.Collections let rec foldBackOpt (f:OptimizedClosures.FSharpFunc<_,_,_,_>) m x = match m with - | MapEmpty -> x + | MapNode(_,_,_,_,0) -> x | MapNode(k,v,l,r,_) -> let x = foldBackOpt f r x let x = f.Invoke(k,v,x) @@ -248,7 +234,7 @@ namespace Microsoft.FSharp.Collections let rec foldOpt (f:OptimizedClosures.FSharpFunc<_,_,_,_>) x m = match m with - | MapEmpty -> x + | MapNode(_,_,_,_,0) -> x | MapNode(k,v,l,r,_) -> let x = foldOpt f x l let x = f.Invoke(x,k,v) @@ -259,7 +245,7 @@ namespace Microsoft.FSharp.Collections let foldSectionOpt (comparer: IComparer<'Value>) lo hi (f:OptimizedClosures.FSharpFunc<_,_,_,_>) m x = let rec foldFromTo (f:OptimizedClosures.FSharpFunc<_,_,_,_>) m x = match m with - | MapEmpty -> x + | MapNode(_,_,_,_,0) -> x | MapNode(k,v,l,r,_) -> let cLoKey = comparer.Compare(lo,k) let cKeyHi = comparer.Compare(k,hi) @@ -294,7 +280,7 @@ namespace Microsoft.FSharp.Collections let constructViaArray comparer (data:seq<'Key*'Value>) = let array = data |> Seq.toArray - if array.Length = 0 then MapEmpty + if array.Length = 0 then Constants.Empty else let keys = array |> Array.map fst @@ -312,7 +298,7 @@ namespace Microsoft.FSharp.Collections else let right = loop (mid+1) upper if mid = lower then - mk MapEmpty k v right + mk Constants.Empty k v right else let left = loop lower (mid-1) mk left k v right @@ -322,7 +308,7 @@ namespace Microsoft.FSharp.Collections let toList m = let rec loop m acc = match m with - | MapEmpty -> acc + | MapNode(_,_,_,_,0) -> acc | MapNode(k,v,l,r,_) -> loop l ((k,v)::loop r acc) loop m [] @@ -335,7 +321,7 @@ namespace Microsoft.FSharp.Collections largeObjectHeapBytes * 10 / 9 / sizeof<'Key*'Value> / 2 let ofList comparer (l:list<'Key*'Value>) = - if l |> List.isEmpty then empty + if l |> List.isEmpty then Constants.Empty else let chunk = ResizeArray () let maxCount = maxInitializationObjectCount<'Key, 'Value> () @@ -351,7 +337,7 @@ namespace Microsoft.FSharp.Collections remainder |> List.fold (fun acc (k,v) -> add comparer k v acc) chunkTree let ofSeqlImpl comparer (e:IEnumerator<'Key*'Value>) = - if not (e.MoveNext()) then empty + if not (e.MoveNext()) then Constants.Empty else let chunk = ResizeArray () let maxCount = maxInitializationObjectCount<'Key, 'Value> () @@ -406,9 +392,9 @@ namespace Microsoft.FSharp.Collections let rec collapseLHS stack = match stack with | [] -> [] - | MapEmpty :: rest -> collapseLHS rest - | MapNode(_,_,MapEmpty,MapEmpty,_) :: _ -> stack - | (MapNode(k,v,l,r,_)) :: rest -> collapseLHS (l :: (mkLeaf k v) :: r :: rest) + | MapNode(_,_,_,_,0) :: rest -> collapseLHS rest + | MapNode(_,_,MapNode(_,_,_,_,0),MapNode(_,_,_,_,0),_) :: _ -> stack + | MapNode(k,v,l,r,_) :: rest -> collapseLHS (l :: (mkLeaf k v) :: r :: rest) let mkIterator s = { stack = collapseLHS [s]; started = false } @@ -418,7 +404,7 @@ namespace Microsoft.FSharp.Collections let current i = if i.started then match i.stack with - | MapNode(k,v,MapEmpty,MapEmpty,_) :: _ -> new KeyValuePair<_,_>(k,v) + | MapNode(k,v,MapNode(_,_,_,_,0),MapNode(_,_,_,_,0),_) :: _ -> new KeyValuePair<_,_>(k,v) | [] -> alreadyFinished() | _ -> failwith "Please report error: Map iterator, unexpected stack for current" else @@ -427,7 +413,7 @@ namespace Microsoft.FSharp.Collections let rec moveNext i = if i.started then match i.stack with - | MapNode(_,_,MapEmpty,MapEmpty,_) :: rest -> + | MapNode(_,_,MapNode(_,_,_,_,0),MapNode(_,_,_,_,0),_) :: rest -> i.stack <- collapseLHS rest not i.stack.IsEmpty | [] -> false @@ -476,7 +462,7 @@ namespace Microsoft.FSharp.Collections // set (it is just a lookup into a .NET table of type-instantiation-indexed static fields). static let empty = let comparer = LanguagePrimitives.FastGenericComparer<'Key> - new Map<'Key,'Value>(comparer,MapTree<_,_>.MapEmpty) + new Map<'Key,'Value>(comparer,MapTree.Constants.Empty) #if !FX_NO_BINARY_SERIALIZATION [] From 33529d77da236e98806a75ab524e182cee36fcb9 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Thu, 26 Jul 2018 19:02:50 +1000 Subject: [PATCH 53/92] manual selective inlining of rebalance in add --- src/fsharp/FSharp.Core/map.fs | 19 ++++++++++++++++--- 1 file changed, 16 insertions(+), 3 deletions(-) diff --git a/src/fsharp/FSharp.Core/map.fs b/src/fsharp/FSharp.Core/map.fs index d7c7c0aefe1..bc467c378a7 100644 --- a/src/fsharp/FSharp.Core/map.fs +++ b/src/fsharp/FSharp.Core/map.fs @@ -89,9 +89,22 @@ namespace Microsoft.FSharp.Collections if s = 0 then mkLeaf k v else let c = comparer.Compare(k,k2) - if c < 0 then rebalance (add comparer k v l) k2 v2 r - elif c > 0 then rebalance l k2 v2 (add comparer k v r) - else MapNode(k,v,l,r,s) + if c < 0 then + let l' = add comparer k v l + let l's, rs = size l', size r + if (l's >>> 1) > rs then + rebalanceLeft l' k2 v2 r + else + MapNode (k2,v2,l',r, l's+rs+1) + elif c > 0 then + let r' = add comparer k v r + let ls, r's = size l, size r' + if (r's >>> 1) > ls then + rebalanceRight l k2 v2 r' + else + MapNode (k2,v2,l,r', ls+r's+1) + else + MapNode(k,v,l,r,s) let rec find (comparer: IComparer<'Value>) k m = match m with From 768a8d79e9957829f8ce3867d4b65cb7ecd55f24 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sat, 28 Jul 2018 10:27:54 +1000 Subject: [PATCH 54/92] Only access members when necessary - measurable performance diff for find's inner loop --- src/fsharp/FSharp.Core/map.fs | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/src/fsharp/FSharp.Core/map.fs b/src/fsharp/FSharp.Core/map.fs index bc467c378a7..0c3dfde73a9 100644 --- a/src/fsharp/FSharp.Core/map.fs +++ b/src/fsharp/FSharp.Core/map.fs @@ -106,14 +106,13 @@ namespace Microsoft.FSharp.Collections else MapNode(k,v,l,r,s) - let rec find (comparer: IComparer<'Value>) k m = - match m with - | MapNode(_,_,_,_,0) -> raise (KeyNotFoundException()) - | MapNode(k2,v2,l,r,_) -> - let c = comparer.Compare(k,k2) - if c < 0 then find comparer k l - elif c = 0 then v2 - else find comparer k r + let rec find (comparer: IComparer<'Value>) k (MapNode(k2,_,_,_,s) as m) = + if s = 0 then raise (KeyNotFoundException ()) + + let c = comparer.Compare(k,k2) + if c < 0 then match m with MapNode(_,_,l,_,_) -> find comparer k l + elif c > 0 then match m with MapNode(_,_,_,r,_) -> find comparer k r + else match m with MapNode(_,v2,_,_,_) -> v2 let rec tryFind (comparer: IComparer<'Value>) k m = match m with From c7e6a01ed966d8094456b0aaf5dd8ee1ef86de6c Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sat, 28 Jul 2018 16:46:04 +1000 Subject: [PATCH 55/92] Consolidated find functionality --- src/fsharp/FSharp.Core/map.fs | 50 ++++++++++++++++------------------- 1 file changed, 23 insertions(+), 27 deletions(-) diff --git a/src/fsharp/FSharp.Core/map.fs b/src/fsharp/FSharp.Core/map.fs index 0c3dfde73a9..701a4d3e404 100644 --- a/src/fsharp/FSharp.Core/map.fs +++ b/src/fsharp/FSharp.Core/map.fs @@ -85,7 +85,7 @@ namespace Microsoft.FSharp.Collections elif (ls >>> 1) > rs then rebalanceLeft l k v r else MapNode (k,v,l,r, ls+rs+1) - let rec add (comparer: IComparer<'Value>) k v (MapNode(k2,v2,l,r,s)) = + let rec add (comparer:IComparer<'Key>) k v (MapNode(k2,v2,l,r,s)) = if s = 0 then mkLeaf k v else let c = comparer.Compare(k,k2) @@ -106,27 +106,23 @@ namespace Microsoft.FSharp.Collections else MapNode(k,v,l,r,s) - let rec find (comparer: IComparer<'Value>) k (MapNode(k2,_,_,_,s) as m) = - if s = 0 then raise (KeyNotFoundException ()) - - let c = comparer.Compare(k,k2) - if c < 0 then match m with MapNode(_,_,l,_,_) -> find comparer k l - elif c > 0 then match m with MapNode(_,_,_,r,_) -> find comparer k r - else match m with MapNode(_,v2,_,_,_) -> v2 + let inline private findImpl (comparer:IComparer<'Key>) k m found notfound = + let rec loop (MapNode(k2,_,_,_,s) as m) = + if s = 0 then notfound () + else + let c = comparer.Compare(k,k2) + if c < 0 then match m with MapNode(_,_,l,_,_) -> loop l + elif c > 0 then match m with MapNode(_,_,_,r,_) -> loop r + else match m with MapNode(_,v2,_,_,_) -> found v2 + loop m - let rec tryFind (comparer: IComparer<'Value>) k m = - match m with - | MapNode(_,_,_,_,0) -> None - | MapNode(k2,v2,l,r,_) -> - let c = comparer.Compare(k,k2) - if c < 0 then tryFind comparer k l - elif c = 0 then Some v2 - else tryFind comparer k r + let find comparer k m = findImpl comparer k m id (fun () -> raise (KeyNotFoundException ())) + let tryFind comparer k m = findImpl comparer k m Some (fun () -> None) - let partition1 (comparer: IComparer<'Value>) (f:OptimizedClosures.FSharpFunc<_,_,_>) k v (acc1,acc2) = + let partition1 (comparer:IComparer<'Key>) (f:OptimizedClosures.FSharpFunc<_,_,_>) k v (acc1,acc2) = if f.Invoke(k, v) then (add comparer k v acc1,acc2) else (acc1,add comparer k v acc2) - let rec partitionAux (comparer: IComparer<'Value>) (f:OptimizedClosures.FSharpFunc<_,_,_>) s acc = + let rec partitionAux (comparer:IComparer<'Key>) (f:OptimizedClosures.FSharpFunc<_,_,_>) s acc = match s with | MapNode(_,_,_,_,0) -> acc | MapNode(k,v,l,r,_) -> @@ -134,11 +130,11 @@ namespace Microsoft.FSharp.Collections let acc = partition1 comparer f k v acc partitionAux comparer f l acc - let partition (comparer: IComparer<'Value>) f s = partitionAux comparer (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) s (Constants.Empty,Constants.Empty) + let partition (comparer:IComparer<'Key>) f s = partitionAux comparer (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) s (Constants.Empty,Constants.Empty) - let filter1 (comparer: IComparer<'Value>) (f:OptimizedClosures.FSharpFunc<_,_,_>) k v acc = if f.Invoke(k, v) then add comparer k v acc else acc + let filter1 (comparer:IComparer<'Key>) (f:OptimizedClosures.FSharpFunc<_,_,_>) k v acc = if f.Invoke(k, v) then add comparer k v acc else acc - let rec filterAux (comparer: IComparer<'Value>) (f:OptimizedClosures.FSharpFunc<_,_,_>) s acc = + let rec filterAux (comparer:IComparer<'Key>) (f:OptimizedClosures.FSharpFunc<_,_,_>) s acc = match s with | MapNode(_,_,_,_,0) -> acc | MapNode(k,v,l,r,_) -> @@ -146,7 +142,7 @@ namespace Microsoft.FSharp.Collections let acc = filter1 comparer f k v acc filterAux comparer f r acc - let filter (comparer: IComparer<'Value>) f s = filterAux comparer (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) s Constants.Empty + let filter (comparer:IComparer<'Key>) f s = filterAux comparer (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) s Constants.Empty let rec spliceOutSuccessor m = match m with @@ -156,7 +152,7 @@ namespace Microsoft.FSharp.Collections | MapNode(_,_,_,_,0) -> k2,v2,r | _ -> let k3,v3,l' = spliceOutSuccessor l in k3,v3,mk l' k2 v2 r - let rec remove (comparer: IComparer<'Value>) k m = + let rec remove (comparer:IComparer<'Key>) k m = match m with | MapNode(_,_,_,_,0) -> Constants.Empty | MapNode(k2,v2,l,r,_) -> @@ -171,7 +167,7 @@ namespace Microsoft.FSharp.Collections mk l sk sv r' else rebalance l k2 v2 (remove comparer k r) - let rec mem (comparer: IComparer<'Value>) k m = + let rec mem (comparer:IComparer<'Key>) k m = match m with | MapNode(_,_,_,_,0) -> false | MapNode(k2,_,l,r,_) -> @@ -254,7 +250,7 @@ namespace Microsoft.FSharp.Collections let fold f x m = foldOpt (OptimizedClosures.FSharpFunc<_,_,_,_>.Adapt(f)) x m - let foldSectionOpt (comparer: IComparer<'Value>) lo hi (f:OptimizedClosures.FSharpFunc<_,_,_,_>) m x = + let foldSectionOpt (comparer:IComparer<'Key>) lo hi (f:OptimizedClosures.FSharpFunc<_,_,_,_>) m x = let rec foldFromTo (f:OptimizedClosures.FSharpFunc<_,_,_,_>) m x = match m with | MapNode(_,_,_,_,0) -> x @@ -268,7 +264,7 @@ namespace Microsoft.FSharp.Collections if comparer.Compare(lo,hi) = 1 then x else foldFromTo f m x - let foldSection (comparer: IComparer<'Value>) lo hi f m x = + let foldSection (comparer:IComparer<'Key>) lo hi f m x = foldSectionOpt comparer lo hi (OptimizedClosures.FSharpFunc<_,_,_,_>.Adapt(f)) m x // create a mapping function which indexes the array, but with duplicate values removed @@ -452,7 +448,7 @@ namespace Microsoft.FSharp.Collections [] [] [] - type Map<[]'Key,[]'Value when 'Key : comparison >(comparer: IComparer<'Key>, tree: MapTree<'Key,'Value>) = + type Map<[]'Key,[]'Value when 'Key : comparison >(comparer:IComparer<'Key>, tree: MapTree<'Key,'Value>) = #if !FX_NO_BINARY_SERIALIZATION [] From a35212cdb2353a048f069a91145f876a1ed8ac14 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sat, 28 Jul 2018 16:53:43 +1000 Subject: [PATCH 56/92] Labelled MapNode fields --- src/fsharp/FSharp.Core/map.fs | 60 +++++++++++++++++------------------ 1 file changed, 30 insertions(+), 30 deletions(-) diff --git a/src/fsharp/FSharp.Core/map.fs b/src/fsharp/FSharp.Core/map.fs index 701a4d3e404..0c59772c20a 100644 --- a/src/fsharp/FSharp.Core/map.fs +++ b/src/fsharp/FSharp.Core/map.fs @@ -10,7 +10,7 @@ namespace Microsoft.FSharp.Collections [] type MapTree<'Key,'Value when 'Key : comparison > = - | MapNode of 'Key * 'Value * MapTree<'Key,'Value> * MapTree<'Key,'Value> * int + | MapNode of Key:'Key * Value:'Value * Left:MapTree<'Key,'Value> * Right:MapTree<'Key,'Value> * Size:int [] module MapTree = @@ -52,9 +52,9 @@ namespace Microsoft.FSharp.Collections static let empty = MapNode(Unchecked.defaultof<'Key>, Unchecked.defaultof<'Value>, Unchecked.defaultof>, Unchecked.defaultof>, 0) static member Empty = empty - let inline size (MapNode(_,_,_,_,s)) = s + let inline size (MapNode(Size=s)) = s - let inline isEmpty (MapNode(_,_,_,_,s)) = s = 0 + let inline isEmpty (MapNode(Size=s)) = s = 0 let inline mk l k v r = MapNode (k,v,l,r, size l + size r + 1) @@ -86,7 +86,7 @@ namespace Microsoft.FSharp.Collections else MapNode (k,v,l,r, ls+rs+1) let rec add (comparer:IComparer<'Key>) k v (MapNode(k2,v2,l,r,s)) = - if s = 0 then mkLeaf k v + if s = 0 then mkLeaf k v else let c = comparer.Compare(k,k2) if c < 0 then @@ -107,13 +107,13 @@ namespace Microsoft.FSharp.Collections MapNode(k,v,l,r,s) let inline private findImpl (comparer:IComparer<'Key>) k m found notfound = - let rec loop (MapNode(k2,_,_,_,s) as m) = + let rec loop (MapNode(Key=k2;Size=s) as m) = if s = 0 then notfound () else let c = comparer.Compare(k,k2) - if c < 0 then match m with MapNode(_,_,l,_,_) -> loop l - elif c > 0 then match m with MapNode(_,_,_,r,_) -> loop r - else match m with MapNode(_,v2,_,_,_) -> found v2 + if c < 0 then match m with MapNode(Left=l) -> loop l + elif c > 0 then match m with MapNode(Right=r) -> loop r + else match m with MapNode(Value=v2) -> found v2 loop m let find comparer k m = findImpl comparer k m id (fun () -> raise (KeyNotFoundException ())) @@ -124,7 +124,7 @@ namespace Microsoft.FSharp.Collections let rec partitionAux (comparer:IComparer<'Key>) (f:OptimizedClosures.FSharpFunc<_,_,_>) s acc = match s with - | MapNode(_,_,_,_,0) -> acc + | MapNode(Size=0) -> acc | MapNode(k,v,l,r,_) -> let acc = partitionAux comparer f r acc let acc = partition1 comparer f k v acc @@ -136,7 +136,7 @@ namespace Microsoft.FSharp.Collections let rec filterAux (comparer:IComparer<'Key>) (f:OptimizedClosures.FSharpFunc<_,_,_>) s acc = match s with - | MapNode(_,_,_,_,0) -> acc + | MapNode(Size=0) -> acc | MapNode(k,v,l,r,_) -> let acc = filterAux comparer f l acc let acc = filter1 comparer f k v acc @@ -146,22 +146,22 @@ namespace Microsoft.FSharp.Collections let rec spliceOutSuccessor m = match m with - | MapNode(_,_,_,_,0) -> failwith "internal error: Map.spliceOutSuccessor" + | MapNode(Size=0) -> failwith "internal error: Map.spliceOutSuccessor" | MapNode(k2,v2,l,r,_) -> match l with - | MapNode(_,_,_,_,0) -> k2,v2,r + | MapNode(Size=0) -> k2,v2,r | _ -> let k3,v3,l' = spliceOutSuccessor l in k3,v3,mk l' k2 v2 r let rec remove (comparer:IComparer<'Key>) k m = match m with - | MapNode(_,_,_,_,0) -> Constants.Empty + | MapNode(Size=0) -> Constants.Empty | MapNode(k2,v2,l,r,_) -> let c = comparer.Compare(k,k2) if c < 0 then rebalance (remove comparer k l) k2 v2 r elif c = 0 then match l,r with - | MapNode(_,_,_,_,0),_ -> r - | _,MapNode(_,_,_,_,0) -> l + | MapNode(Size=0),_ -> r + | _,MapNode(Size=0) -> l | _ -> let sk,sv,r' = spliceOutSuccessor r mk l sk sv r' @@ -169,7 +169,7 @@ namespace Microsoft.FSharp.Collections let rec mem (comparer:IComparer<'Key>) k m = match m with - | MapNode(_,_,_,_,0) -> false + | MapNode(Size=0) -> false | MapNode(k2,_,l,r,_) -> let c = comparer.Compare(k,k2) if c < 0 then mem comparer k l @@ -177,14 +177,14 @@ namespace Microsoft.FSharp.Collections let rec iterOpt (f:OptimizedClosures.FSharpFunc<_,_,_>) m = match m with - | MapNode(_,_,_,_,0) -> () + | MapNode(Size=0) -> () | MapNode(k2,v2,l,r,_) -> iterOpt f l; f.Invoke(k2, v2); iterOpt f r let iter f m = iterOpt (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) m let rec tryPickOpt (f:OptimizedClosures.FSharpFunc<_,_,_>) m = match m with - | MapNode(_,_,_,_,0) -> None + | MapNode(Size=0) -> None | MapNode(k2,v2,l,r,_) -> match tryPickOpt f l with | Some _ as res -> res @@ -198,21 +198,21 @@ namespace Microsoft.FSharp.Collections let rec existsOpt (f:OptimizedClosures.FSharpFunc<_,_,_>) m = match m with - | MapNode(_,_,_,_,0) -> false + | MapNode(Size=0) -> false | MapNode(k2,v2,l,r,_) -> existsOpt f l || f.Invoke(k2, v2) || existsOpt f r let exists f m = existsOpt (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) m let rec forallOpt (f:OptimizedClosures.FSharpFunc<_,_,_>) m = match m with - | MapNode(_,_,_,_,0) -> true + | MapNode(Size=0) -> true | MapNode(k2,v2,l,r,_) -> forallOpt f l && f.Invoke(k2, v2) && forallOpt f r let forall f m = forallOpt (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) m let rec map f m = match m with - | MapNode(_,_,_,_,0) -> Constants.Empty + | MapNode(Size=0) -> Constants.Empty | MapNode(k,v,l,r,h) -> let l2 = map f l let v2 = f v @@ -221,7 +221,7 @@ namespace Microsoft.FSharp.Collections let rec mapiOpt (f:OptimizedClosures.FSharpFunc<_,_,_>) m = match m with - | MapNode(_,_,_,_,0) -> Constants.Empty + | MapNode(Size=0) -> Constants.Empty | MapNode(k,v,l,r,h) -> let l2 = mapiOpt f l let v2 = f.Invoke(k, v) @@ -232,7 +232,7 @@ namespace Microsoft.FSharp.Collections let rec foldBackOpt (f:OptimizedClosures.FSharpFunc<_,_,_,_>) m x = match m with - | MapNode(_,_,_,_,0) -> x + | MapNode(Size=0) -> x | MapNode(k,v,l,r,_) -> let x = foldBackOpt f r x let x = f.Invoke(k,v,x) @@ -242,7 +242,7 @@ namespace Microsoft.FSharp.Collections let rec foldOpt (f:OptimizedClosures.FSharpFunc<_,_,_,_>) x m = match m with - | MapNode(_,_,_,_,0) -> x + | MapNode(Size=0) -> x | MapNode(k,v,l,r,_) -> let x = foldOpt f x l let x = f.Invoke(x,k,v) @@ -253,7 +253,7 @@ namespace Microsoft.FSharp.Collections let foldSectionOpt (comparer:IComparer<'Key>) lo hi (f:OptimizedClosures.FSharpFunc<_,_,_,_>) m x = let rec foldFromTo (f:OptimizedClosures.FSharpFunc<_,_,_,_>) m x = match m with - | MapNode(_,_,_,_,0) -> x + | MapNode(Size=0) -> x | MapNode(k,v,l,r,_) -> let cLoKey = comparer.Compare(lo,k) let cKeyHi = comparer.Compare(k,hi) @@ -316,7 +316,7 @@ namespace Microsoft.FSharp.Collections let toList m = let rec loop m acc = match m with - | MapNode(_,_,_,_,0) -> acc + | MapNode(Size=0) -> acc | MapNode(k,v,l,r,_) -> loop l ((k,v)::loop r acc) loop m [] @@ -400,8 +400,8 @@ namespace Microsoft.FSharp.Collections let rec collapseLHS stack = match stack with | [] -> [] - | MapNode(_,_,_,_,0) :: rest -> collapseLHS rest - | MapNode(_,_,MapNode(_,_,_,_,0),MapNode(_,_,_,_,0),_) :: _ -> stack + | MapNode(Size=0) :: rest -> collapseLHS rest + | MapNode(_,_,MapNode(Size=0),MapNode(Size=0),_) :: _ -> stack | MapNode(k,v,l,r,_) :: rest -> collapseLHS (l :: (mkLeaf k v) :: r :: rest) let mkIterator s = { stack = collapseLHS [s]; started = false } @@ -412,7 +412,7 @@ namespace Microsoft.FSharp.Collections let current i = if i.started then match i.stack with - | MapNode(k,v,MapNode(_,_,_,_,0),MapNode(_,_,_,_,0),_) :: _ -> new KeyValuePair<_,_>(k,v) + | MapNode(k,v,MapNode(Size=0),MapNode(Size=0),_) :: _ -> new KeyValuePair<_,_>(k,v) | [] -> alreadyFinished() | _ -> failwith "Please report error: Map iterator, unexpected stack for current" else @@ -421,7 +421,7 @@ namespace Microsoft.FSharp.Collections let rec moveNext i = if i.started then match i.stack with - | MapNode(_,_,MapNode(_,_,_,_,0),MapNode(_,_,_,_,0),_) :: rest -> + | MapNode(_,_,MapNode(Size=0),MapNode(Size=0),_) :: rest -> i.stack <- collapseLHS rest not i.stack.IsEmpty | [] -> false From 2a7e1d0847112b43e9b2ac76e8716d841d1653c7 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sun, 29 Jul 2018 12:26:23 +1000 Subject: [PATCH 57/92] Revamped enumeration to create less garbage. Faster on 64-bit, slower on 32-bit. --- src/fsharp/FSharp.Core/map.fs | 152 +++++++++++++++------------------- 1 file changed, 67 insertions(+), 85 deletions(-) diff --git a/src/fsharp/FSharp.Core/map.fs b/src/fsharp/FSharp.Core/map.fs index 0c59772c20a..b7a00c7d4da 100644 --- a/src/fsharp/FSharp.Core/map.fs +++ b/src/fsharp/FSharp.Core/map.fs @@ -52,7 +52,11 @@ namespace Microsoft.FSharp.Collections static let empty = MapNode(Unchecked.defaultof<'Key>, Unchecked.defaultof<'Value>, Unchecked.defaultof>, Unchecked.defaultof>, 0) static member Empty = empty - let inline size (MapNode(Size=s)) = s + let inline size (MapNode(Size=s)) = s + let inline key (MapNode(Key=k)) = k + let inline value (MapNode(Value=v)) = v + let inline left (MapNode(Left=l)) = l + let inline right (MapNode(Right=r)) = r let inline isEmpty (MapNode(Size=s)) = s = 0 @@ -313,37 +317,12 @@ namespace Microsoft.FSharp.Collections loop 0 (count-1) - let toList m = - let rec loop m acc = - match m with - | MapNode(Size=0) -> acc - | MapNode(k,v,l,r,_) -> loop l ((k,v)::loop r acc) - loop m [] - - let toArray m = m |> toList |> Array.ofList - [] let largeObjectHeapBytes = 85000 let maxInitializationObjectCount<'Key, 'Value> () = largeObjectHeapBytes * 10 / 9 / sizeof<'Key*'Value> / 2 - let ofList comparer (l:list<'Key*'Value>) = - if l |> List.isEmpty then Constants.Empty - else - let chunk = ResizeArray () - let maxCount = maxInitializationObjectCount<'Key, 'Value> () - let rec populate x = - match x with - | [] -> x - | hd::tl -> - chunk.Add hd - if chunk.Count = maxCount then tl - else populate tl - let remainder = populate l - let chunkTree = constructViaArray comparer chunk - remainder |> List.fold (fun acc (k,v) -> add comparer k v acc) chunkTree - let ofSeqlImpl comparer (e:IEnumerator<'Key*'Value>) = if not (e.MoveNext()) then Constants.Empty else @@ -368,6 +347,12 @@ namespace Microsoft.FSharp.Collections else acc addRemainder chunkTree + + let ofList comparer (l:list<'Key*'Value>) = + match l with + | [] -> Constants.Empty + | l when (List.length l) <= (maxInitializationObjectCount<'Key, 'Value> ()) -> constructViaArray comparer l + | _ -> ofSeqlImpl comparer ((l:>seq<_>).GetEnumerator ()) let ofArray comparer (arr : array<_>) = constructViaArray comparer arr @@ -376,72 +361,67 @@ namespace Microsoft.FSharp.Collections match c with | :? array<'Key * 'T> as xs -> ofArray comparer xs | :? list<'Key * 'T> as xs -> ofList comparer xs - | _ -> - use ie = c.GetEnumerator() - ofSeqlImpl comparer ie - + | _ -> ofSeqlImpl comparer (c.GetEnumerator()) let copyToArray s (arr: _[]) i = let j = ref i s |> iter (fun x y -> arr.[!j] <- KeyValuePair(x,y); j := !j + 1) + + [] + type TreeIterator<'Key,'Value when 'Key : comparison>(root) = + let items = ResizeArray> () + let mutable depth = 0 + + let rec tryPush item = + if size item > 0 then + if depth = items.Count then + items.Add item + else + items.[depth] <- item + depth <- depth + 1 + tryPush (left item) - /// Imperative left-to-right iterators. - [] - type MapIterator<'Key,'Value when 'Key : comparison > = - { /// invariant: always collapseLHS result - mutable stack: MapTree<'Key,'Value> list; - /// true when MoveNext has been called - mutable started : bool } - - // collapseLHS: - // a) Always returns either [] or a list starting with MapOne. - // b) The "fringe" of the set stack is unchanged. - let rec collapseLHS stack = - match stack with - | [] -> [] - | MapNode(Size=0) :: rest -> collapseLHS rest - | MapNode(_,_,MapNode(Size=0),MapNode(Size=0),_) :: _ -> stack - | MapNode(k,v,l,r,_) :: rest -> collapseLHS (l :: (mkLeaf k v) :: r :: rest) - - let mkIterator s = { stack = collapseLHS [s]; started = false } + do tryPush root - let notStarted() = raise (InvalidOperationException(SR.GetString(SR.enumerationNotStarted))) - let alreadyFinished() = raise (InvalidOperationException(SR.GetString(SR.enumerationAlreadyFinished))) + member inline __.PopCurrent f = + depth <- depth - 1 + match items.[depth] with + | MapNode(k,v,_,r,_) -> + tryPush r + f k v - let current i = - if i.started then - match i.stack with - | MapNode(k,v,MapNode(Size=0),MapNode(Size=0),_) :: _ -> new KeyValuePair<_,_>(k,v) - | [] -> alreadyFinished() - | _ -> failwith "Please report error: Map iterator, unexpected stack for current" - else - notStarted() - - let rec moveNext i = - if i.started then - match i.stack with - | MapNode(_,_,MapNode(Size=0),MapNode(Size=0),_) :: rest -> - i.stack <- collapseLHS rest - not i.stack.IsEmpty - | [] -> false - | _ -> failwith "Please report error: Map iterator, unexpected stack for moveNext" - else - i.started <- true (* The first call to MoveNext "starts" the enumeration. *) - not i.stack.IsEmpty - - let mkIEnumerator s = - let i = ref (mkIterator s) - { new IEnumerator<_> with - member __.Current = current !i - interface System.Collections.IEnumerator with - member __.Current = box (current !i) - member __.MoveNext() = moveNext !i - member __.Reset() = i := mkIterator s - interface System.IDisposable with - member __.Dispose() = ()} + member __.MorePairs = depth > 0 + + let inline private getEnumerable f m = + seq { let iterator = TreeIterator<_,_> m + while iterator.MorePairs do + yield iterator.PopCurrent f } + let tryGetSmallEnumerable m = + match m with + | MapNode(Size=0) -> Seq.empty + | MapNode(k,v,_,_,1) -> [ KeyValuePair (k,v) ] :> seq<_> + | MapNode(k,v,MapNode(lk,lv,_,_,1),_,2) -> [| KeyValuePair (lk,lv); KeyValuePair (k,v) |] :> seq<_> + | MapNode(k,v,_,MapNode(rk,rv,_,_,1),2) -> [| KeyValuePair (k,v); KeyValuePair (rk,rv) |] :> seq<_> + | MapNode(k,v,MapNode(lk,lv,_,_,1),MapNode(rk,rv,_,_,1),3) -> [| KeyValuePair (lk,lv); KeyValuePair (k,v); KeyValuePair (rk,rv) |] :> seq<_> + | _ -> null + + let getKVEnumerable m = + match tryGetSmallEnumerable m with + | null -> getEnumerable (fun k v -> KeyValuePair (k, v)) m + | small -> small + + let toSeq m = + getEnumerable (fun k v -> k, v) m + let toList m = + let iterator = TreeIterator<_,_> m + List.init (size m) (fun _ -> iterator.PopCurrent (fun k v -> k, v)) + + let toArray m = + let iterator = TreeIterator<_,_> m + Array.init (size m) (fun _ -> iterator.PopCurrent (fun k v -> k, v)) [>)>] [] @@ -568,6 +548,8 @@ namespace Microsoft.FSharp.Collections #endif MapTree.tryFind comparer key tree + member m.ToSeq() = MapTree.toSeq tree + member m.ToList() = MapTree.toList tree member m.ToArray() = MapTree.toArray tree @@ -599,10 +581,10 @@ namespace Microsoft.FSharp.Collections override this.GetHashCode() = this.ComputeHashCode() interface IEnumerable> with - member __.GetEnumerator() = MapTree.mkIEnumerator tree + member __.GetEnumerator() = (MapTree.getKVEnumerable tree).GetEnumerator() interface System.Collections.IEnumerable with - member __.GetEnumerator() = (MapTree.mkIEnumerator tree :> System.Collections.IEnumerator) + member __.GetEnumerator() = (((MapTree.getKVEnumerable tree).GetEnumerator()) :> System.Collections.IEnumerator) interface IDictionary<'Key, 'Value> with member m.Item @@ -739,7 +721,7 @@ namespace Microsoft.FSharp.Collections let foldBack<'Key,'T,'State when 'Key : comparison> folder (table:Map<'Key,'T>) (state:'State) = MapTree.foldBack folder table.Tree state [] - let toSeq (table:Map<_,_>) = table |> Seq.map (fun kvp -> kvp.Key, kvp.Value) + let toSeq (table:Map<_,_>) = table.ToSeq() [] let findKey predicate (table : Map<_,_>) = table |> toSeq |> Seq.pick (fun (k,v) -> if predicate k v then Some(k) else None) From c0685c5510472eb0e78142293480c3318c8d86ae Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sun, 29 Jul 2018 13:14:33 +1000 Subject: [PATCH 58/92] Added Checked logic to ensure size constraint isn't violated --- src/fsharp/FSharp.Core/map.fs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/fsharp/FSharp.Core/map.fs b/src/fsharp/FSharp.Core/map.fs index b7a00c7d4da..d9b3345dff2 100644 --- a/src/fsharp/FSharp.Core/map.fs +++ b/src/fsharp/FSharp.Core/map.fs @@ -60,8 +60,10 @@ namespace Microsoft.FSharp.Collections let inline isEmpty (MapNode(Size=s)) = s = 0 + let inline (++) l r = Checked.(+) l r + let inline mk l k v r = - MapNode (k,v,l,r, size l + size r + 1) + MapNode (k,v,l,r, size l ++ size r ++ 1) let inline mkLeaf k v = MapNode (k, v, Constants.Empty, Constants.Empty, 1) @@ -87,7 +89,7 @@ namespace Microsoft.FSharp.Collections let ls, rs = size l, size r if (rs >>> 1) > ls then rebalanceRight l k v r elif (ls >>> 1) > rs then rebalanceLeft l k v r - else MapNode (k,v,l,r, ls+rs+1) + else MapNode (k,v,l,r, ls ++ rs ++ 1) let rec add (comparer:IComparer<'Key>) k v (MapNode(k2,v2,l,r,s)) = if s = 0 then mkLeaf k v @@ -99,14 +101,14 @@ namespace Microsoft.FSharp.Collections if (l's >>> 1) > rs then rebalanceLeft l' k2 v2 r else - MapNode (k2,v2,l',r, l's+rs+1) + MapNode (k2,v2,l',r, l's ++ rs ++ 1) elif c > 0 then let r' = add comparer k v r let ls, r's = size l, size r' if (r's >>> 1) > ls then rebalanceRight l k2 v2 r' else - MapNode (k2,v2,l,r', ls+r's+1) + MapNode (k2,v2,l,r', ls ++ r's ++ 1) else MapNode(k,v,l,r,s) From 97ff63534da947f2b2679cbe896e3655480af720 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sun, 29 Jul 2018 13:19:34 +1000 Subject: [PATCH 59/92] findImpl use helper functions to clean up --- src/fsharp/FSharp.Core/map.fs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/fsharp/FSharp.Core/map.fs b/src/fsharp/FSharp.Core/map.fs index d9b3345dff2..fc9be5783db 100644 --- a/src/fsharp/FSharp.Core/map.fs +++ b/src/fsharp/FSharp.Core/map.fs @@ -113,13 +113,13 @@ namespace Microsoft.FSharp.Collections MapNode(k,v,l,r,s) let inline private findImpl (comparer:IComparer<'Key>) k m found notfound = - let rec loop (MapNode(Key=k2;Size=s) as m) = - if s = 0 then notfound () + let rec loop m = + if (size m) = 0 then notfound () else - let c = comparer.Compare(k,k2) - if c < 0 then match m with MapNode(Left=l) -> loop l - elif c > 0 then match m with MapNode(Right=r) -> loop r - else match m with MapNode(Value=v2) -> found v2 + let c = comparer.Compare(k, key m) + if c < 0 then loop (left m) + elif c > 0 then loop (right m) + else found (value m) loop m let find comparer k m = findImpl comparer k m id (fun () -> raise (KeyNotFoundException ())) From 9896c6582abc2a08b3b2256e47dee9d089468381 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sun, 29 Jul 2018 16:04:29 +1000 Subject: [PATCH 60/92] Made the non-(to|of)(Seq|List|Array) Map changes to the TaggedCollections version --- src/utils/TaggedCollections.fs | 311 +++++++++++---------------------- 1 file changed, 102 insertions(+), 209 deletions(-) diff --git a/src/utils/TaggedCollections.fs b/src/utils/TaggedCollections.fs index 232d3b75053..6eb89d326c7 100644 --- a/src/utils/TaggedCollections.fs +++ b/src/utils/TaggedCollections.fs @@ -701,196 +701,137 @@ namespace Internal.Utilities.Collections.Tagged Set<_,_>(comparer=comparer, tree=SetTree.ofSeq comparer l) - [] [] - type MapTree<'Key,'T> = - | MapEmpty -#if ONE - | MapOne of 'Key * 'T -#endif - | MapNode of 'Key * 'T * MapTree<'Key,'T> * MapTree<'Key,'T> * int + type MapTree<'Key,'Value> = + | MapNode of Key:'Key * Value:'Value * Left:MapTree<'Key,'Value> * Right:MapTree<'Key,'Value> * Size:int [] module MapTree = - let empty = MapEmpty - - let inline height x = - match x with - | MapEmpty -> 0 -#if ONE - | MapOne _ -> 1 -#endif - | MapNode(_,_,_,_,h) -> h - - let inline isEmpty m = - match m with - | MapEmpty -> true - | _ -> false - - let inline mk l k v r = -#if ONE - match l,r with - | MapEmpty,MapEmpty -> MapOne(k,v) - | _ -> -#endif - let hl = height l - let hr = height r - let m = if hl < hr then hr else hl - MapNode(k,v,l,r,m+1) - - let rebalance t1 k v t2 = - let t1h = height t1 - let t2h = height t2 - if t2h > t1h + 2 then // right is heavier than left - match t2 with - | MapNode(t2k,t2v,t2l,t2r,_) -> - // one of the nodes must have height > height t1 + 1 - if height t2l > t1h + 1 then // balance left: combination - match t2l with - | MapNode(t2lk,t2lv,t2ll,t2lr,_) -> - mk (mk t1 k v t2ll) t2lk t2lv (mk t2lr t2k t2v t2r) - | _ -> failwith "rebalance" - else // rotate left - mk (mk t1 k v t2l) t2k t2v t2r - | _ -> failwith "rebalance" + [] + type Constants<'Key, 'Value> private () = + static let empty = MapNode(Unchecked.defaultof<'Key>, Unchecked.defaultof<'Value>, Unchecked.defaultof>, Unchecked.defaultof>, 0) + static member Empty = empty + + let inline size (MapNode(Size=s)) = s + let inline key (MapNode(Key=k)) = k + let inline value (MapNode(Value=v)) = v + let inline left (MapNode(Left=l)) = l + let inline right (MapNode(Right=r)) = r + + let inline isEmpty (MapNode(Size=s)) = s = 0 + + let inline (++) l r = Checked.(+) l r + + let inline mk l k v r = + MapNode (k,v,l,r, size l ++ size r ++ 1) + + let inline mkLeaf k v = + MapNode (k, v, Constants.Empty, Constants.Empty, 1) + + let private rebalanceRight l k v (MapNode(rk,rv,rl,rr,_)) = + (* one of the nodes must have height > height t1 + 1 *) + if size rl > size l then (* balance left: combination *) + match rl with + | MapNode(rlk,rlv,rll,rlr,_) -> mk (mk l k v rll) rlk rlv (mk rlr rk rv rr) + else (* rotate left *) + mk (mk l k v rl) rk rv rr + + let private rebalanceLeft (MapNode(lk,lv,ll,lr,_)) k v r = + (* one of the nodes must have height > height t2 + 1 *) + if size lr > size r then + (* balance right: combination *) + match lr with + | MapNode(lrk,lrv,lrl,lrr,_) -> mk (mk ll lk lv lrl) lrk lrv (mk lrr k v r) else - if t1h > t2h + 2 then // left is heavier than right - match t1 with - | MapNode(t1k,t1v,t1l,t1r,_) -> - // one of the nodes must have height > height t2 + 1 - if height t1r > t2h + 1 then - // balance right: combination - match t1r with - | MapNode(t1rk,t1rv,t1rl,t1rr,_) -> - mk (mk t1l t1k t1v t1rl) t1rk t1rv (mk t1rr k v t2) - | _ -> failwith "rebalance" - else - mk t1l t1k t1v (mk t1r k v t2) - | _ -> failwith "rebalance" - else mk t1 k v t2 - - let rec sizeAux acc m = - match m with - | MapEmpty -> acc -#if ONE - | MapOne _ -> acc + 1 -#endif - | MapNode(_,_,l,r,_) -> sizeAux (sizeAux (acc+1) l) r + mk ll lk lv (mk lr k v r) -#if ONE -#else - let MapOne(k,v) = MapNode(k,v,MapEmpty,MapEmpty,1) -#endif - - let count x = sizeAux 0 x + let inline rebalance l k v r = + let ls, rs = size l, size r + if (rs >>> 1) > ls then rebalanceRight l k v r + elif (ls >>> 1) > rs then rebalanceLeft l k v r + else MapNode (k,v,l,r, ls ++ rs ++ 1) - let rec add (comparer: IComparer<'T>) k v m = - match m with - | MapEmpty -> MapOne(k,v) -#if ONE - | MapOne(k2,v2) -> - let c = comparer.Compare(k,k2) - if c < 0 then MapNode (k,v,MapEmpty,m,2) - elif c = 0 then MapOne(k,v) - else MapNode (k,v,m,MapEmpty,2) -#endif - | MapNode(k2,v2,l,r,h) -> + let rec add (comparer:IComparer<'Key>) k v (MapNode(k2,v2,l,r,s)) = + if s = 0 then mkLeaf k v + else let c = comparer.Compare(k,k2) - if c < 0 then rebalance (add comparer k v l) k2 v2 r - elif c = 0 then MapNode(k,v,l,r,h) - else rebalance l k2 v2 (add comparer k v r) + if c < 0 then + let l' = add comparer k v l + let l's, rs = size l', size r + if (l's >>> 1) > rs then + rebalanceLeft l' k2 v2 r + else + MapNode (k2,v2,l',r, l's ++ rs ++ 1) + elif c > 0 then + let r' = add comparer k v r + let ls, r's = size l, size r' + if (r's >>> 1) > ls then + rebalanceRight l k2 v2 r' + else + MapNode (k2,v2,l,r', ls ++ r's ++ 1) + else + MapNode(k,v,l,r,s) let indexNotFound() = raise (new System.Collections.Generic.KeyNotFoundException("An index satisfying the predicate was not found in the collection")) - let rec find (comparer: IComparer<'T>) k m = - match m with - | MapEmpty -> indexNotFound() -#if ONE - | MapOne(k2,v2) -> - let c = comparer.Compare(k,k2) - if c = 0 then v2 - else indexNotFound() -#endif - | MapNode(k2,v2,l,r,_) -> - let c = comparer.Compare(k,k2) - if c < 0 then find comparer k l - elif c = 0 then v2 - else find comparer k r + let inline private findImpl (comparer:IComparer<'Key>) k m found notfound = + let rec loop m = + if (size m) = 0 then notfound () + else + let c = comparer.Compare(k, key m) + if c < 0 then loop (left m) + elif c > 0 then loop (right m) + else found (value m) + loop m - let rec tryFind (comparer: IComparer<'T>) k m = - match m with - | MapEmpty -> None -#if ONE - | MapOne(k2,v2) -> - let c = comparer.Compare(k,k2) - if c = 0 then Some v2 - else None -#endif - | MapNode(k2,v2,l,r,_) -> - let c = comparer.Compare(k,k2) - if c < 0 then tryFind comparer k l - elif c = 0 then Some v2 - else tryFind comparer k r + let find comparer k m = findImpl comparer k m id (fun () -> indexNotFound()) + let tryFind comparer k m = findImpl comparer k m Some (fun () -> None) let partition1 (comparer: IComparer<'T>) f k v (acc1,acc2) = if f k v then (add comparer k v acc1,acc2) else (acc1,add comparer k v acc2) let rec partitionAux (comparer: IComparer<'T>) f s acc = match s with - | MapEmpty -> acc -#if ONE - | MapOne(k,v) -> partition1 comparer f k v acc -#endif + | MapNode(Size=0) -> acc | MapNode(k,v,l,r,_) -> let acc = partitionAux comparer f r acc let acc = partition1 comparer f k v acc partitionAux comparer f l acc - let partition (comparer: IComparer<'T>) f s = partitionAux comparer f s (empty,empty) + let partition (comparer: IComparer<'T>) f s = partitionAux comparer f s (Constants.Empty,Constants.Empty) let filter1 (comparer: IComparer<'T>) f k v acc = if f k v then add comparer k v acc else acc let rec filterAux (comparer: IComparer<'T>) f s acc = match s with - | MapEmpty -> acc -#if ONE - | MapOne(k,v) -> filter1 comparer f k v acc -#endif + | MapNode(Size=0) -> acc | MapNode(k,v,l,r,_) -> let acc = filterAux comparer f l acc let acc = filter1 comparer f k v acc filterAux comparer f r acc - let filter (comparer: IComparer<'T>) f s = filterAux comparer f s empty + let filter (comparer: IComparer<'T>) f s = filterAux comparer f s Constants.Empty let rec spliceOutSuccessor m = match m with - | MapEmpty -> failwith "internal error: Map.splice_out_succ_or_pred" -#if ONE - | MapOne(k2,v2) -> k2,v2,MapEmpty -#endif + | MapNode(Size=0) -> failwith "internal error: Map.splice_out_succ_or_pred" | MapNode(k2,v2,l,r,_) -> match l with - | MapEmpty -> k2,v2,r + | MapNode(Size=0) -> k2,v2,r | _ -> let k3,v3,l' = spliceOutSuccessor l in k3,v3,mk l' k2 v2 r let rec remove (comparer: IComparer<'T>) k m = match m with - | MapEmpty -> empty -#if ONE - | MapOne(k2,v2) -> - let c = comparer.Compare(k,k2) - if c = 0 then MapEmpty else m -#endif + | MapNode(Size=0) -> Constants.Empty | MapNode(k2,v2,l,r,_) -> let c = comparer.Compare(k,k2) if c < 0 then rebalance (remove comparer k l) k2 v2 r elif c = 0 then match l,r with - | MapEmpty,_ -> r - | _,MapEmpty -> l + | MapNode(Size=0),_ -> r + | _,MapNode(Size=0) -> l | _ -> let sk,sv,r' = spliceOutSuccessor r mk l sk sv r' @@ -898,10 +839,7 @@ namespace Internal.Utilities.Collections.Tagged let rec containsKey (comparer: IComparer<'T>) k m = match m with - | MapEmpty -> false -#if ONE - | MapOne(k2,v2) -> (comparer.Compare(k,k2) = 0) -#endif + | MapNode(Size=0) -> false | MapNode(k2,_,l,r,_) -> let c = comparer.Compare(k,k2) if c < 0 then containsKey comparer k l @@ -909,18 +847,12 @@ namespace Internal.Utilities.Collections.Tagged let rec iter f m = match m with - | MapEmpty -> () -#if ONE - | MapOne(k2,v2) -> f k2 v2 -#endif + | MapNode(Size=0) -> () | MapNode(k2,v2,l,r,_) -> iter f l; f k2 v2; iter f r let rec first f m = match m with - | MapEmpty -> None -#if ONE - | MapOne(k2,v2) -> f k2 v2 -#endif + | MapNode(Size=0) -> None | MapNode(k2,v2,l,r,_) -> match first f l with | Some _ as res -> res @@ -931,34 +863,22 @@ namespace Internal.Utilities.Collections.Tagged let rec exists f m = match m with - | MapEmpty -> false -#if ONE - | MapOne(k2,v2) -> f k2 v2 -#endif + | MapNode(Size=0) -> false | MapNode(k2,v2,l,r,_) -> f k2 v2 || exists f l || exists f r let rec forAll f m = match m with - | MapEmpty -> true -#if ONE - | MapOne(k2,v2) -> f k2 v2 -#endif + | MapNode(Size=0) -> true | MapNode(k2,v2,l,r,_) -> f k2 v2 && forAll f l && forAll f r let rec map f m = match m with - | MapEmpty -> empty -#if ONE - | MapOne(k,v) -> MapOne(k,f v) -#endif + | MapNode(Size=0) -> Constants.Empty | MapNode(k,v,l,r,h) -> let v2 = f v in MapNode(k,v2,map f l, map f r,h) let rec mapi f m = match m with - | MapEmpty -> empty -#if ONE - | MapOne(k,v) -> MapOne(k,f k v) -#endif + | MapNode(Size=0) -> Constants.Empty | MapNode(k,v,l,r,h) -> let v2 = f k v in MapNode(k,v2, mapi f l, mapi f r,h) // Fold, right-to-left. @@ -966,23 +886,13 @@ namespace Internal.Utilities.Collections.Tagged // NOTE: This differs from the behaviour of Set.fold which folds left-to-right. let rec fold f m x = match m with - | MapEmpty -> x -#if ONE - | MapOne(k,v) -> f k v x -#endif + | MapNode(Size=0) -> x | MapNode(k,v,l,r,_) -> fold f l (f k v (fold f r x)) let foldSection (comparer: IComparer<'T>) lo hi f m x = let rec fold_from_to f m x = match m with - | MapEmpty -> x -#if ONE - | MapOne(k,v) -> - let clo_k = comparer.Compare(lo,k) - let ck_hi = comparer.Compare(k,hi) - let x = if clo_k <= 0 && ck_hi <= 0 then f k v x else x - x -#endif + | MapNode(Size=0) -> x | MapNode(k,v,l,r,_) -> let clo_k = comparer.Compare(lo,k) let ck_hi = comparer.Compare(k,hi) @@ -995,12 +905,7 @@ namespace Internal.Utilities.Collections.Tagged let rec foldMap (comparer: IComparer<'T>) f m z acc = match m with - | MapEmpty -> acc,z -#if ONE - | MapOne(k,v) -> - let v',z = f k v z - add comparer k v' acc,z -#endif + | MapNode(Size=0) -> acc,z | MapNode(k,v,l,r,_) -> let acc,z = foldMap comparer f r z acc let v',z = f k v z @@ -1009,7 +914,7 @@ namespace Internal.Utilities.Collections.Tagged let toList m = fold (fun k v acc -> (k,v) :: acc) m [] let toArray m = m |> toList |> Array.ofList - let ofList comparer l = List.fold (fun acc (k,v) -> add comparer k v acc) empty l + let ofList comparer l = List.fold (fun acc (k,v) -> add comparer k v acc) Constants.Empty l let rec mkFromEnumerator comparer acc (e : IEnumerator<_>) = @@ -1020,7 +925,7 @@ namespace Internal.Utilities.Collections.Tagged let ofSeq comparer (c : seq<_>) = use ie = c.GetEnumerator() - mkFromEnumerator comparer empty ie + mkFromEnumerator comparer Constants.Empty ie let copyToArray s (arr: _[]) i = let j = ref i @@ -1035,13 +940,9 @@ namespace Internal.Utilities.Collections.Tagged let rec collapseLHS stack = match stack with | [] -> [] - | MapEmpty :: rest -> collapseLHS rest -#if ONE - | MapOne _ :: _ -> stack -#else - | (MapNode(_,_,MapEmpty,MapEmpty,_)) :: _ -> stack -#endif - | (MapNode(k,v,l,r,_)) :: rest -> collapseLHS (l :: MapOne (k,v) :: r :: rest) + | MapNode(Size=0) :: rest -> collapseLHS rest + | (MapNode(_,_,MapNode(Size=0),MapNode(Size=0),_)) :: _ -> stack + | (MapNode(k,v,l,r,_)) :: rest -> collapseLHS (l :: (mkLeaf k v) :: r :: rest) /// invariant: always collapseLHS result let mutable stack = collapseLHS [s] @@ -1054,11 +955,7 @@ namespace Internal.Utilities.Collections.Tagged member i.Current = if started then match stack with -#if ONE - | MapOne (k,v) :: _ -> new KeyValuePair<_,_>(k,v) -#else - | (MapNode(k,v,MapEmpty,MapEmpty,_)) :: _ -> new KeyValuePair<_,_>(k,v) -#endif + | (MapNode(k,v,MapNode(Size=0),MapNode(Size=0),_)) :: _ -> new KeyValuePair<_,_>(k,v) | [] -> alreadyFinished() | _ -> failwith "Please report error: Map iterator, unexpected stack for current" else @@ -1067,11 +964,7 @@ namespace Internal.Utilities.Collections.Tagged member i.MoveNext() = if started then match stack with -#if ONE - | MapOne _ :: rest -> -#else - | (MapNode(_,_,MapEmpty,MapEmpty,_)) :: rest -> -#endif + | (MapNode(_,_,MapNode(Size=0),MapNode(Size=0),_)) :: rest -> stack <- collapseLHS rest; not stack.IsEmpty | [] -> false @@ -1103,7 +996,7 @@ namespace Internal.Utilities.Collections.Tagged member s.Tree = tree member s.Comparer : IComparer<'Key> = comparer - static member Empty(comparer : 'ComparerTag) = Map<'Key,'T,'ComparerTag>(comparer=comparer, tree=MapTree.empty) + static member Empty(comparer : 'ComparerTag) = Map<'Key,'T,'ComparerTag>(comparer=comparer, tree=MapTree.Constants.Empty) member m.Add(k,v) = refresh m (MapTree.add comparer k v tree) member m.IsEmpty = MapTree.isEmpty tree member m.Item with get(k : 'Key) = MapTree.find comparer k tree @@ -1114,7 +1007,7 @@ namespace Internal.Utilities.Collections.Tagged member m.Fold f acc = MapTree.fold f tree acc member m.FoldSection lo hi f acc = MapTree.foldSection comparer lo hi f tree acc member m.FoldAndMap f z = - let tree,z = MapTree.foldMap comparer f tree z MapTree.empty + let tree,z = MapTree.foldMap comparer f tree z MapTree.Constants.Empty refresh m tree, z member m.Iterate f = MapTree.iter f tree member m.MapRange f = refresh m (MapTree.map f tree) @@ -1122,7 +1015,7 @@ namespace Internal.Utilities.Collections.Tagged member m.Partition(f) = let r1,r2 = MapTree.partition comparer f tree refresh m r1, refresh m r2 - member m.Count = MapTree.count tree + member m.Count = MapTree.size tree member m.ContainsKey(k) = MapTree.containsKey comparer k tree member m.Remove(k) = refresh m (MapTree.remove comparer k tree) member m.TryFind(k) = MapTree.tryFind comparer k tree From 9611fb12a225162f74c6c363f042d2e73a814e0c Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Mon, 30 Jul 2018 17:47:00 +1000 Subject: [PATCH 61/92] Removed SetOne --- src/fsharp/FSharp.Core/set.fs | 69 +++++------------------------------ 1 file changed, 9 insertions(+), 60 deletions(-) diff --git a/src/fsharp/FSharp.Core/set.fs b/src/fsharp/FSharp.Core/set.fs index 85c04a2c241..8ee68bcc900 100644 --- a/src/fsharp/FSharp.Core/set.fs +++ b/src/fsharp/FSharp.Core/set.fs @@ -18,7 +18,6 @@ namespace Microsoft.FSharp.Collections type SetTree<'T> when 'T: comparison = | SetEmpty // height = 0 | SetNode of 'T * SetTree<'T> * SetTree<'T> * int // height = int - | SetOne of 'T // height = 1 // OPTIMIZATION: store SetNode(k,SetEmpty,SetEmpty,1) ---> SetOne(k) // REVIEW: performance rumour has it that the data held in SetNode and SetOne should be // exactly one cache line on typical architectures. They are currently @@ -30,7 +29,6 @@ namespace Microsoft.FSharp.Collections let rec countAux s acc = match s with | SetNode(_,l,r,_) -> countAux l (countAux r (acc+1)) - | SetOne(_) -> acc+1 | SetEmpty -> acc let count s = countAux s 0 @@ -64,7 +62,6 @@ namespace Microsoft.FSharp.Collections totalSizeOnNodeCreation <- totalSizeOnNodeCreation + float (count n); n #else - let SetOne n = SetTree.SetOne n let SetNode (x,l,r,h) = SetTree.SetNode(x,l,r,h) #endif @@ -73,7 +70,6 @@ namespace Microsoft.FSharp.Collections let height t = match t with | SetEmpty -> 0 - | SetOne _ -> 1 | SetNode (_,_,_,h) -> h #if CHECKED @@ -88,11 +84,14 @@ namespace Microsoft.FSharp.Collections (-2 <= (h1 - h2) && (h1 - h2) <= 2) && checkInvariant t1 && checkInvariant t2 #endif + let inline mkLeaf k = + SetNode (k, SetEmpty, SetEmpty, 1) + let tolerance = 2 let mk l k r = match l,r with - | SetEmpty,SetEmpty -> SetOne (k) + | SetEmpty,SetEmpty -> mkLeaf k | _ -> let hl = height l let hr = height r @@ -137,13 +136,7 @@ namespace Microsoft.FSharp.Collections if c < 0 then rebalance (add comparer k l) k2 r elif c = 0 then t else rebalance l k2 (add comparer k r) - | SetOne(k2) -> - // nb. no check for rebalance needed for small trees, also be sure to reuse node already allocated - let c = comparer.Compare(k,k2) - if c < 0 then SetNode (k,SetEmpty,t,2) - elif c = 0 then t - else SetNode (k,t,SetEmpty,2) - | SetEmpty -> SetOne(k) + | SetEmpty -> mkLeaf k let rec balance comparer t1 k t2 = // Given t1 < k < t2 where t1 and t2 are "balanced", @@ -152,8 +145,6 @@ namespace Microsoft.FSharp.Collections match t1,t2 with | SetEmpty,t2 -> add comparer k t2 // drop t1 = empty | t1,SetEmpty -> add comparer k t1 // drop t2 = empty - | SetOne k1,t2 -> add comparer k (add comparer k1 t2) - | t1,SetOne k2 -> add comparer k (add comparer k2 t1) | SetNode(k1,t11,t12,h1),SetNode(k2,t21,t22,h2) -> // Have: (t11 < k1 < t12) < k < (t21 < k2 < t22) // Either (a) h1,h2 differ by at most 2 - no rebalance needed. @@ -185,18 +176,12 @@ namespace Microsoft.FSharp.Collections else // pivot t2 let t12Lo,havePivot,t12Hi = split comparer pivot t12 balance comparer t11 k1 t12Lo,havePivot,t12Hi - | SetOne k1 -> - let c = comparer.Compare(k1,pivot) - if c < 0 then t ,false,SetEmpty // singleton under pivot - elif c = 0 then SetEmpty,true ,SetEmpty // singleton is pivot - else SetEmpty,false,t // singleton over pivot | SetEmpty -> SetEmpty,false,SetEmpty let rec spliceOutSuccessor t = match t with | SetEmpty -> failwith "internal error: Set.spliceOutSuccessor" - | SetOne (k2) -> k2,SetEmpty | SetNode (k2,l,r,_) -> match l with | SetEmpty -> k2,r @@ -205,10 +190,6 @@ namespace Microsoft.FSharp.Collections let rec remove (comparer: IComparer<'T>) k t = match t with | SetEmpty -> t - | SetOne (k2) -> - let c = comparer.Compare(k,k2) - if c = 0 then SetEmpty - else t | SetNode (k2,l,r,_) -> let c = comparer.Compare(k,k2) if c < 0 then rebalance (remove comparer k l) k2 r @@ -228,19 +209,16 @@ namespace Microsoft.FSharp.Collections if c < 0 then mem comparer k l elif c = 0 then true else mem comparer k r - | SetOne(k2) -> (comparer.Compare(k,k2) = 0) | SetEmpty -> false let rec iter f t = match t with | SetNode(k2,l,r,_) -> iter f l; f k2; iter f r - | SetOne(k2) -> f k2 | SetEmpty -> () let rec foldBackOpt (f:OptimizedClosures.FSharpFunc<_,_,_>) m x = match m with | SetNode(k,l,r,_) -> foldBackOpt f l (f.Invoke(k, (foldBackOpt f r x))) - | SetOne(k) -> f.Invoke(k, x) | SetEmpty -> x let foldBack f m x = foldBackOpt (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) m x @@ -251,7 +229,6 @@ namespace Microsoft.FSharp.Collections let x = foldOpt f x l in let x = f.Invoke(x, k) foldOpt f x r - | SetOne(k) -> f.Invoke(x, k) | SetEmpty -> x let fold f x m = foldOpt (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) x m @@ -259,13 +236,11 @@ namespace Microsoft.FSharp.Collections let rec forall f m = match m with | SetNode(k2,l,r,_) -> f k2 && forall f l && forall f r - | SetOne(k2) -> f k2 | SetEmpty -> true let rec exists f m = match m with | SetNode(k2,l,r,_) -> f k2 || exists f l || exists f r - | SetOne(k2) -> f k2 | SetEmpty -> false let isEmpty m = match m with | SetEmpty -> true | _ -> false @@ -279,7 +254,6 @@ namespace Microsoft.FSharp.Collections | SetNode(k,l,r,_) -> let acc = if f k then add comparer k acc else acc filterAux comparer f l (filterAux comparer f r acc) - | SetOne(k) -> if f k then add comparer k acc else acc | SetEmpty -> acc let filter comparer f s = filterAux comparer f s SetEmpty @@ -290,7 +264,6 @@ namespace Microsoft.FSharp.Collections | _ -> match m with | SetNode(k,l,r,_) -> diffAux comparer l (diffAux comparer r (remove comparer k acc)) - | SetOne(k) -> remove comparer k acc | SetEmpty -> acc let diff comparer a b = diffAux comparer b a @@ -311,8 +284,6 @@ namespace Microsoft.FSharp.Collections balance comparer (union comparer t21 lo) k2 (union comparer t22 hi) | SetEmpty,t -> t | t,SetEmpty -> t - | SetOne k1,t2 -> add comparer k1 t2 - | t1,SetOne k2 -> add comparer k2 t1 let rec intersectionAux comparer b m acc = match m with @@ -320,8 +291,6 @@ namespace Microsoft.FSharp.Collections let acc = intersectionAux comparer b r acc let acc = if mem comparer k b then add comparer k acc else acc intersectionAux comparer b l acc - | SetOne(k) -> - if mem comparer k b then add comparer k acc else acc | SetEmpty -> acc let intersection comparer a b = intersectionAux comparer b a SetEmpty @@ -334,7 +303,6 @@ namespace Microsoft.FSharp.Collections let acc = partitionAux comparer f r acc let acc = partition1 comparer f k acc partitionAux comparer f l acc - | SetOne(k) -> partition1 comparer f k acc | SetEmpty -> acc let partition comparer f s = partitionAux comparer f s (SetEmpty,SetEmpty) @@ -343,31 +311,26 @@ namespace Microsoft.FSharp.Collections let (|MatchSetNode|MatchSetEmpty|) s = match s with | SetNode(k2,l,r,_) -> MatchSetNode(k2,l,r) - | SetOne(k2) -> MatchSetNode(k2,SetEmpty,SetEmpty) | SetEmpty -> MatchSetEmpty let rec minimumElementAux s n = match s with | SetNode(k,l,_,_) -> minimumElementAux l k - | SetOne(k) -> k | SetEmpty -> n and minimumElementOpt s = match s with | SetNode(k,l,_,_) -> Some(minimumElementAux l k) - | SetOne(k) -> Some k | SetEmpty -> None and maximumElementAux s n = match s with | SetNode(k,_,r,_) -> maximumElementAux r k - | SetOne(k) -> k | SetEmpty -> n and maximumElementOpt s = match s with | SetNode(k,_,r,_) -> Some(maximumElementAux r k) - | SetOne(k) -> Some(k) | SetEmpty -> None let minimumElement s = @@ -398,8 +361,8 @@ namespace Microsoft.FSharp.Collections match stack with | [] -> [] | SetEmpty :: rest -> collapseLHS rest - | SetOne _ :: _ -> stack - | SetNode(k,l,r,_) :: rest -> collapseLHS (l :: SetOne k :: r :: rest) + | SetNode(_,_,_,1) :: _ -> stack + | SetNode(k,l,r,_) :: rest -> collapseLHS (l :: (mkLeaf k) :: r :: rest) let mkIterator s = { stack = collapseLHS [s]; started = false } @@ -409,7 +372,7 @@ namespace Microsoft.FSharp.Collections let current i = if i.started then match i.stack with - | SetOne k :: _ -> k + | SetNode(k,_,_,1) :: _ -> k | [] -> alreadyFinished() | _ -> failwith "Please report error: Set iterator, unexpected stack for current" else @@ -418,7 +381,7 @@ namespace Microsoft.FSharp.Collections let rec moveNext i = if i.started then match i.stack with - | SetOne _ :: rest -> + | SetNode(_,_,_,1) :: rest -> i.stack <- collapseLHS rest; not i.stack.IsEmpty | [] -> false @@ -448,24 +411,11 @@ namespace Microsoft.FSharp.Collections | [],_ -> -1 | _ ,[] -> 1 | (SetEmpty _ :: t1),(SetEmpty :: t2) -> compareStacks comparer t1 t2 - | (SetOne(n1k) :: t1),(SetOne(n2k) :: t2) -> - let c = comparer.Compare(n1k,n2k) - if c <> 0 then c else compareStacks comparer t1 t2 - | (SetOne(n1k) :: t1),(SetNode(n2k,SetEmpty,n2r,_) :: t2) -> - let c = comparer.Compare(n1k,n2k) - if c <> 0 then c else compareStacks comparer (SetEmpty :: t1) (n2r :: t2) - | (SetNode(n1k,(SetEmpty as emp),n1r,_) :: t1),(SetOne(n2k) :: t2) -> - let c = comparer.Compare(n1k,n2k) - if c <> 0 then c else compareStacks comparer (n1r :: t1) (emp :: t2) | (SetNode(n1k,SetEmpty,n1r,_) :: t1),(SetNode(n2k,SetEmpty,n2r,_) :: t2) -> let c = comparer.Compare(n1k,n2k) if c <> 0 then c else compareStacks comparer (n1r :: t1) (n2r :: t2) - | (SetOne(n1k) :: t1),_ -> - compareStacks comparer (SetEmpty :: SetOne(n1k) :: t1) l2 | (SetNode(n1k,n1l,n1r,_) :: t1),_ -> compareStacks comparer (n1l :: SetNode(n1k,SetEmpty,n1r,0) :: t1) l2 - | _,(SetOne(n2k) :: t2) -> - compareStacks comparer l1 (SetEmpty :: SetOne(n2k) :: t2) | _,(SetNode(n2k,n2l,n2r,_) :: t2) -> compareStacks comparer l1 (n2l :: SetNode(n2k,SetEmpty,n2r,0) :: t2) @@ -482,7 +432,6 @@ namespace Microsoft.FSharp.Collections let rec loop m acc = match m with | SetNode(k,l,r,_) -> loop l (k :: loop r acc) - | SetOne(k) -> k ::acc | SetEmpty -> acc loop s [] From 752fa52bc259f11697a475f4c1262523e0cef6e4 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Mon, 30 Jul 2018 19:06:31 +1000 Subject: [PATCH 62/92] Converted Set's height to size --- src/fsharp/FSharp.Core/set.fs | 43 +++++++++++++---------------------- 1 file changed, 16 insertions(+), 27 deletions(-) diff --git a/src/fsharp/FSharp.Core/set.fs b/src/fsharp/FSharp.Core/set.fs index 8ee68bcc900..be2f6e283b7 100644 --- a/src/fsharp/FSharp.Core/set.fs +++ b/src/fsharp/FSharp.Core/set.fs @@ -17,7 +17,7 @@ namespace Microsoft.FSharp.Collections [] type SetTree<'T> when 'T: comparison = | SetEmpty // height = 0 - | SetNode of 'T * SetTree<'T> * SetTree<'T> * int // height = int + | SetNode of 'T * SetTree<'T> * SetTree<'T> * Size:int // OPTIMIZATION: store SetNode(k,SetEmpty,SetEmpty,1) ---> SetOne(k) // REVIEW: performance rumour has it that the data held in SetNode and SetOne should be // exactly one cache line on typical architectures. They are currently @@ -26,13 +26,6 @@ namespace Microsoft.FSharp.Collections [] module internal SetTree = - let rec countAux s acc = - match s with - | SetNode(_,l,r,_) -> countAux l (countAux r (acc+1)) - | SetEmpty -> acc - - let count s = countAux s 0 - #if TRACE_SETS_AND_MAPS let mutable traceCount = 0 let mutable numOnes = 0 @@ -67,10 +60,10 @@ namespace Microsoft.FSharp.Collections #endif - let height t = + let size t = match t with | SetEmpty -> 0 - | SetNode (_,_,_,h) -> h + | SetNode (Size=s) -> s #if CHECKED let rec checkInvariant t = @@ -87,25 +80,21 @@ namespace Microsoft.FSharp.Collections let inline mkLeaf k = SetNode (k, SetEmpty, SetEmpty, 1) - let tolerance = 2 + let inline (++) l r = Checked.(+) l r let mk l k r = match l,r with | SetEmpty,SetEmpty -> mkLeaf k - | _ -> - let hl = height l - let hr = height r - let m = if hl < hr then hr else hl - SetNode(k,l,r,m+1) + | _ -> SetNode(k,l,r,(size l) ++ (size r) + 1) let rebalance t1 k t2 = - let t1h = height t1 - let t2h = height t2 - if t2h > t1h + tolerance then // right is heavier than left + let t1s = size t1 + let t2s = size t2 + if (t2s >>> 1) > t1s then // right is heavier than left match t2 with | SetNode(t2k,t2l,t2r,_) -> // one of the nodes must have height > height t1 + 1 - if height t2l > t1h + 1 then // balance left: combination + if size t2l > t1s then // balance left: combination match t2l with | SetNode(t2lk,t2ll,t2lr,_) -> mk (mk t1 k t2ll) t2lk (mk t2lr t2k t2r) @@ -114,11 +103,11 @@ namespace Microsoft.FSharp.Collections mk (mk t1 k t2l) t2k t2r | _ -> failwith "rebalance" else - if t1h > t2h + tolerance then // left is heavier than right + if (t1s >>> 1) > t2s then // left is heavier than right match t1 with | SetNode(t1k,t1l,t1r,_) -> // one of the nodes must have height > height t2 + 1 - if height t1r > t2h + 1 then + if size t1r > t2s then // balance right: combination match t1r with | SetNode(t1rk,t1rl,t1rr,_) -> @@ -145,16 +134,16 @@ namespace Microsoft.FSharp.Collections match t1,t2 with | SetEmpty,t2 -> add comparer k t2 // drop t1 = empty | t1,SetEmpty -> add comparer k t1 // drop t2 = empty - | SetNode(k1,t11,t12,h1),SetNode(k2,t21,t22,h2) -> + | SetNode(k1,t11,t12,s1),SetNode(k2,t21,t22,s2) -> // Have: (t11 < k1 < t12) < k < (t21 < k2 < t22) // Either (a) h1,h2 differ by at most 2 - no rebalance needed. // (b) h1 too small, i.e. h1+2 < h2 // (c) h2 too small, i.e. h2+2 < h1 - if h1+tolerance < h2 then + if s1 < (s2 >>> 1) then // case: b, h1 too small // push t1 into low side of t2, may increase height by 1 so rebalance rebalance (balance comparer t1 k t21) k2 t22 - elif h2+tolerance < h1 then + elif s2 < (s1 >>> 1) then // case: c, h2 too small // push t2 into high side of t1, may increase height by 1 so rebalance rebalance t11 k1 (balance comparer t12 k t2) @@ -440,7 +429,7 @@ namespace Microsoft.FSharp.Collections iter (fun x -> arr.[!j] <- x; j := !j + 1) s let toArray s = - let n = (count s) + let n = size s let res = Array.zeroCreate n copyToArray s res 0; res @@ -531,7 +520,7 @@ namespace Microsoft.FSharp.Collections #endif Set<'T>(s.Comparer,SetTree.remove s.Comparer value s.Tree) - member s.Count = SetTree.count s.Tree + member s.Count = SetTree.size s.Tree member s.Contains(value) = #if TRACE_SETS_AND_MAPS From 1f4c59b5b094454f6cb063b2f06042beffdaecc9 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Tue, 31 Jul 2018 19:30:35 +1000 Subject: [PATCH 63/92] Cut SetTree down to just SetNode --- src/fsharp/FSharp.Core/set.fs | 167 ++++++++++++++++------------------ 1 file changed, 76 insertions(+), 91 deletions(-) diff --git a/src/fsharp/FSharp.Core/set.fs b/src/fsharp/FSharp.Core/set.fs index be2f6e283b7..a3013ba7a51 100644 --- a/src/fsharp/FSharp.Core/set.fs +++ b/src/fsharp/FSharp.Core/set.fs @@ -13,16 +13,9 @@ namespace Microsoft.FSharp.Collections (* A classic functional language implementation of binary trees *) - [] [] type SetTree<'T> when 'T: comparison = - | SetEmpty // height = 0 | SetNode of 'T * SetTree<'T> * SetTree<'T> * Size:int - // OPTIMIZATION: store SetNode(k,SetEmpty,SetEmpty,1) ---> SetOne(k) - // REVIEW: performance rumour has it that the data held in SetNode and SetOne should be - // exactly one cache line on typical architectures. They are currently - // ~6 and 3 words respectively. - [] module internal SetTree = @@ -54,16 +47,14 @@ namespace Microsoft.FSharp.Collections let n = SetTree.SetNode(x,l,r,h) totalSizeOnNodeCreation <- totalSizeOnNodeCreation + float (count n); n - #else - let SetNode (x,l,r,h) = SetTree.SetNode(x,l,r,h) - #endif - - let size t = - match t with - | SetEmpty -> 0 - | SetNode (Size=s) -> s + [] + type Constants<'Key when 'Key : comparison> private () = + static let empty = SetNode(Unchecked.defaultof<'Key>, Unchecked.defaultof>, Unchecked.defaultof>, 0) + static member Empty = empty + + let size (SetNode (Size=s)) = s #if CHECKED let rec checkInvariant t = @@ -77,15 +68,11 @@ namespace Microsoft.FSharp.Collections (-2 <= (h1 - h2) && (h1 - h2) <= 2) && checkInvariant t1 && checkInvariant t2 #endif - let inline mkLeaf k = - SetNode (k, SetEmpty, SetEmpty, 1) - let inline (++) l r = Checked.(+) l r - let mk l k r = - match l,r with - | SetEmpty,SetEmpty -> mkLeaf k - | _ -> SetNode(k,l,r,(size l) ++ (size r) + 1) + let inline mkLeaf k = SetNode (k, Constants.Empty, Constants.Empty, 1) + + let inline mk l k r = SetNode(k,l,r,(size l) ++ (size r) + 1) let rebalance t1 k t2 = let t1s = size t1 @@ -98,10 +85,8 @@ namespace Microsoft.FSharp.Collections match t2l with | SetNode(t2lk,t2ll,t2lr,_) -> mk (mk t1 k t2ll) t2lk (mk t2lr t2k t2r) - | _ -> failwith "rebalance" else // rotate left mk (mk t1 k t2l) t2k t2r - | _ -> failwith "rebalance" else if (t1s >>> 1) > t2s then // left is heavier than right match t1 with @@ -112,28 +97,26 @@ namespace Microsoft.FSharp.Collections match t1r with | SetNode(t1rk,t1rl,t1rr,_) -> mk (mk t1l t1k t1rl) t1rk (mk t1rr k t2) - | _ -> failwith "rebalance" else mk t1l t1k (mk t1r k t2) - | _ -> failwith "rebalance" else mk t1 k t2 let rec add (comparer: IComparer<'T>) k t = match t with + | SetNode (Size=0) -> mkLeaf k | SetNode (k2,l,r,_) -> let c = comparer.Compare(k,k2) if c < 0 then rebalance (add comparer k l) k2 r elif c = 0 then t else rebalance l k2 (add comparer k r) - | SetEmpty -> mkLeaf k let rec balance comparer t1 k t2 = // Given t1 < k < t2 where t1 and t2 are "balanced", // return a balanced tree for . // Recall: balance means subtrees heights differ by at most "tolerance" match t1,t2 with - | SetEmpty,t2 -> add comparer k t2 // drop t1 = empty - | t1,SetEmpty -> add comparer k t1 // drop t2 = empty + | SetNode (Size=0),t2 -> add comparer k t2 // drop t1 = empty + | t1,SetNode (Size=0) -> add comparer k t1 // drop t2 = empty | SetNode(k1,t11,t12,s1),SetNode(k2,t21,t22,s2) -> // Have: (t11 < k1 < t12) < k < (t21 < k2 < t22) // Either (a) h1,h2 differ by at most 2 - no rebalance needed. @@ -155,6 +138,8 @@ namespace Microsoft.FSharp.Collections // Given a pivot and a set t // Return { x in t s.t. x < pivot }, pivot in t? , { x in t s.t. x > pivot } match t with + | SetNode(Size=0) -> + Constants.Empty,false,Constants.Empty | SetNode(k1,t11,t12,_) -> let c = comparer.Compare(pivot,k1) if c < 0 then // pivot t1 @@ -165,27 +150,25 @@ namespace Microsoft.FSharp.Collections else // pivot t2 let t12Lo,havePivot,t12Hi = split comparer pivot t12 balance comparer t11 k1 t12Lo,havePivot,t12Hi - | SetEmpty -> - SetEmpty,false,SetEmpty let rec spliceOutSuccessor t = match t with - | SetEmpty -> failwith "internal error: Set.spliceOutSuccessor" + | SetNode(Size=0) -> failwith "internal error: Set.spliceOutSuccessor" | SetNode (k2,l,r,_) -> match l with - | SetEmpty -> k2,r + | SetNode(Size=0) -> k2,r | _ -> let k3,l' = spliceOutSuccessor l in k3,mk l' k2 r let rec remove (comparer: IComparer<'T>) k t = match t with - | SetEmpty -> t + | SetNode(Size=0) -> t | SetNode (k2,l,r,_) -> let c = comparer.Compare(k,k2) if c < 0 then rebalance (remove comparer k l) k2 r elif c = 0 then match l,r with - | SetEmpty,_ -> r - | _,SetEmpty -> l + | SetNode(Size=0),_ -> r + | _,SetNode(Size=0) -> l | _ -> let sk,r' = spliceOutSuccessor r mk l sk r' @@ -193,46 +176,46 @@ namespace Microsoft.FSharp.Collections let rec mem (comparer: IComparer<'T>) k t = match t with + | SetNode(Size=0) -> false | SetNode(k2,l,r,_) -> let c = comparer.Compare(k,k2) if c < 0 then mem comparer k l elif c = 0 then true else mem comparer k r - | SetEmpty -> false let rec iter f t = match t with + | SetNode(Size=0) -> () | SetNode(k2,l,r,_) -> iter f l; f k2; iter f r - | SetEmpty -> () let rec foldBackOpt (f:OptimizedClosures.FSharpFunc<_,_,_>) m x = match m with + | SetNode(Size=0) -> x | SetNode(k,l,r,_) -> foldBackOpt f l (f.Invoke(k, (foldBackOpt f r x))) - | SetEmpty -> x let foldBack f m x = foldBackOpt (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) m x let rec foldOpt (f:OptimizedClosures.FSharpFunc<_,_,_>) x m = match m with + | SetNode(Size=0) -> x | SetNode(k,l,r,_) -> let x = foldOpt f x l in let x = f.Invoke(x, k) foldOpt f x r - | SetEmpty -> x let fold f x m = foldOpt (OptimizedClosures.FSharpFunc<_,_,_>.Adapt(f)) x m let rec forall f m = match m with + | SetNode(Size=0) -> true | SetNode(k2,l,r,_) -> f k2 && forall f l && forall f r - | SetEmpty -> true let rec exists f m = match m with + | SetNode(Size=0) -> false | SetNode(k2,l,r,_) -> f k2 || exists f l || exists f r - | SetEmpty -> false - let isEmpty m = match m with | SetEmpty -> true | _ -> false + let isEmpty (SetNode(Size=s)) = s = 0 let subset comparer a b = forall (fun x -> mem comparer x b) a @@ -240,26 +223,28 @@ namespace Microsoft.FSharp.Collections let rec filterAux comparer f s acc = match s with + | SetNode(Size=0) -> acc | SetNode(k,l,r,_) -> let acc = if f k then add comparer k acc else acc filterAux comparer f l (filterAux comparer f r acc) - | SetEmpty -> acc - let filter comparer f s = filterAux comparer f s SetEmpty + let filter comparer f s = filterAux comparer f s Constants.Empty let rec diffAux comparer m acc = match acc with - | SetEmpty -> acc + | SetNode(Size=0) -> acc | _ -> match m with + | SetNode(Size=0) -> acc | SetNode(k,l,r,_) -> diffAux comparer l (diffAux comparer r (remove comparer k acc)) - | SetEmpty -> acc let diff comparer a b = diffAux comparer b a let rec union comparer t1 t2 = // Perf: tried bruteForce for low heights, but nothing significant match t1,t2 with + | SetNode(Size=0),t -> t + | t,SetNode(Size=0) -> t | SetNode(k1,t11,t12,h1),SetNode(k2,t21,t22,h2) -> // (t11 < k < t12) AND (t21 < k2 < t22) // Divide and Conquer: // Suppose t1 is largest. @@ -271,56 +256,54 @@ namespace Microsoft.FSharp.Collections else let lo,_,hi = split comparer k2 t1 in balance comparer (union comparer t21 lo) k2 (union comparer t22 hi) - | SetEmpty,t -> t - | t,SetEmpty -> t let rec intersectionAux comparer b m acc = match m with + | SetNode(Size=0) -> acc | SetNode(k,l,r,_) -> let acc = intersectionAux comparer b r acc let acc = if mem comparer k b then add comparer k acc else acc intersectionAux comparer b l acc - | SetEmpty -> acc - let intersection comparer a b = intersectionAux comparer b a SetEmpty + let intersection comparer a b = intersectionAux comparer b a Constants.Empty let partition1 comparer f k (acc1,acc2) = if f k then (add comparer k acc1,acc2) else (acc1,add comparer k acc2) let rec partitionAux comparer f s acc = match s with + | SetNode(Size=0) -> acc | SetNode(k,l,r,_) -> let acc = partitionAux comparer f r acc let acc = partition1 comparer f k acc partitionAux comparer f l acc - | SetEmpty -> acc - let partition comparer f s = partitionAux comparer f s (SetEmpty,SetEmpty) + let partition comparer f s = partitionAux comparer f s (Constants.Empty,Constants.Empty) - // It's easier to get many less-important algorithms right using this active pattern - let (|MatchSetNode|MatchSetEmpty|) s = - match s with - | SetNode(k2,l,r,_) -> MatchSetNode(k2,l,r) - | SetEmpty -> MatchSetEmpty + //// It's easier to get many less-important algorithms right using this active pattern + //let (|MatchSetNode|MatchSetEmpty|) s = + // match s with + // | SetNode(Size=0) -> MatchSetEmpty + // | SetNode(k2,l,r,_) -> MatchSetNode(k2,l,r) let rec minimumElementAux s n = match s with + | SetNode(Size=0) -> n | SetNode(k,l,_,_) -> minimumElementAux l k - | SetEmpty -> n and minimumElementOpt s = match s with + | SetNode(Size=0) -> None | SetNode(k,l,_,_) -> Some(minimumElementAux l k) - | SetEmpty -> None and maximumElementAux s n = match s with + | SetNode(Size=0) -> n | SetNode(k,_,r,_) -> maximumElementAux r k - | SetEmpty -> n and maximumElementOpt s = match s with + | SetNode(Size=0) -> None | SetNode(k,_,r,_) -> Some(maximumElementAux r k) - | SetEmpty -> None let minimumElement s = match minimumElementOpt s with @@ -349,7 +332,7 @@ namespace Microsoft.FSharp.Collections let rec collapseLHS stack = match stack with | [] -> [] - | SetEmpty :: rest -> collapseLHS rest + | SetNode(Size=0) :: rest -> collapseLHS rest | SetNode(_,_,_,1) :: _ -> stack | SetNode(k,l,r,_) :: rest -> collapseLHS (l :: (mkLeaf k) :: r :: rest) @@ -394,34 +377,36 @@ namespace Microsoft.FSharp.Collections // Set comparison. This can be expensive. //-------------------------------------------------------------------------- - let rec compareStacks (comparer: IComparer<'T>) l1 l2 = + let (^^) hd tl = + match hd with + | SetNode(Size=0) -> tl + | _ -> hd::tl + + let rec compareStacks (comparer:IComparer<'T>) l1 l2 = match l1,l2 with | [],[] -> 0 | [],_ -> -1 | _ ,[] -> 1 - | (SetEmpty _ :: t1),(SetEmpty :: t2) -> compareStacks comparer t1 t2 - | (SetNode(n1k,SetEmpty,n1r,_) :: t1),(SetNode(n2k,SetEmpty,n2r,_) :: t2) -> - let c = comparer.Compare(n1k,n2k) - if c <> 0 then c else compareStacks comparer (n1r :: t1) (n2r :: t2) - | (SetNode(n1k,n1l,n1r,_) :: t1),_ -> - compareStacks comparer (n1l :: SetNode(n1k,SetEmpty,n1r,0) :: t1) l2 - | _,(SetNode(n2k,n2l,n2r,_) :: t2) -> - compareStacks comparer l1 (n2l :: SetNode(n2k,SetEmpty,n2r,0) :: t2) + | (SetNode(n1k,SetNode(Size=0),n1r,_)::t1),(SetNode(n2k,SetNode(Size=0),n2r,_)::t2) -> + match comparer.Compare (n1k,n2k) with + | 0 -> compareStacks comparer (n1r ^^ t1) (n2r ^^ t2) + | c -> c + | (SetNode(n1k,(SetNode(Size=n1ls) as n1l),n1r,_)::t1),_ when n1ls > 0 -> + compareStacks comparer (n1l ^^ (mk Constants.Empty n1k n1r) ^^ t1) l2 + | _,(SetNode(n2k,n2l,n2r,_)::t2) -> + compareStacks comparer l1 (n2l ^^ (mk Constants.Empty n2k n2r) ^^ t2) - let compare comparer s1 s2 = - match s1,s2 with - | SetEmpty,SetEmpty -> 0 - | SetEmpty,_ -> -1 - | _,SetEmpty -> 1 - | _ -> compareStacks comparer [s1] [s2] + let compare comparer s1 s2 = + if obj.ReferenceEquals (s1,s2) then 0 + else compareStacks comparer (s1 ^^ []) (s2 ^^ []) let choose s = minimumElement s let toList s = let rec loop m acc = match m with + | SetNode(Size=0) -> acc | SetNode(k,l,r,_) -> loop l (k :: loop r acc) - | SetEmpty -> acc loop s [] let copyToArray s (arr: _[]) i = @@ -443,9 +428,9 @@ namespace Microsoft.FSharp.Collections let ofSeq comparer (c: IEnumerable<_>) = use ie = c.GetEnumerator() - mkFromEnumerator comparer SetEmpty ie + mkFromEnumerator comparer Constants.Empty ie - let ofArray comparer l = Array.fold (fun acc k -> add comparer k acc) SetEmpty l + let ofArray comparer l = Array.fold (fun acc k -> add comparer k acc) Constants.Empty l [] @@ -476,7 +461,7 @@ namespace Microsoft.FSharp.Collections static let empty: Set<'T> = let comparer = LanguagePrimitives.FastGenericComparer<'T> - Set<'T>(comparer, SetEmpty) + Set<'T>(comparer, SetTree.Constants.Empty) #if !FX_NO_BINARY_SERIALIZATION [] @@ -541,17 +526,17 @@ namespace Microsoft.FSharp.Collections member s.Partition f : Set<'T> * Set<'T> = match s.Tree with - | SetEmpty -> s,s + | SetNode(Size=0) -> s,s | _ -> let t1,t2 = SetTree.partition s.Comparer f s.Tree in Set(s.Comparer,t1), Set(s.Comparer,t2) member s.Filter f : Set<'T> = match s.Tree with - | SetEmpty -> s + | SetNode(Size=0) -> s | _ -> Set(s.Comparer,SetTree.filter s.Comparer f s.Tree) member s.Map f : Set<'U> = let comparer = LanguagePrimitives.FastGenericComparer<'U> - Set(comparer,SetTree.fold (fun acc k -> SetTree.add comparer (f k) acc) (SetTree<_>.SetEmpty) s.Tree) + Set(comparer,SetTree.fold (fun acc k -> SetTree.add comparer (f k) acc) SetTree.Constants.Empty s.Tree) member s.Exists f = SetTree.exists f s.Tree @@ -560,10 +545,10 @@ namespace Microsoft.FSharp.Collections [] static member (-) (set1: Set<'T>, set2: Set<'T>) = match set1.Tree with - | SetEmpty -> set1 (* 0 - B = 0 *) + | SetNode(Size=0) -> set1 (* 0 - B = 0 *) | _ -> match set2.Tree with - | SetEmpty -> set1 (* A - 0 = A *) + | SetNode(Size=0) -> set1 (* A - 0 = A *) | _ -> Set(set1.Comparer,SetTree.diff set1.Comparer set1.Tree set2.Tree) [] @@ -573,18 +558,18 @@ namespace Microsoft.FSharp.Collections SetTree.numUnions <- SetTree.numUnions + 1 #endif match set2.Tree with - | SetEmpty -> set1 (* A U 0 = A *) + | SetNode(Size=0) -> set1 (* A U 0 = A *) | _ -> match set1.Tree with - | SetEmpty -> set2 (* 0 U B = B *) + | SetNode(Size=0) -> set2 (* 0 U B = B *) | _ -> Set(set1.Comparer,SetTree.union set1.Comparer set1.Tree set2.Tree) static member Intersection(a: Set<'T>, b: Set<'T>) : Set<'T> = match b.Tree with - | SetEmpty -> b (* A INTER 0 = 0 *) + | SetNode(Size=0) -> b (* A INTER 0 = 0 *) | _ -> match a.Tree with - | SetEmpty -> a (* 0 INTER B = 0 *) + | SetNode(Size=0) -> a (* 0 INTER B = 0 *) | _ -> Set(a.Comparer,SetTree.intersection a.Comparer a.Tree b.Tree) static member Union(sets:seq>) : Set<'T> = From 45509bd44414ae0edbe8379e74aa42033b25d044 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Wed, 1 Aug 2018 19:31:41 +1000 Subject: [PATCH 64/92] rebalance split and add from Map --- src/fsharp/FSharp.Core/set.fs | 74 +++++++++++++++++++---------------- 1 file changed, 41 insertions(+), 33 deletions(-) diff --git a/src/fsharp/FSharp.Core/set.fs b/src/fsharp/FSharp.Core/set.fs index a3013ba7a51..8e476e0d40c 100644 --- a/src/fsharp/FSharp.Core/set.fs +++ b/src/fsharp/FSharp.Core/set.fs @@ -74,41 +74,49 @@ namespace Microsoft.FSharp.Collections let inline mk l k r = SetNode(k,l,r,(size l) ++ (size r) + 1) - let rebalance t1 k t2 = - let t1s = size t1 - let t2s = size t2 - if (t2s >>> 1) > t1s then // right is heavier than left - match t2 with - | SetNode(t2k,t2l,t2r,_) -> - // one of the nodes must have height > height t1 + 1 - if size t2l > t1s then // balance left: combination - match t2l with - | SetNode(t2lk,t2ll,t2lr,_) -> - mk (mk t1 k t2ll) t2lk (mk t2lr t2k t2r) - else // rotate left - mk (mk t1 k t2l) t2k t2r + let private rebalanceRight l k (SetNode(rk,rl,rr,_)) = + (* one of the nodes must have height > height t1 + 1 *) + if size rl > size l then (* balance left: combination *) + match rl with + | SetNode(rlk,rll,rlr,_) -> mk (mk l k rll) rlk (mk rlr rk rr) + else (* rotate left *) + mk (mk l k rl) rk rr + + let private rebalanceLeft (SetNode(lk,ll,lr,_)) k r = + (* one of the nodes must have height > height t2 + 1 *) + if size lr > size r then + (* balance right: combination *) + match lr with + | SetNode(lrk,lrl,lrr,_) -> mk (mk ll lk lrl) lrk (mk lrr k r) + else + mk ll lk (mk lr k r) + + let inline rebalance l k r = + let ls, rs = size l, size r + if (rs >>> 1) > ls then rebalanceRight l k r + elif (ls >>> 1) > rs then rebalanceLeft l k r + else SetNode (k,l,r, ls ++ rs ++ 1) + + let rec add (comparer:IComparer<'Key>) k (SetNode(k2,l,r,s)) = + if s = 0 then mkLeaf k else - if (t1s >>> 1) > t2s then // left is heavier than right - match t1 with - | SetNode(t1k,t1l,t1r,_) -> - // one of the nodes must have height > height t2 + 1 - if size t1r > t2s then - // balance right: combination - match t1r with - | SetNode(t1rk,t1rl,t1rr,_) -> - mk (mk t1l t1k t1rl) t1rk (mk t1rr k t2) - else - mk t1l t1k (mk t1r k t2) - else mk t1 k t2 - - let rec add (comparer: IComparer<'T>) k t = - match t with - | SetNode (Size=0) -> mkLeaf k - | SetNode (k2,l,r,_) -> let c = comparer.Compare(k,k2) - if c < 0 then rebalance (add comparer k l) k2 r - elif c = 0 then t - else rebalance l k2 (add comparer k r) + if c < 0 then + let l' = add comparer k l + let l's, rs = size l', size r + if (l's >>> 1) > rs then + rebalanceLeft l' k2 r + else + SetNode (k2,l',r, l's ++ rs ++ 1) + elif c > 0 then + let r' = add comparer k r + let ls, r's = size l, size r' + if (r's >>> 1) > ls then + rebalanceRight l k2 r' + else + SetNode (k2,l,r', ls ++ r's ++ 1) + else + SetNode(k,l,r,s) let rec balance comparer t1 k t2 = // Given t1 < k < t2 where t1 and t2 are "balanced", From ba7392e42b644d0955d80c14d0f192491460ac40 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sun, 5 Aug 2018 07:10:16 +1000 Subject: [PATCH 65/92] Easy case Zmap to Map --- src/absil/ilreflect.fs | 74 +++++++++++------------ src/fsharp/InnerLambdasToTopLevelFuncs.fs | 8 +++ src/fsharp/lib.fs | 3 + 3 files changed, 46 insertions(+), 39 deletions(-) diff --git a/src/absil/ilreflect.fs b/src/absil/ilreflect.fs index c07408e8ab6..b48e7fbd82f 100644 --- a/src/absil/ilreflect.fs +++ b/src/absil/ilreflect.fs @@ -27,8 +27,6 @@ open Microsoft.FSharp.Core.Printf open Microsoft.FSharp.Core.ReflectionAdapters #endif -let codeLabelOrder = ComparisonIdentity.Structural - // Convert the output of convCustomAttr open Microsoft.FSharp.Compiler.AbstractIL.ILAsciiWriter let wrapCustomAttr setCustomAttr (cinfo, bytes) = @@ -284,6 +282,9 @@ type System.Reflection.Emit.ILGenerator with let inline flagsIf b x = if b then x else enum 0 +module Map = + let force x m str = match Map.tryFind x m with Some y -> y | None -> failwithf "Map.force: %s: x = %+A" str x + module Zmap = let force x m str = match Zmap.tryFind x m with Some y -> y | None -> failwithf "Zmap.force: %s: x = %+A" str x @@ -363,30 +364,25 @@ let convTypeRefAux (cenv:cenv) (tref:ILTypeRef) = /// and could be placed as hash tables in the global environment. [] type emEnv = - { emTypMap : Zmap ; - emConsMap : Zmap; - emMethMap : Zmap; - emFieldMap : Zmap; - emPropMap : Zmap; + { emTypMap : Map + emConsMap : Map; + emMethMap : Map + emFieldMap : Map + emPropMap : Map emLocals : LocalBuilder[]; - emLabels : Zmap; + emLabels : Map emTyvars : Type[] list; // stack emEntryPts : (TypeBuilder * string) list delayedFieldInits : (unit -> unit) list} -let orderILTypeRef = ComparisonIdentity.Structural -let orderILMethodRef = ComparisonIdentity.Structural -let orderILFieldRef = ComparisonIdentity.Structural -let orderILPropertyRef = ComparisonIdentity.Structural - let emEnv0 = - { emTypMap = Zmap.empty orderILTypeRef; - emConsMap = Zmap.empty orderILMethodRef; - emMethMap = Zmap.empty orderILMethodRef; - emFieldMap = Zmap.empty orderILFieldRef; - emPropMap = Zmap.empty orderILPropertyRef; + { emTypMap = Map.empty + emConsMap = Map.empty + emMethMap = Map.empty + emFieldMap = Map.empty + emPropMap = Map.empty emLocals = [| |]; - emLabels = Zmap.empty codeLabelOrder; + emLabels = Map.empty emTyvars = []; emEntryPts = [] delayedFieldInits = [] } @@ -394,13 +390,13 @@ let emEnv0 = let envBindTypeRef emEnv (tref:ILTypeRef) (typT, typB, typeDef)= match typT with | null -> failwithf "binding null type in envBindTypeRef: %s\n" tref.Name; - | _ -> {emEnv with emTypMap = Zmap.add tref (typT, typB, typeDef, None) emEnv.emTypMap} + | _ -> {emEnv with emTypMap = Map.add tref (typT, typB, typeDef, None) emEnv.emTypMap} let envUpdateCreatedTypeRef emEnv (tref:ILTypeRef) = // The tref's TypeBuilder has been created, so we have a Type proper. // Update the tables to include this created type (the typT held prior to this is (i think) actually (TypeBuilder :> Type). // The (TypeBuilder :> Type) does not implement all the methods that a Type proper does. - let typT, typB, typeDef, _createdTypOpt = Zmap.force tref emEnv.emTypMap "envGetTypeDef: failed" + let typT, typB, typeDef, _createdTypOpt = Map.force tref emEnv.emTypMap "envGetTypeDef: failed" if typB.IsCreated() then let ty = typB.CreateTypeAndLog() #if ENABLE_MONO_SUPPORT @@ -415,7 +411,7 @@ let envUpdateCreatedTypeRef emEnv (tref:ILTypeRef) = System.Runtime.Serialization.FormatterServices.GetUninitializedObject(ty) |> ignore with e -> () #endif - {emEnv with emTypMap = Zmap.add tref (typT, typB, typeDef, Some ty) emEnv.emTypMap} + {emEnv with emTypMap = Map.add tref (typT, typB, typeDef, Some ty) emEnv.emTypMap} else #if DEBUG printf "envUpdateCreatedTypeRef: expected type to be created\n"; @@ -424,7 +420,7 @@ let envUpdateCreatedTypeRef emEnv (tref:ILTypeRef) = let convTypeRef cenv emEnv preferCreated (tref:ILTypeRef) = let res = - match Zmap.tryFind tref emEnv.emTypMap with + match Map.tryFind tref emEnv.emTypMap with | Some (_typT, _typB, _typeDef, Some createdTy) when preferCreated -> createdTy | Some (typT, _typB, _typeDef, _) -> typT | None -> convTypeRefAux cenv tref @@ -433,35 +429,35 @@ let convTypeRef cenv emEnv preferCreated (tref:ILTypeRef) = | _ -> res let envBindConsRef emEnv (mref:ILMethodRef) consB = - {emEnv with emConsMap = Zmap.add mref consB emEnv.emConsMap} + {emEnv with emConsMap = Map.add mref consB emEnv.emConsMap} let envGetConsB emEnv (mref:ILMethodRef) = - Zmap.force mref emEnv.emConsMap "envGetConsB: failed" + Map.force mref emEnv.emConsMap "envGetConsB: failed" let envBindMethodRef emEnv (mref:ILMethodRef) methB = - {emEnv with emMethMap = Zmap.add mref methB emEnv.emMethMap} + {emEnv with emMethMap = Map.add mref methB emEnv.emMethMap} let envGetMethB emEnv (mref:ILMethodRef) = - Zmap.force mref emEnv.emMethMap "envGetMethB: failed" + Map.force mref emEnv.emMethMap "envGetMethB: failed" let envBindFieldRef emEnv fref fieldB = - {emEnv with emFieldMap = Zmap.add fref fieldB emEnv.emFieldMap} + {emEnv with emFieldMap = Map.add fref fieldB emEnv.emFieldMap} let envGetFieldB emEnv fref = - Zmap.force fref emEnv.emFieldMap "- envGetMethB: failed" + Map.force fref emEnv.emFieldMap "- envGetMethB: failed" let envBindPropRef emEnv (pref:ILPropertyRef) propB = - {emEnv with emPropMap = Zmap.add pref propB emEnv.emPropMap} + {emEnv with emPropMap = Map.add pref propB emEnv.emPropMap} let envGetPropB emEnv pref = - Zmap.force pref emEnv.emPropMap "- envGetPropB: failed" + Map.force pref emEnv.emPropMap "- envGetPropB: failed" let envGetTypB emEnv (tref:ILTypeRef) = - Zmap.force tref emEnv.emTypMap "envGetTypB: failed" + Map.force tref emEnv.emTypMap "envGetTypB: failed" |> (fun (_typT, typB, _typeDef, _createdTypOpt) -> typB) let envGetTypeDef emEnv (tref:ILTypeRef) = - Zmap.force tref emEnv.emTypMap "envGetTypeDef: failed" + Map.force tref emEnv.emTypMap "envGetTypeDef: failed" |> (fun (_typT, _typB, typeDef, _createdTypOpt) -> typeDef) let envSetLocals emEnv locs = assert (emEnv.emLocals.Length = 0); // check "locals" is not yet set (scopes once only) @@ -469,11 +465,11 @@ let envSetLocals emEnv locs = assert (emEnv.emLocals.Length = 0); // check "loca let envGetLocal emEnv i = emEnv.emLocals.[i] // implicit bounds checking let envSetLabel emEnv name lab = - assert (not (Zmap.mem name emEnv.emLabels)); - {emEnv with emLabels = Zmap.add name lab emEnv.emLabels} + assert (not (Map.containsKey name emEnv.emLabels)); + {emEnv with emLabels = Map.add name lab emEnv.emLabels} let envGetLabel emEnv name = - Zmap.find name emEnv.emLabels + Map.find name emEnv.emLabels let envPushTyvars emEnv tys = {emEnv with emTyvars = tys :: emEnv.emTyvars} let envPopTyvars emEnv = {emEnv with emTyvars = List.tail emEnv.emTyvars} @@ -487,7 +483,7 @@ let envGetTyvar emEnv u16 = else tvs.[i] -let isEmittedTypeRef emEnv tref = Zmap.mem tref emEnv.emTypMap +let isEmittedTypeRef emEnv tref = Map.containsKey tref emEnv.emTypMap let envAddEntryPt emEnv mref = {emEnv with emEntryPts = mref::emEnv.emEntryPts} let envPopEntryPts emEnv = {emEnv with emEntryPts = []}, emEnv.emEntryPts @@ -2147,6 +2143,6 @@ let LookupTypeRef cenv emEnv tref = convCreatedTypeRef cenv emEnv tref let LookupType cenv emEnv ty = convCreatedType cenv emEnv ty // Lookups of ILFieldRef and MethodRef may require a similar non-Builder-fixup post Type-creation. -let LookupFieldRef emEnv fref = Zmap.tryFind fref emEnv.emFieldMap |> Option.map (fun fieldBuilder -> fieldBuilder :> FieldInfo) -let LookupMethodRef emEnv mref = Zmap.tryFind mref emEnv.emMethMap |> Option.map (fun methodBuilder -> methodBuilder :> MethodInfo) +let LookupFieldRef emEnv fref = Map.tryFind fref emEnv.emFieldMap |> Option.map (fun fieldBuilder -> fieldBuilder :> FieldInfo) +let LookupMethodRef emEnv mref = Map.tryFind mref emEnv.emMethMap |> Option.map (fun methodBuilder -> methodBuilder :> MethodInfo) diff --git a/src/fsharp/InnerLambdasToTopLevelFuncs.fs b/src/fsharp/InnerLambdasToTopLevelFuncs.fs index da5c49f4bb7..2eb45de1495 100644 --- a/src/fsharp/InnerLambdasToTopLevelFuncs.fs +++ b/src/fsharp/InnerLambdasToTopLevelFuncs.fs @@ -24,6 +24,14 @@ let verboseTLR = false let internalError str = dprintf "Error: %s\n" str;raise (Failure str) +module Map = + let force k mp (str,soK) = + try Map.find k mp + with e -> + dprintf "Map.force: %s %s\n" str (soK k); + PreserveStackTrace(e) + raise e + module Zmap = let force k mp (str,soK) = try Zmap.find k mp diff --git a/src/fsharp/lib.fs b/src/fsharp/lib.fs index 3d5e854aff8..fb31c9803c2 100755 --- a/src/fsharp/lib.fs +++ b/src/fsharp/lib.fs @@ -286,6 +286,9 @@ module List = // Zmap rebinds //------------------------------------------------------------------------- +module Map = + let force k mp = match Map.tryFind k mp with Some x -> x | None -> failwith "Map.force: lookup failed" + module Zmap = let force k mp = match Zmap.tryFind k mp with Some x -> x | None -> failwith "Zmap.force: lookup failed" From fcef137cdf57645c9dc95f34384a974c4a930213 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sun, 5 Aug 2018 12:59:50 +1000 Subject: [PATCH 66/92] Removed IntMap --- src/fsharp/IlxGen.fs | 17 ++++++++--------- src/fsharp/lib.fs | 21 --------------------- src/fsharp/range.fs | 3 +++ 3 files changed, 11 insertions(+), 30 deletions(-) diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index 23c4af9526f..75674b4ef99 100644 --- a/src/fsharp/IlxGen.fs +++ b/src/fsharp/IlxGen.fs @@ -696,8 +696,7 @@ and IlxGenEnv = /// Full list of enclosing bound values. First non-compiler-generated element is used to help give nice names for closures and other expressions. letBoundVars: ValRef list /// The set of IL local variable indexes currently in use by lexically scoped variables, to allow reuse on different branches. - /// Really an integer set. - liveLocals: IntMap + liveLocals: Set /// Are we under the scope of a try, catch or finally? If so we can't tailcall. SEH = structured exception handling withinSEH: bool } @@ -1588,7 +1587,7 @@ let CodeGenThen cenv mgbuf (entryPointInfo,methodName,eenv,alreadyUsedArgs,alrea (* Call the given code generator *) codeGenFunction cgbuf {eenv with withinSEH=false - liveLocals=IntMap.empty() + liveLocals=Set.empty innerVals = innerVals} let locals,maxStack,lab2pc,code,exnSpecs,hasSequencePoints = cgbuf.Close() @@ -4309,11 +4308,11 @@ and GenMatch cenv cgbuf eenv (spBind,_exprm,tree,targets,m,ty) sequel = // Accumulate the decision graph as we go and GenDecisionTreeAndTargets cenv cgbuf stackAtTargets eenv tree targets repeatSP sequel = - let targetInfos = GenDecisionTreeAndTargetsInner cenv cgbuf None stackAtTargets eenv tree targets repeatSP (IntMap.empty()) sequel + let targetInfos = GenDecisionTreeAndTargetsInner cenv cgbuf None stackAtTargets eenv tree targets repeatSP Map.empty sequel GenPostponedDecisionTreeTargets cenv cgbuf stackAtTargets targetInfos sequel and TryFindTargetInfo targetInfos n = - match IntMap.tryFind n targetInfos with + match Map.tryFind n targetInfos with | Some (targetInfo,_) -> Some targetInfo | None -> None @@ -4389,7 +4388,7 @@ and GenDecisionTreeSuccess cenv cgbuf inplabOpt stackAtTargets eenv es targetIdx CG.EmitInstr cgbuf (pop 0) Push0 (I_br targetMarkBeforeBinds.CodeLabel) true - let targetInfos = IntMap.add targetIdx (targetInfo,isTargetPostponed) targetInfos + let targetInfos = Map.add targetIdx (targetInfo,isTargetPostponed) targetInfos targetInfos and GenPostponedDecisionTreeTargets cenv cgbuf stackAtTargets targetInfos sequel = @@ -5582,9 +5581,9 @@ and AllocLocal cenv cgbuf eenv compgen (v,ty,isFixed) (scopeMarks: Mark * Mark) // Get an index for the local let j = if cenv.opts.localOptimizationsAreOn - then cgbuf.ReallocLocal((fun i (_,ty',isFixed') -> not isFixed' && not isFixed && not (IntMap.mem i eenv.liveLocals) && (ty = ty')),ranges,ty,isFixed) + then cgbuf.ReallocLocal((fun i (_,ty',isFixed') -> not isFixed' && not isFixed && not (Set.contains i eenv.liveLocals) && (ty = ty')),ranges,ty,isFixed) else cgbuf.AllocLocal(ranges,ty,isFixed) - j, { eenv with liveLocals = IntMap.add j () eenv.liveLocals } + j, { eenv with liveLocals = Set.add j eenv.liveLocals } and AllocLocalVal cenv cgbuf v eenv repr scopeMarks = let repr,eenv = @@ -6918,7 +6917,7 @@ let GetEmptyIlxGenEnv (ilg : ILGlobals) ccu = someTypeInThisAssembly=ilg.typ_Object (* dummy value *) isFinalFile = false letBoundVars=[] - liveLocals=IntMap.empty() + liveLocals=Set.empty innerVals = [] sigToImplRemapInfo = [] (* "module remap info" *) withinSEH = false } diff --git a/src/fsharp/lib.fs b/src/fsharp/lib.fs index fb31c9803c2..c8d65730098 100755 --- a/src/fsharp/lib.fs +++ b/src/fsharp/lib.fs @@ -74,9 +74,6 @@ module Filename = module Bool = let order = LanguagePrimitives.FastGenericComparer -module Int32 = - let order = LanguagePrimitives.FastGenericComparer - module Int64 = let order = LanguagePrimitives.FastGenericComparer @@ -133,24 +130,6 @@ module Check = if s.Length = 0 then raise (new System.ArgumentNullException(argname)) -//------------------------------------------------------------------------- -// Library -//------------------------------------------------------------------------ - -type IntMap<'T> = Zmap -module IntMap = - let empty () = Zmap.empty Int32.order - - let add k v (t:IntMap<'T>) = Zmap.add k v t - let find k (t:IntMap<'T>) = Zmap.find k t - let tryFind k (t:IntMap<'T>) = Zmap.tryFind k t - let remove k (t:IntMap<'T>) = Zmap.remove k t - let mem k (t:IntMap<'T>) = Zmap.mem k t - let iter f (t:IntMap<'T>) = Zmap.iter f t - let map f (t:IntMap<'T>) = Zmap.map f t - let fold f (t:IntMap<'T>) z = Zmap.fold f t z - - //------------------------------------------------------------------------- // Library: generalized association lists //------------------------------------------------------------------------ diff --git a/src/fsharp/range.fs b/src/fsharp/range.fs index 8649b700867..b4fc973e168 100755 --- a/src/fsharp/range.fs +++ b/src/fsharp/range.fs @@ -197,6 +197,9 @@ let mkRange f b e = let mkFileIndexRange fi b e = range (fi, b, e) (* end representation, start derived ops *) + +module Int32 = + let order = LanguagePrimitives.FastGenericComparer let posOrder = Order.orderOn (fun (p:pos) -> p.Line, p.Column) (Pair.order (Int32.order, Int32.order)) (* rangeOrder: not a total order, but enough to sort on ranges *) From e4575bcf21bddd48f2d7a7f458b1054eb45776b1 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sun, 5 Aug 2018 19:10:20 +1000 Subject: [PATCH 67/92] Added SortKey as Adapter for Map to use IComparable --- .../FSharp.Compiler.Service.fsproj | 3 ++ .../FSharp.Compiler.Private.fsproj | 3 ++ .../FSharp.Compiler.Private.fsproj | 3 ++ src/fsharp/Fsc-proto/Fsc-proto.fsproj | 3 ++ src/fsharp/NicePrint.fs | 3 +- src/fsharp/TastOps.fs | 22 ++++++---- src/fsharp/TastOps.fsi | 7 ++- src/utils/SortKey.fs | 43 +++++++++++++++++++ 8 files changed, 77 insertions(+), 10 deletions(-) create mode 100644 src/utils/SortKey.fs diff --git a/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj b/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj index 489b9188a2b..f25e6e01060 100644 --- a/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj +++ b/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj @@ -117,6 +117,9 @@ Utilities/TaggedCollections.fs + + Utilities/SortKey.fs + Utilities/QueueList.fs diff --git a/src/buildfromsource/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj b/src/buildfromsource/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj index 1668c425ebe..4f2b71ef4b6 100644 --- a/src/buildfromsource/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj +++ b/src/buildfromsource/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj @@ -81,6 +81,9 @@ Utilities\TaggedCollections.fs + + Utilities\SortKey.fs + Utilities\ildiag.fsi diff --git a/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj b/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj index 4b5affe091c..68d6522fd22 100644 --- a/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj +++ b/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj @@ -119,6 +119,9 @@ Utilities\TaggedCollections.fs + + Utilities\SortKey.fs + Utilities\ildiag.fsi diff --git a/src/fsharp/Fsc-proto/Fsc-proto.fsproj b/src/fsharp/Fsc-proto/Fsc-proto.fsproj index 5cccf4f17a2..711438aba0b 100644 --- a/src/fsharp/Fsc-proto/Fsc-proto.fsproj +++ b/src/fsharp/Fsc-proto/Fsc-proto.fsproj @@ -103,6 +103,9 @@ TaggedCollections.fs + + SortKey.fs + Utilities\ildiag.fsi diff --git a/src/fsharp/NicePrint.fs b/src/fsharp/NicePrint.fs index f0964312245..5755513dfde 100755 --- a/src/fsharp/NicePrint.fs +++ b/src/fsharp/NicePrint.fs @@ -6,6 +6,7 @@ module internal Microsoft.FSharp.Compiler.NicePrint +open Internal.Utilities.Collections open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.AbstractIL.Internal @@ -761,7 +762,7 @@ module private PrintTypes = let varL = layoutTyparRef denv typar let varL = if denv.showAttributes then layoutTyparAttribs denv typar.Kind typar.Attribs varL else varL - match Zmap.tryFind typar env.inplaceConstraints with + match MapCustom.tryFind typar env.inplaceConstraints with | Some (typarConstraintTy) -> if Zset.contains typar env.singletons then leftL (tagPunctuation "#") ^^ layoutTypeWithInfo denv env typarConstraintTy diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index db888dd8f9c..875add26c04 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -5,6 +5,7 @@ module internal Microsoft.FSharp.Compiler.Tastops open System.Collections.Generic open Internal.Utilities +open Internal.Utilities.Collections open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.AbstractIL.Extensions.ILX @@ -1862,6 +1863,11 @@ let typarOrder = { new System.Collections.Generic.IComparer with member x.Compare (v1:Typar, v2:Typar) = compare v1.Stamp v2.Stamp } +[] +type TyparByStamp = + interface IComparer with + member __.Compare(v1: Typar, v2: Typar): int = compare v1.Stamp v2.Stamp + let emptyFreeTypars = Zset.empty typarOrder let unionFreeTypars s1 s2 = if s1 === emptyFreeTypars then s2 @@ -2526,30 +2532,30 @@ module SimplifyTypes = | TType_measure _ -> z let incM x m = - if Zmap.mem x m then Zmap.add x (1 + Zmap.find x m) m - else Zmap.add x 1 m + if MapCustom.mem x m then MapCustom.add x (1 + MapCustom.find x m) m + else MapCustom.add x 1 m let accTyparCounts z ty = // Walk type to determine typars and their counts (for pprinting decisions) foldTypeButNotConstraints (fun z ty -> match ty with | TType_var tp when tp.Rigidity = TyparRigidity.Rigid -> incM tp z | _ -> z) z ty - let emptyTyparCounts = Zmap.empty typarOrder + let emptyTyparCounts = MapCustom.Empty () // print multiple fragments of the same type using consistent naming and formatting let accTyparCountsMulti acc l = List.fold accTyparCounts acc l type TypeSimplificationInfo = { singletons : Typar Zset - inplaceConstraints : Zmap + inplaceConstraints : Map, TType> postfixConstraints : (Typar * TyparConstraint) list } let typeSimplificationInfo0 = { singletons = Zset.empty typarOrder - inplaceConstraints = Zmap.empty typarOrder + inplaceConstraints = MapCustom.Empty () postfixConstraints = [] } let categorizeConstraints simplify m cxs = - let singletons = if simplify then Zmap.chooseL (fun tp n -> if n = 1 then Some tp else None) m else [] + let singletons = if simplify then MapCustom.chooseL (fun tp n -> if n = 1 then Some tp else None) m else [] let singletons = Zset.addList singletons (Zset.empty typarOrder) // Here, singletons are typars that occur once in the type. // However, they may also occur in a type constraint. @@ -2567,7 +2573,7 @@ module SimplifyTypes = let inplace = inplace |> List.map (function (tp, TyparConstraint.CoercesTo(ty, _)) -> tp, ty | _ -> failwith "not isTTyparCoercesToType") { singletons = singletons - inplaceConstraints = Zmap.ofList typarOrder inplace + inplaceConstraints = MapCustom.ofList inplace postfixConstraints = postfix } let CollectInfo simplify tys cxs = categorizeConstraints simplify (accTyparCountsMulti emptyTyparCounts tys) cxs @@ -3247,7 +3253,7 @@ module DebugPrint = begin + typar.DisplayName)) let varL = tpL |> stampL typar.Stamp - match Zmap.tryFind typar env.inplaceConstraints with + match MapCustom.tryFind typar env.inplaceConstraints with | Some (typarConstraintTy) -> if Zset.contains typar env.singletons then leftL (tagText "#") ^^ auxTyparConstraintTypL env typarConstraintTy diff --git a/src/fsharp/TastOps.fsi b/src/fsharp/TastOps.fsi index d2a532c37a9..c2c9468fb89 100755 --- a/src/fsharp/TastOps.fsi +++ b/src/fsharp/TastOps.fsi @@ -6,6 +6,7 @@ module internal Microsoft.FSharp.Compiler.Tastops open System.Text open System.Collections.Generic open Internal.Utilities +open Internal.Utilities.Collections open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.AbstractIL.Internal @@ -749,11 +750,15 @@ val trimPathByDisplayEnv : DisplayEnv -> string list -> string val prefixOfStaticReq : TyparStaticReq -> string val prefixOfRigidTypar : Typar -> string +[] +type TyparByStamp = + interface IComparer + /// Utilities used in simplifying types for visual presentation module SimplifyTypes = type TypeSimplificationInfo = { singletons : Typar Zset; - inplaceConstraints : Zmap; + inplaceConstraints : Map, TType> postfixConstraints : TyparConstraintsWithTypars; } val typeSimplificationInfo0 : TypeSimplificationInfo val CollectInfo : bool -> TType list -> TyparConstraintsWithTypars -> TypeSimplificationInfo diff --git a/src/utils/SortKey.fs b/src/utils/SortKey.fs new file mode 100644 index 00000000000..c3506e1fc5e --- /dev/null +++ b/src/utils/SortKey.fs @@ -0,0 +1,43 @@ +namespace Internal.Utilities.Collections + +open System +open System.Collections.Generic + +[] +type SortKey<'Key, 'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> = { + CompareObj : 'Key +} +with + interface IComparable> with + member lhs.CompareTo (rhs:SortKey<'Key, 'Comparer>): int = + Unchecked.defaultof<'Comparer>.Compare(lhs.CompareObj, rhs.CompareObj) + + static member fail () = failwith "Invalid logic. No method other than IComparable<_>.CompareTo is valid for SortKey" + interface IComparable with member __.CompareTo _ = SortKey<'Key,'Comparer>.fail () + override __.GetHashCode () = SortKey<'Key,'Comparer>.fail () + override __.Equals _ = SortKey<'Key,'Comparer>.fail () + +[] +type MapCustom<'Key,'Value>() = + static member Empty<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct>() : Map,'Value> = + Map.empty, 'Value> + + static member ofList<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> lst : Map,'Value> = + lst + |> List.map (fun (k,v) -> {CompareObj=k},v) + |> Map.ofList + + static member inline chooseL<'Comparer, 'U when 'Comparer :> IComparer<'Key> and 'Comparer : struct> f (m:Map,'Value>) = + Map.foldBack (fun k v (s:list<'U>) -> match f k.CompareObj v with None -> s | Some x -> x::s) m [] + + static member inline tryFind<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (k:'Key) (m:Map,'Value>) = + Map.tryFind {CompareObj=k} m + + static member inline mem<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (k:'Key) (m:Map,'Value>) = + Map.containsKey {CompareObj=k} m + + static member inline add<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (k:'Key) (v:'Value) (m:Map,'Value>) = + Map.add {CompareObj=k} v m + + static member inline find<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (k:'Key) (m:Map,'Value>) = + Map.find {CompareObj=k} m \ No newline at end of file From 85a3e6abb4a0e5a830ffb7ac818e681f9a36325e Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Mon, 6 Aug 2018 19:31:03 +1000 Subject: [PATCH 68/92] Converted Zmaps on Val types --- src/fsharp/DetupleArgs.fs | 34 ++++++++++++----------- src/fsharp/DetupleArgs.fsi | 7 +++-- src/fsharp/InnerLambdasToTopLevelFuncs.fs | 11 ++++---- src/fsharp/TastOps.fs | 5 ---- src/fsharp/TastOps.fsi | 4 --- src/fsharp/TypeChecker.fs | 11 ++++---- src/fsharp/tast.fs | 11 +++++++- src/utils/SortKey.fs | 16 +++++++++-- 8 files changed, 58 insertions(+), 41 deletions(-) diff --git a/src/fsharp/DetupleArgs.fs b/src/fsharp/DetupleArgs.fs index bf56deeeb7f..f8af3385774 100644 --- a/src/fsharp/DetupleArgs.fs +++ b/src/fsharp/DetupleArgs.fs @@ -2,6 +2,8 @@ module internal Microsoft.FSharp.Compiler.Detuple +open Internal.Utilities.Collections + open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library @@ -181,20 +183,20 @@ module GlobalUsageAnalysis = /// (b) log it's binding site representation. type Results = { /// v -> context / APP inst args - Uses : Zmap + Uses : Map, (accessor list * TType list * Expr list) list> /// v -> binding repr - Defns : Zmap + Defns : Map, Expr> /// bound in a decision tree? DecisionTreeBindings : Zset /// v -> v list * recursive? -- the others in the mutual binding - RecursiveBindings : Zmap + RecursiveBindings : Map, bool * Vals> TopLevelBindings : Zset IterationIsAtTopLevel : bool } let z0 = - { Uses = Zmap.empty valOrder - Defns = Zmap.empty valOrder - RecursiveBindings = Zmap.empty valOrder + { Uses = MapCustom.Empty () + Defns = MapCustom.Empty () + RecursiveBindings = MapCustom.Empty () DecisionTreeBindings = Zset.empty valOrder TopLevelBindings = Zset.empty valOrder IterationIsAtTopLevel = true } @@ -203,9 +205,9 @@ module GlobalUsageAnalysis = /// Note: this routine is called very frequently let logUse (f:Val) tup z = {z with Uses = - match Zmap.tryFind f z.Uses with - | Some sites -> Zmap.add f (tup::sites) z.Uses - | None -> Zmap.add f [tup] z.Uses } + match MapCustom.tryFind f z.Uses with + | Some sites -> MapCustom.add f (tup::sites) z.Uses + | None -> MapCustom.add f [tup] z.Uses } /// Log the definition of a binding let logBinding z (isInDTree, v) = @@ -218,14 +220,14 @@ module GlobalUsageAnalysis = let logNonRecBinding z (bind:Binding) = let v = bind.Var let vs = [v] - {z with RecursiveBindings = Zmap.add v (false, vs) z.RecursiveBindings - Defns = Zmap.add v bind.Expr z.Defns } + {z with RecursiveBindings = MapCustom.add v (false, vs) z.RecursiveBindings + Defns = MapCustom.add v bind.Expr z.Defns } /// Log the definition of a recursive binding let logRecBindings z binds = let vs = valsOfBinds binds - {z with RecursiveBindings = (z.RecursiveBindings, vs) ||> List.fold (fun mubinds v -> Zmap.add v (true, vs) mubinds) - Defns = (z.Defns, binds) ||> List.fold (fun eqns bind -> Zmap.add bind.Var bind.Expr eqns) } + {z with RecursiveBindings = (z.RecursiveBindings, vs) ||> List.fold (fun mubinds v -> MapCustom.add v (true, vs) mubinds) + Defns = (z.Defns, binds) ||> List.fold (fun eqns bind -> MapCustom.add bind.Var bind.Expr eqns) } /// Work locally under a lambda of some kind let foldUnderLambda f z x = @@ -535,7 +537,7 @@ let decideFormalSuggestedCP g z tys vss = TupleTS tss let trimTsByVal z ts v = - match Zmap.tryFind v z.Uses with + match MapCustom.tryFind v z.Uses with | None -> UnknownTS (* formal has no usage info, it is unused *) | Some sites -> let trim ts (accessors, _inst, _args) = trimTsByAccess accessors ts @@ -599,7 +601,7 @@ let determineTransforms g (z : GlobalUsageAnalysis.Results) = let selectTransform (f: Val) sites = if not (eligibleVal g f.Range f) then None else // Consider f, if it has top-level lambda (meaning has term args) - match Zmap.tryFind f z.Defns with + match MapCustom.tryFind f z.Defns with | None -> None // no binding site, so no transform | Some e -> let tps, vss, _b, rty = stripTopLambda (e, f.Type) @@ -610,7 +612,7 @@ let determineTransforms g (z : GlobalUsageAnalysis.Results) = let callPatterns = sitesCPs sites // callPatterns from sites decideTransform g z f callPatterns (m, tps, vss, rty) // make transform (if required) - let vtransforms = Zmap.chooseL selectTransform z.Uses + let vtransforms = MapCustom.chooseL selectTransform z.Uses let vtransforms = Zmap.ofList valOrder vtransforms vtransforms diff --git a/src/fsharp/DetupleArgs.fsi b/src/fsharp/DetupleArgs.fsi index 58412315820..7479c8707c2 100644 --- a/src/fsharp/DetupleArgs.fsi +++ b/src/fsharp/DetupleArgs.fsi @@ -2,6 +2,7 @@ module internal Microsoft.FSharp.Compiler.Detuple +open Internal.Utilities.Collections open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.Tast open Microsoft.FSharp.Compiler.TcGlobals @@ -18,13 +19,13 @@ module GlobalUsageAnalysis = /// Later could support "safe" change operations, and optimisations could be in terms of those. type Results = { /// v -> context / APP inst args - Uses : Zmap; + Uses : Map, (accessor list * TType list * Expr list) list>; /// v -> binding repr - Defns : Zmap; + Defns : Map, Expr>; /// bound in a decision tree? DecisionTreeBindings : Zset; /// v -> recursive? * v list -- the others in the mutual binding - RecursiveBindings : Zmap; + RecursiveBindings : Map, (bool * Vals)>; /// val not defined under lambdas TopLevelBindings : Zset; /// top of expr toplevel? (true) diff --git a/src/fsharp/InnerLambdasToTopLevelFuncs.fs b/src/fsharp/InnerLambdasToTopLevelFuncs.fs index 2eb45de1495..829984ebe3c 100644 --- a/src/fsharp/InnerLambdasToTopLevelFuncs.fs +++ b/src/fsharp/InnerLambdasToTopLevelFuncs.fs @@ -2,6 +2,7 @@ module internal Microsoft.FSharp.Compiler.InnerLambdasToTopLevelFuncs +open Internal.Utilities.Collections open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library @@ -145,7 +146,7 @@ let GetValsBoundUnderMustInline xinfo = Zset.union (GetValsBoundInExpr repr) rejectS else rejectS let rejectS = Zset.empty valOrder - let rejectS = Zmap.fold accRejectFrom xinfo.Defns rejectS + let rejectS = MapCustom.fold accRejectFrom xinfo.Defns rejectS rejectS //------------------------------------------------------------------------- @@ -180,7 +181,7 @@ let IsMandatoryNonTopLevel g (f:Val) = module Pass1_DetermineTLRAndArities = let GetMaxNumArgsAtUses xinfo f = - match Zmap.tryFind f xinfo.Uses with + match MapCustom.tryFind f xinfo.Uses with | None -> 0 (* no call sites *) | Some sites -> sites |> List.map (fun (_accessors,_tinst,args) -> List.length args) |> List.max @@ -203,8 +204,8 @@ module Pass1_DetermineTLRAndArities = /// ValRec considered: recursive && some f in mutual binding is not bound to a lambda let IsValueRecursionFree xinfo f = - let hasDelayedRepr f = isDelayedRepr f (Zmap.force f xinfo.Defns ("IsValueRecursionFree - hasDelayedRepr",nameOfVal)) - let isRecursive,mudefs = Zmap.force f xinfo.RecursiveBindings ("IsValueRecursionFree",nameOfVal) + let hasDelayedRepr f = isDelayedRepr f (Map.force {CompareObj=f} xinfo.Defns ("IsValueRecursionFree - hasDelayedRepr",(fun {CompareObj=v} -> nameOfVal v))) + let isRecursive,mudefs = Map.force {CompareObj=f} xinfo.RecursiveBindings ("IsValueRecursionFree",(fun {CompareObj=v} -> nameOfVal v)) not isRecursive || List.forall hasDelayedRepr mudefs let DumpArity arityM = @@ -213,7 +214,7 @@ module Pass1_DetermineTLRAndArities = let DetermineTLRAndArities g expr = let xinfo = GetUsageInfoOfImplFile g expr - let fArities = Zmap.chooseL (SelectTLRVals g xinfo) xinfo.Defns + let fArities = MapCustom.chooseL (SelectTLRVals g xinfo) xinfo.Defns let fArities = List.filter (fst >> IsValueRecursionFree xinfo) fArities // Do not TLR v if it is bound under a mustinline defn // There is simply no point - the original value will be duplicated and TLR'd anyway diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index 875add26c04..c9c820d095f 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -1863,11 +1863,6 @@ let typarOrder = { new System.Collections.Generic.IComparer with member x.Compare (v1:Typar, v2:Typar) = compare v1.Stamp v2.Stamp } -[] -type TyparByStamp = - interface IComparer with - member __.Compare(v1: Typar, v2: Typar): int = compare v1.Stamp v2.Stamp - let emptyFreeTypars = Zset.empty typarOrder let unionFreeTypars s1 s2 = if s1 === emptyFreeTypars then s2 diff --git a/src/fsharp/TastOps.fsi b/src/fsharp/TastOps.fsi index c2c9468fb89..e5c9a643d02 100755 --- a/src/fsharp/TastOps.fsi +++ b/src/fsharp/TastOps.fsi @@ -750,10 +750,6 @@ val trimPathByDisplayEnv : DisplayEnv -> string list -> string val prefixOfStaticReq : TyparStaticReq -> string val prefixOfRigidTypar : Typar -> string -[] -type TyparByStamp = - interface IComparer - /// Utilities used in simplifying types for visual presentation module SimplifyTypes = type TypeSimplificationInfo = diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index 658baff82f4..62982a5cc6b 100755 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -8,6 +8,7 @@ open System open System.Collections.Generic open Internal.Utilities +open Internal.Utilities.Collections open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.IL @@ -12419,19 +12420,19 @@ module IncrClassChecking = TakenFieldNames:Set RepInfoTcGlobals:TcGlobals /// vals mapped to representations - ValReprs : Zmap + ValReprs : Map, IncrClassValRepr> /// vals represented as fields or members from this point on ValsWithRepresentation : Zset } static member Empty(g, names) = { TakenFieldNames=Set.ofList names RepInfoTcGlobals=g - ValReprs = Zmap.empty valOrder + ValReprs = MapCustom.Empty () ValsWithRepresentation = Zset.empty valOrder } /// Find the representation of a value member localRep.LookupRepr (v:Val) = - match Zmap.tryFind v localRep.ValReprs with + match MapCustom.tryFind v localRep.ValReprs with | None -> error(InternalError("LookupRepr: failed to find representation for value", v.Range)) | Some res -> res @@ -12544,7 +12545,7 @@ module IncrClassChecking = // OK, representation chosen, now add it {localRep with TakenFieldNames=takenFieldNames - ValReprs = Zmap.add v repr localRep.ValReprs} + ValReprs = MapCustom.add v repr localRep.ValReprs} member localRep.ValNowWithRepresentation (v:Val) = {localRep with ValsWithRepresentation = Zset.add v localRep.ValsWithRepresentation} @@ -12629,7 +12630,7 @@ module IncrClassChecking = member localRep.PublishIncrClassFields (cenv, denv, cpath, ctorInfo:IncrClassCtorLhs, safeStaticInitInfo) = let tcref = ctorInfo.TyconRef let rfspecs = - [ for KeyValue(v, repr) in localRep.ValReprs do + [ for KeyValue({CompareObj=v}, repr) in localRep.ValReprs do match repr with | InField(isStatic, _, rfref) -> // Instance fields for structs are published earlier because the full set of fields is determined syntactically from the implicit diff --git a/src/fsharp/tast.fs b/src/fsharp/tast.fs index ffef5fc82b0..184fe0f2edb 100644 --- a/src/fsharp/tast.fs +++ b/src/fsharp/tast.fs @@ -2279,6 +2279,11 @@ and override x.ToString() = x.Name +and [] TyparByStamp = + interface IComparer with + member __.Compare(v1: Typar, v2: Typar): int = + compare v1.Stamp v2.Stamp + and [] TyparConstraint = @@ -2962,7 +2967,11 @@ and [] member x.DebugText = x.ToString() override x.ToString() = x.LogicalName - + +and [] ValByStamp = + interface IComparer with + member __.Compare(v1, v2) = + compare v1.Stamp v2.Stamp and /// Represents the extra information stored for a member diff --git a/src/utils/SortKey.fs b/src/utils/SortKey.fs index c3506e1fc5e..f1da293fc7e 100644 --- a/src/utils/SortKey.fs +++ b/src/utils/SortKey.fs @@ -13,10 +13,19 @@ with Unchecked.defaultof<'Comparer>.Compare(lhs.CompareObj, rhs.CompareObj) static member fail () = failwith "Invalid logic. No method other than IComparable<_>.CompareTo is valid for SortKey" - interface IComparable with member __.CompareTo _ = SortKey<'Key,'Comparer>.fail () override __.GetHashCode () = SortKey<'Key,'Comparer>.fail () override __.Equals _ = SortKey<'Key,'Comparer>.fail () +#if THIS_SHOULD_JUST_THROW_AN_EXCEPTION + interface IComparable with member __.CompareTo _ = SortKey<'Key,'Comparer>.fail () +#else + // tests run with an old version of FSharp.Core that doesn't using the non-boxing IComparable + interface IComparable with + member lhs.CompareTo rhs = + Unchecked.defaultof<'Comparer>.Compare(lhs.CompareObj, (rhs:?>SortKey<'Key,'Comparer>).CompareObj) +#endif + + [] type MapCustom<'Key,'Value>() = static member Empty<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct>() : Map,'Value> = @@ -40,4 +49,7 @@ type MapCustom<'Key,'Value>() = Map.add {CompareObj=k} v m static member inline find<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (k:'Key) (m:Map,'Value>) = - Map.find {CompareObj=k} m \ No newline at end of file + Map.find {CompareObj=k} m + + static member inline fold<'Comparer, 'State when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (folder:'Key->'Value->'State->'State) (m:Map,'Value>) (state:'State) : 'State = + Map.foldBack (fun {CompareObj=k} t s -> folder k t s) m state \ No newline at end of file From 7e7a499801b828013ebdbeefa4afdcdca9d41cad Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Thu, 9 Aug 2018 20:05:45 +1000 Subject: [PATCH 69/92] ...working way through all Zmaps... --- src/fsharp/DetupleArgs.fs | 6 ++-- src/fsharp/InnerLambdasToTopLevelFuncs.fs | 39 +++++++++++++---------- src/utils/SortKey.fs | 19 ++++++++++- 3 files changed, 43 insertions(+), 21 deletions(-) diff --git a/src/fsharp/DetupleArgs.fs b/src/fsharp/DetupleArgs.fs index f8af3385774..d18924db818 100644 --- a/src/fsharp/DetupleArgs.fs +++ b/src/fsharp/DetupleArgs.fs @@ -613,7 +613,7 @@ let determineTransforms g (z : GlobalUsageAnalysis.Results) = decideTransform g z f callPatterns (m, tps, vss, rty) // make transform (if required) let vtransforms = MapCustom.chooseL selectTransform z.Uses - let vtransforms = Zmap.ofList valOrder vtransforms + let vtransforms = MapCustom.ofList vtransforms vtransforms @@ -624,11 +624,11 @@ let determineTransforms g (z : GlobalUsageAnalysis.Results) = type penv = { // The planned transforms - transforms : Zmap + transforms : Map, Transform> ccu : CcuThunk g : TcGlobals } -let hasTransfrom penv f = Zmap.tryFind f penv.transforms +let hasTransfrom penv f = MapCustom.tryFind f penv.transforms //------------------------------------------------------------------------- // pass - app fixup - collapseArgs diff --git a/src/fsharp/InnerLambdasToTopLevelFuncs.fs b/src/fsharp/InnerLambdasToTopLevelFuncs.fs index 829984ebe3c..ff262f0c310 100644 --- a/src/fsharp/InnerLambdasToTopLevelFuncs.fs +++ b/src/fsharp/InnerLambdasToTopLevelFuncs.fs @@ -314,6 +314,11 @@ type BindingGroupSharingSameReqdItems(bindings: Bindings) = let fclassOrder = Order.orderOn (fun (b: BindingGroupSharingSameReqdItems) -> b.Vals) (List.order valOrder) +[] +type BindingGroupSharingSameReqdItemsByVals = + interface System.Collections.Generic.IComparer with + member __.Compare(v1, v2) = fclassOrder.Compare (v1,v2) + /// It is required to make the TLR closed wrt it's freevars (the env reqdVals0). /// For gv a generator, /// An arity-met gv occurrence contributes the env required for that gv call. @@ -424,16 +429,16 @@ module Pass2_DetermineReqdItems = /// recShortCalls to f will require a binding for f in terms of fHat within the fHatBody. type state = { stack : (BindingGroupSharingSameReqdItems * Generators * ReqdItemsForDefn) list - reqdItemsMap : Zmap - fclassM : Zmap + reqdItemsMap : Map,ReqdItemsForDefn> + fclassM : Map,BindingGroupSharingSameReqdItems> revDeclist : BindingGroupSharingSameReqdItems list recShortCallS : Zset } let state0 = { stack = [] - reqdItemsMap = Zmap.empty fclassOrder - fclassM = Zmap.empty valOrder + reqdItemsMap = MapCustom.Empty () + fclassM = MapCustom.Empty () revDeclist = [] recShortCallS = Zset.empty valOrder } @@ -457,8 +462,8 @@ module Pass2_DetermineReqdItems = | (fclass,_reqdVals0,env)::stack -> (* ASSERT: same fclass *) {state with stack = stack - reqdItemsMap = Zmap.add fclass env state.reqdItemsMap - fclassM = List.fold (fun mp (k,v) -> Zmap.add k v mp) state.fclassM fclass.Pairs } + reqdItemsMap = MapCustom.add fclass env state.reqdItemsMap + fclassM = List.fold (fun mp (k,v) -> MapCustom.add k v mp) state.fclassM fclass.Pairs } /// Log requirements for gv in the relevant stack frames let LogRequiredFrom gv items state = @@ -570,8 +575,8 @@ module Pass2_DetermineReqdItems = let closeStep reqdItemsMap changed fc (env: ReqdItemsForDefn) = let directCallReqdEnvs = env.ReqdSubEnvs let directCallReqdTypars = directCallReqdEnvs |> List.map (fun f -> - let fc = Zmap.force f fclassM ("reqdTyparsFor",nameOfVal) - let env = Zmap.force fc reqdItemsMap ("reqdTyparsFor",string) + let fc = Map.force {CompareObj=f} fclassM ("reqdTyparsFor",(fun x -> nameOfVal x.CompareObj)) + let env = Map.force {CompareObj=fc} reqdItemsMap ("reqdTyparsFor",(fun x -> string x.CompareObj)) env.reqdTypars) let reqdTypars0 = env.reqdTypars @@ -591,7 +596,7 @@ module Pass2_DetermineReqdItems = let rec fixpoint reqdItemsMap = let changed = false - let changed,reqdItemsMap = Zmap.foldMap (closeStep reqdItemsMap) changed reqdItemsMap + let changed,reqdItemsMap = MapCustom.foldMap (closeStep reqdItemsMap) changed reqdItemsMap if changed then fixpoint reqdItemsMap else @@ -623,9 +628,9 @@ module Pass2_DetermineReqdItems = // close the reqdTypars under the subEnv reln let reqdItemsMap = CloseReqdTypars fclassM reqdItemsMap // filter out trivial fclass - with no TLR defns - let reqdItemsMap = Zmap.remove (BindingGroupSharingSameReqdItems List.empty) reqdItemsMap + let reqdItemsMap = MapCustom.remove (BindingGroupSharingSameReqdItems List.empty) reqdItemsMap // restrict declist to those with reqdItemsMap bindings (the non-trivial ones) - let declist = List.filter (Zmap.memberOf reqdItemsMap) declist + let declist = List.filter (MapCustom.memberOf reqdItemsMap) declist #if DEBUG // diagnostic dump if verboseTLR then @@ -689,11 +694,11 @@ exception AbortTLR of Range.range /// and TBIND(asubEnvi = aenvFor(v)) for each (asubEnvi,v) in cmap(subEnvk) ranging over required subEnvk. /// where /// aenvFor(v) = aenvi where (v,aenvi) in cmap. -let FlatEnvPacks g fclassM topValS declist (reqdItemsMap: Zmap) = - let fclassOf f = Zmap.force f fclassM ("fclassM",nameOfVal) +let FlatEnvPacks g fclassM topValS declist (reqdItemsMap: Map,ReqdItemsForDefn>) = + let fclassOf f = Map.force {CompareObj=f} fclassM ("fclassM",fun x -> nameOfVal x.CompareObj) let packEnv carrierMaps (fc:BindingGroupSharingSameReqdItems) = if verboseTLR then dprintf "\ntlr: packEnv fc=%A\n" fc - let env = Zmap.force fc reqdItemsMap ("packEnv",string) + let env = Map.force {CompareObj=fc} reqdItemsMap ("packEnv",fun x -> string x.CompareObj) // carrierMaps = (fclass,(v,aenv)map)map let carrierMapFor f = Zmap.force (fclassOf f) carrierMaps ("carrierMapFor",string) @@ -832,7 +837,7 @@ let CreateNewValuesForTLR g tlrS arityM fclassM envPackM = if verboseTLR then dprintf "CreateNewValuesForTLR------\n" let createFHat (f:Val) = let wf = Zmap.force f arityM ("createFHat - wf",(fun v -> showL (valL v))) - let fc = Zmap.force f fclassM ("createFHat - fc",nameOfVal) + let fc = Map.force {CompareObj=f} fclassM ("createFHat - fc",fun x -> nameOfVal x.CompareObj) let envp = Zmap.force fc envPackM ("CreateNewValuesForTLR - envp",string) let name = f.LogicalName (* + "_TLR_" + string wf *) let m = f.Range @@ -866,7 +871,7 @@ module Pass4_RewriteAssembly = tlrS : Zset topValS : Zset arityM : Zmap - fclassM : Zmap + fclassM : Map,BindingGroupSharingSameReqdItems> recShortCallS : Zset envPackM : Zmap /// The mapping from 'f' values to 'fHat' values @@ -1060,7 +1065,7 @@ module Pass4_RewriteAssembly = let f = fvref.Deref (* replace by direct call to corresponding fHat (and additional closure args) *) - let fc = Zmap.force f penv.fclassM ("TransApp - fc",nameOfVal) + let fc = Map.force {CompareObj=f} penv.fclassM ("TransApp - fc",fun x -> nameOfVal x.CompareObj) let envp = Zmap.force fc penv.envPackM ("TransApp - envp",string) let fHat = Zmap.force f penv.fHatM ("TransApp - fHat",nameOfVal) let tys = (List.map mkTyparTy envp.ep_etps) @ tys diff --git a/src/utils/SortKey.fs b/src/utils/SortKey.fs index f1da293fc7e..d859fc92601 100644 --- a/src/utils/SortKey.fs +++ b/src/utils/SortKey.fs @@ -45,6 +45,9 @@ type MapCustom<'Key,'Value>() = static member inline mem<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (k:'Key) (m:Map,'Value>) = Map.containsKey {CompareObj=k} m + static member inline memberOf<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (m:Map,'Value>) (k:'Key) = + Map.containsKey {CompareObj=k} m + static member inline add<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (k:'Key) (v:'Value) (m:Map,'Value>) = Map.add {CompareObj=k} v m @@ -52,4 +55,18 @@ type MapCustom<'Key,'Value>() = Map.find {CompareObj=k} m static member inline fold<'Comparer, 'State when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (folder:'Key->'Value->'State->'State) (m:Map,'Value>) (state:'State) : 'State = - Map.foldBack (fun {CompareObj=k} t s -> folder k t s) m state \ No newline at end of file + Map.foldBack (fun {CompareObj=k} t s -> folder k t s) m state + + static member inline remove<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (k:'Key) (m:Map,'Value>) = + Map.remove {CompareObj=k} m + + + static member foldMap<'Comparer, 'State, 'U when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (folder:'State->'Key->'Value->'State*'U) (initialState:'State) (initialMap:Map,'Value>) : 'State * Map,'U> = + let f = OptimizedClosures.FSharpFunc<_,_,_,_>.Adapt folder + let struct (finalState, finalMap) = + (initialMap, struct (initialState, MapCustom.Empty<'Comparer> ())) + ||> Map.foldBack (fun {CompareObj=k} v struct (acc, m) -> + let acc', v' = f.Invoke (acc, k, v) + let m' = Map.add {CompareObj=k} v' m + struct (acc', m')) + finalState, finalMap From 17d2fedeae9c5442ad944237847b3bfb1696555c Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Thu, 9 Aug 2018 20:14:34 +1000 Subject: [PATCH 70/92] Fixed call missed in #debug section --- src/fsharp/InnerLambdasToTopLevelFuncs.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/fsharp/InnerLambdasToTopLevelFuncs.fs b/src/fsharp/InnerLambdasToTopLevelFuncs.fs index ff262f0c310..121cdae62f9 100644 --- a/src/fsharp/InnerLambdasToTopLevelFuncs.fs +++ b/src/fsharp/InnerLambdasToTopLevelFuncs.fs @@ -587,7 +587,7 @@ module Pass2_DetermineReqdItems = if verboseTLR then dprintf "closeStep: fc=%30A nSubs=%d reqdTypars0=%s reqdTypars=%s\n" fc directCallReqdEnvs.Length (showTyparSet reqdTypars0) (showTyparSet reqdTypars) directCallReqdEnvs |> List.iter (fun f -> dprintf "closeStep: dcall f=%s\n" f.LogicalName) - directCallReqdEnvs |> List.iter (fun f -> dprintf "closeStep: dcall fc=%A\n" (Zmap.find f fclassM)) + directCallReqdEnvs |> List.iter (fun f -> dprintf "closeStep: dcall fc=%A\n" (MapCustom.find f fclassM)) directCallReqdTypars |> List.iter (fun _reqdTypars -> dprintf "closeStep: dcall reqdTypars=%s\n" (showTyparSet reqdTypars0)) #else ignore fc From a17471284ed5f6a910ed3146918e82ef8960e285 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Thu, 9 Aug 2018 21:02:00 +1000 Subject: [PATCH 71/92] Removed remaining usages of Zmap --- src/fsharp/CompileOps.fs | 21 +++++---- src/fsharp/InnerLambdasToTopLevelFuncs.fs | 54 +++++++++++------------ src/utils/SortKey.fs | 12 +++++ 3 files changed, 52 insertions(+), 35 deletions(-) diff --git a/src/fsharp/CompileOps.fs b/src/fsharp/CompileOps.fs index d54373c5548..aac9ea5365e 100644 --- a/src/fsharp/CompileOps.fs +++ b/src/fsharp/CompileOps.fs @@ -5329,11 +5329,16 @@ let CheckSimulateException(tcConfig:TcConfig) = // Type-check sets of files //-------------------------------------------------------------------------- -type RootSigs = Zmap -type RootImpls = Zset - let qnameOrder = Order.orderBy (fun (q:QualifiedNameOfFile) -> q.Text) +[] +type QualifiedNameOfFileByText = + interface System.Collections.Generic.IComparer with + member __.Compare(v1, v2) = qnameOrder.Compare (v1,v2) + +type RootSigs = Map, ModuleOrNamespaceType> +type RootImpls = Zset + type TcState = { tcsCcu: CcuThunk tcsCcuType: ModuleOrNamespace @@ -5403,7 +5408,7 @@ let GetInitialTcState(m, ccuName, tcConfig:TcConfig, tcGlobals, tcImports:TcImpo tcsTcSigEnv=tcEnv0 tcsTcImplEnv=tcEnv0 tcsCreatesGeneratedProvidedTypes=false - tcsRootSigs = Zmap.empty qnameOrder + tcsRootSigs = MapCustom.Empty () tcsRootImpls = Zset.empty qnameOrder tcsCcuSig = NewEmptyModuleOrNamespaceType Namespace } @@ -5425,7 +5430,7 @@ let TypeCheckOneInputEventually (checkForErrors, tcConfig:TcConfig, tcImports:Tc | ParsedInput.SigFile (ParsedSigFileInput(_, qualNameOfFile, _, _, _) as file) -> // Check if we've seen this top module signature before. - if Zmap.mem qualNameOfFile tcState.tcsRootSigs then + if MapCustom.mem qualNameOfFile tcState.tcsRootSigs then errorR(Error(FSComp.SR.buildSignatureAlreadySpecified(qualNameOfFile.Text), m.StartRange)) // Check if the implementation came first in compilation order @@ -5436,7 +5441,7 @@ let TypeCheckOneInputEventually (checkForErrors, tcConfig:TcConfig, tcImports:Tc let! (tcEnv, sigFileType, createsGeneratedProvidedTypes) = TypeCheckOneSigFile (tcGlobals, tcState.tcsNiceNameGen, amap, tcState.tcsCcu, checkForErrors, tcConfig.conditionalCompilationDefines, tcSink, tcConfig.internalTestSpanStackReferring) tcState.tcsTcSigEnv file - let rootSigs = Zmap.add qualNameOfFile sigFileType tcState.tcsRootSigs + let rootSigs = MapCustom.add qualNameOfFile sigFileType tcState.tcsRootSigs // Add the signature to the signature env (unless it had an explicit signature) let ccuSigForFile = CombineCcuContentFragments m [sigFileType; tcState.tcsCcuSig] @@ -5461,7 +5466,7 @@ let TypeCheckOneInputEventually (checkForErrors, tcConfig:TcConfig, tcImports:Tc | ParsedInput.ImplFile (ParsedImplFileInput(_, _, qualNameOfFile, _, _, _, _) as file) -> // Check if we've got an interface for this fragment - let rootSigOpt = tcState.tcsRootSigs.TryFind(qualNameOfFile) + let rootSigOpt = tcState.tcsRootSigs.TryFind {CompareObj=qualNameOfFile} // Check if we've already seen an implementation for this fragment if Zset.contains qualNameOfFile tcState.tcsRootImpls then @@ -5550,7 +5555,7 @@ let TypeCheckClosedInputSetFinish (declaredImpls: TypedImplFile list, tcState) = tcState.tcsCcu.Deref.Contents <- NewCcuContents ILScopeRef.Local range0 tcState.tcsCcu.AssemblyName tcState.tcsCcuSig // Check all interfaces have implementations - tcState.tcsRootSigs |> Zmap.iter (fun qualNameOfFile _ -> + tcState.tcsRootSigs |> MapCustom.iter (fun qualNameOfFile _ -> if not (Zset.contains qualNameOfFile tcState.tcsRootImpls) then errorR(Error(FSComp.SR.buildSignatureWithoutImplementation(qualNameOfFile.Text), qualNameOfFile.Range))) diff --git a/src/fsharp/InnerLambdasToTopLevelFuncs.fs b/src/fsharp/InnerLambdasToTopLevelFuncs.fs index 121cdae62f9..9400e5ff225 100644 --- a/src/fsharp/InnerLambdasToTopLevelFuncs.fs +++ b/src/fsharp/InnerLambdasToTopLevelFuncs.fs @@ -210,7 +210,7 @@ module Pass1_DetermineTLRAndArities = let DumpArity arityM = let dump f n = dprintf "tlr: arity %50s = %d\n" (showL (valL f)) n - Zmap.iter dump arityM + MapCustom.iter dump arityM let DetermineTLRAndArities g expr = let xinfo = GetUsageInfoOfImplFile g expr @@ -231,7 +231,7 @@ module Pass1_DetermineTLRAndArities = missed |> Zset.iter (fun v -> dprintf "TopLevel but not TLR = %s\n" v.LogicalName) #endif (* REPORT OVER *) - let arityM = Zmap.ofList valOrder fArities + let arityM = MapCustom.ofList fArities #if DEBUG if verboseTLR then DumpArity arityM #endif @@ -498,7 +498,7 @@ module Pass2_DetermineReqdItems = let ExprEnvIntercept (tlrS,arityM) exprF z expr = let accInstance z (fvref:ValRef,tps,args) (* f known local *) = let f = fvref.Deref - match Zmap.tryFind f arityM with + match MapCustom.tryFind f arityM with | Some wf -> // f is TLR with arity wf @@ -701,8 +701,8 @@ let FlatEnvPacks g fclassM topValS declist (reqdItemsMap: Map string x.CompareObj) // carrierMaps = (fclass,(v,aenv)map)map - let carrierMapFor f = Zmap.force (fclassOf f) carrierMaps ("carrierMapFor",string) - let valsSubEnvFor f = Zmap.keys (carrierMapFor f) + let carrierMapFor f = Map.force {CompareObj=fclassOf f} carrierMaps ("carrierMapFor",fun x -> string x.CompareObj) + let valsSubEnvFor f = MapCustom.keys (carrierMapFor f) // determine vals(env) - transclosure let vals = env.ReqdVals @ List.collect valsSubEnvFor env.ReqdSubEnvs // list, with repeats @@ -752,25 +752,25 @@ let FlatEnvPacks g fclassM topValS declist (reqdItemsMap: Map List.map (fun v -> (v,(mkCompGenLocal env.m v.LogicalName v.Type |> fst))) - let cmap = Zmap.ofList valOrder cmapPairs - let aenvFor v = Zmap.force v cmap ("aenvFor",nameOfVal) + let cmap = MapCustom.ofList cmapPairs + let aenvFor v = Map.force {CompareObj=v} cmap ("aenvFor",fun x -> nameOfVal x.CompareObj) let aenvExprFor v = exprForVal env.m (aenvFor v) // build PackedReqdItems let reqdTypars = env.reqdTypars - let aenvs = Zmap.values cmap + let aenvs = MapCustom.values cmap let pack = cmapPairs |> List.map (fun (v,aenv) -> mkInvisibleBind aenv (exprForVal env.m v)) let unpack = let unpackCarrier (v,aenv) = mkInvisibleBind (setValHasNoArity v) (exprForVal env.m aenv) let unpackSubenv f = let subCMap = carrierMapFor f - let vaenvs = Zmap.toList subCMap + let vaenvs = MapCustom.toList subCMap vaenvs |> List.map (fun (subv,subaenv) -> mkBind NoSequencePointAtInvisibleBinding subaenv (aenvExprFor subv)) - List.map unpackCarrier (Zmap.toList cmap) @ + List.map unpackCarrier (MapCustom.toList cmap) @ List.collect unpackSubenv env.ReqdSubEnvs // extend carrierMaps - let carrierMaps = Zmap.add fc cmap carrierMaps + let carrierMaps = MapCustom.add fc cmap carrierMaps // dump if verboseTLR then @@ -787,9 +787,9 @@ let FlatEnvPacks g fclassM topValS declist (reqdItemsMap: Map () let envPacks,_carriedMaps = List.mapFold packEnv carriedMaps declist (* List.mapFold in dec order *) - let envPacks = Zmap.ofList fclassOrder envPacks + let envPacks = MapCustom.ofList envPacks envPacks @@ -836,9 +836,9 @@ let MakeSimpleArityInfo tps n = ValReprInfo (ValReprInfo.InferTyparInfo tps,List let CreateNewValuesForTLR g tlrS arityM fclassM envPackM = if verboseTLR then dprintf "CreateNewValuesForTLR------\n" let createFHat (f:Val) = - let wf = Zmap.force f arityM ("createFHat - wf",(fun v -> showL (valL v))) + let wf = Map.force {CompareObj=f} arityM ("createFHat - wf",(fun v -> showL (valL v.CompareObj))) let fc = Map.force {CompareObj=f} fclassM ("createFHat - fc",fun x -> nameOfVal x.CompareObj) - let envp = Zmap.force fc envPackM ("CreateNewValuesForTLR - envp",string) + let envp = Map.force {CompareObj=fc} envPackM ("CreateNewValuesForTLR - envp",fun x -> string x.CompareObj) let name = f.LogicalName (* + "_TLR_" + string wf *) let m = f.Range let tps,tau = f.TypeScheme @@ -855,7 +855,7 @@ let CreateNewValuesForTLR g tlrS arityM fclassM envPackM = let fs = Zset.elements tlrS let ffHats = List.map (fun f -> f,createFHat f) fs - let fHatM = Zmap.ofList valOrder ffHats + let fHatM = MapCustom.ofList ffHats fHatM @@ -870,12 +870,12 @@ module Pass4_RewriteAssembly = g : TcGlobals tlrS : Zset topValS : Zset - arityM : Zmap + arityM : Map,int> fclassM : Map,BindingGroupSharingSameReqdItems> recShortCallS : Zset - envPackM : Zmap + envPackM : Map,PackedReqdItems> /// The mapping from 'f' values to 'fHat' values - fHatM : Zmap + fHatM : Map,Val> } @@ -977,14 +977,14 @@ module Pass4_RewriteAssembly = let TransTLRBindings penv (binds:Bindings) = if isNil binds then List.empty,List.empty else let fc = BindingGroupSharingSameReqdItems binds - let envp = Zmap.force fc penv.envPackM ("TransTLRBindings",string) + let envp = Map.force {CompareObj=fc} penv.envPackM ("TransTLRBindings",fun x -> string x.CompareObj) let fRebinding (TBind(fOrig,b,letSeqPtOpt)) = let m = fOrig.Range let tps,vss,_b,rty = stripTopLambda (b,fOrig.Type) let aenvExprs = envp.ep_aenvs |> List.map (exprForVal m) let vsExprs = vss |> List.map (mkRefTupledVars penv.g m) - let fHat = Zmap.force fOrig penv.fHatM ("fRebinding",nameOfVal) + let fHat = Map.force {CompareObj=fOrig} penv.fHatM ("fRebinding",fun x -> nameOfVal x.CompareObj) (* REVIEW: is this mutation really, really necessary? *) (* Why are we applying TLR if the thing already has an arity? *) let fOrig = setValHasNoArity fOrig @@ -997,8 +997,8 @@ module Pass4_RewriteAssembly = fBind let fHatNewBinding (shortRecBinds:Bindings) (TBind(f,b,letSeqPtOpt)) = - let wf = Zmap.force f penv.arityM ("fHatNewBinding - arityM",nameOfVal) - let fHat = Zmap.force f penv.fHatM ("fHatNewBinding - fHatM",nameOfVal) + let wf = Map.force {CompareObj=f} penv.arityM ("fHatNewBinding - arityM",fun x -> nameOfVal x.CompareObj) + let fHat = Map.force {CompareObj=f} penv.fHatM ("fHatNewBinding - fHatM",fun x -> nameOfVal x.CompareObj) // Take off the variables let tps,vss,b,rty = stripTopLambda (b,f.Type) // Don't take all the variables - only up to length wf @@ -1022,7 +1022,7 @@ module Pass4_RewriteAssembly = newBinds,rebinds let GetAEnvBindings penv fc = - match Zmap.tryFind fc penv.envPackM with + match MapCustom.tryFind fc penv.envPackM with | None -> List.empty // no env for this mutual binding | Some envp -> envp.ep_pack // environment pack bindings @@ -1060,14 +1060,14 @@ module Pass4_RewriteAssembly = match fx with | Expr.Val (fvref:ValRef,_,m) when (Zset.contains fvref.Deref penv.tlrS) && - (let wf = Zmap.force fvref.Deref penv.arityM ("TransApp - wf",nameOfVal) + (let wf = Map.force {CompareObj=fvref.Deref} penv.arityM ("TransApp - wf",fun x -> nameOfVal x.CompareObj) IsArityMet fvref wf tys args) -> let f = fvref.Deref (* replace by direct call to corresponding fHat (and additional closure args) *) let fc = Map.force {CompareObj=f} penv.fclassM ("TransApp - fc",fun x -> nameOfVal x.CompareObj) - let envp = Zmap.force fc penv.envPackM ("TransApp - envp",string) - let fHat = Zmap.force f penv.fHatM ("TransApp - fHat",nameOfVal) + let envp = Map.force {CompareObj=fc} penv.envPackM ("TransApp - envp",fun x -> string x.CompareObj) + let fHat = Map.force {CompareObj=f} penv.fHatM ("TransApp - fHat",fun x -> nameOfVal x.CompareObj) let tys = (List.map mkTyparTy envp.ep_etps) @ tys let aenvExprs = List.map (exprForVal m) envp.ep_aenvs let args = aenvExprs @ args diff --git a/src/utils/SortKey.fs b/src/utils/SortKey.fs index d859fc92601..a2389b54c2d 100644 --- a/src/utils/SortKey.fs +++ b/src/utils/SortKey.fs @@ -60,6 +60,17 @@ type MapCustom<'Key,'Value>() = static member inline remove<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (k:'Key) (m:Map,'Value>) = Map.remove {CompareObj=k} m + static member inline keys<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (m:Map,'Value>) = + Map.foldBack (fun {CompareObj=k} _ s -> k::s) m [] + + static member inline values<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (m:Map,'Value>) = + Map.foldBack (fun _ v s -> v::s) m [] + + static member inline toList<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (m:Map,'Value>) = + Map.foldBack (fun {CompareObj=k} v acc -> (k,v) :: acc) m [] + + static member inline iter<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (f:'Key->'Value->unit) (m:Map,'Value>) = + Map.iter (fun {CompareObj=k} v -> f k v) m static member foldMap<'Comparer, 'State, 'U when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (folder:'State->'Key->'Value->'State*'U) (initialState:'State) (initialMap:Map,'Value>) : 'State * Map,'U> = let f = OptimizedClosures.FSharpFunc<_,_,_,_>.Adapt folder @@ -70,3 +81,4 @@ type MapCustom<'Key,'Value>() = let m' = Map.add {CompareObj=k} v' m struct (acc', m')) finalState, finalMap + From b48f0247432e608c8f3c0884051fd676bb8f86e3 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Thu, 9 Aug 2018 21:12:52 +1000 Subject: [PATCH 72/92] Removed now unused TaggedCollections.Map & Zmap --- .../FSharp.Compiler.Service.fsproj | 6 - src/absil/ilreflect.fs | 3 - src/absil/zmap.fs | 47 --- src/absil/zmap.fsi | 45 --- .../FSharp.Compiler.Private.fsproj | 6 - .../FSharp.Compiler.Private.fsproj | 6 - src/fsharp/Fsc-proto/Fsc-proto.fsproj | 6 - src/fsharp/InnerLambdasToTopLevelFuncs.fs | 8 - src/fsharp/lib.fs | 10 +- src/utils/TaggedCollections.fs | 362 ------------------ src/utils/TaggedCollections.fsi | 107 +----- 11 files changed, 2 insertions(+), 604 deletions(-) delete mode 100644 src/absil/zmap.fs delete mode 100644 src/absil/zmap.fsi diff --git a/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj b/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj index f25e6e01060..3d5c4dedfbf 100644 --- a/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj +++ b/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj @@ -138,12 +138,6 @@ Utilities/filename.fs - - Utilities/zmap.fsi - - - Utilities/zmap.fs - Utilities/zset.fsi diff --git a/src/absil/ilreflect.fs b/src/absil/ilreflect.fs index b48e7fbd82f..7a913101428 100644 --- a/src/absil/ilreflect.fs +++ b/src/absil/ilreflect.fs @@ -285,9 +285,6 @@ let inline flagsIf b x = if b then x else enum 0 module Map = let force x m str = match Map.tryFind x m with Some y -> y | None -> failwithf "Map.force: %s: x = %+A" str x -module Zmap = - let force x m str = match Zmap.tryFind x m with Some y -> y | None -> failwithf "Zmap.force: %s: x = %+A" str x - let equalTypes (s:Type) (t:Type) = s.Equals(t) let equalTypeLists ss tt = List.lengthsEqAndForall2 equalTypes ss tt diff --git a/src/absil/zmap.fs b/src/absil/zmap.fs deleted file mode 100644 index c08767e2744..00000000000 --- a/src/absil/zmap.fs +++ /dev/null @@ -1,47 +0,0 @@ -// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. - -namespace Microsoft.FSharp.Compiler.AbstractIL.Internal - -open Internal.Utilities.Collections.Tagged -open System.Collections.Generic - -/// Maps with a specific comparison function -type internal Zmap<'Key,'T> = Internal.Utilities.Collections.Tagged.Map<'Key,'T> - -[] -module internal Zmap = - - let empty (ord: IComparer<'T>) = Map<_,_,_>.Empty(ord) - - let add k v (m:Zmap<_,_>) = m.Add(k,v) - let find k (m:Zmap<_,_>) = m.[k] - let tryFind k (m:Zmap<_,_>) = m.TryFind(k) - let remove k (m:Zmap<_,_>) = m.Remove(k) - let mem k (m:Zmap<_,_>) = m.ContainsKey(k) - let iter f (m:Zmap<_,_>) = m.Iterate(f) - let first f (m:Zmap<_,_>) = m.First(fun k v -> if f k v then Some (k,v) else None) - let exists f (m:Zmap<_,_>) = m.Exists(f) - let forall f (m:Zmap<_,_>) = m.ForAll(f) - let map f (m:Zmap<_,_>) = m.MapRange(f) - let mapi f (m:Zmap<_,_>) = m.Map(f) - let fold f (m:Zmap<_,_>) x = m.Fold f x - let toList (m:Zmap<_,_>) = m.ToList() - let foldSection lo hi f (m:Zmap<_,_>) x = m.FoldSection lo hi f x - - let isEmpty (m:Zmap<_,_>) = m.IsEmpty - - let foldMap f z (m:Zmap<_,_>) = - let m,z = m.FoldAndMap (fun k v z -> let z,v' = f z k v in v',z) z in - z,m - - let choose f (m:Zmap<_,_>) = m.First(f) - - let chooseL f (m:Zmap<_,_>) = - m.Fold (fun k v s -> match f k v with None -> s | Some x -> x::s) [] - - let ofList ord xs = Internal.Utilities.Collections.Tagged.Map<_,_>.FromList(ord,xs) - - let keys (m:Zmap<_,_>) = m.Fold (fun k _ s -> k::s) [] - let values (m:Zmap<_,_>) = m.Fold (fun _ v s -> v::s) [] - - let memberOf m k = mem k m diff --git a/src/absil/zmap.fsi b/src/absil/zmap.fsi deleted file mode 100644 index 12a17400029..00000000000 --- a/src/absil/zmap.fsi +++ /dev/null @@ -1,45 +0,0 @@ -// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. - -namespace Microsoft.FSharp.Compiler.AbstractIL.Internal - -open Internal.Utilities -open Internal.Utilities.Collections.Tagged -open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library -open System.Collections.Generic - -/// Maps with a specific comparison function -type internal Zmap<'Key,'T> = Internal.Utilities.Collections.Tagged.Map<'Key,'T> - -[] -module internal Zmap = - - val empty : IComparer<'Key> -> Zmap<'Key,'T> - val isEmpty : Zmap<'Key,'T> -> bool - - val add : 'Key -> 'T -> Zmap<'Key,'T> -> Zmap<'Key,'T> - val remove : 'Key -> Zmap<'Key,'T> -> Zmap<'Key,'T> - val mem : 'Key -> Zmap<'Key,'T> -> bool - val memberOf : Zmap<'Key,'T> -> 'Key -> bool - val tryFind : 'Key -> Zmap<'Key,'T> -> 'T option - val find : 'Key -> Zmap<'Key,'T> -> 'T // raises KeyNotFoundException - - val map : mapping:('T -> 'U) -> Zmap<'Key,'T> -> Zmap<'Key,'U> - val mapi : ('Key -> 'T -> 'U) -> Zmap<'Key,'T> -> Zmap<'Key,'U> - val fold : ('Key -> 'T -> 'U -> 'U) -> Zmap<'Key,'T> -> 'U -> 'U - val foldMap : ('State -> 'Key -> 'T -> 'State * 'U) -> 'State -> Zmap<'Key,'T> -> 'State * Zmap<'Key,'U> - val iter : action:('T -> 'U -> unit) -> Zmap<'T, 'U> -> unit - - val foldSection: 'Key -> 'Key -> ('Key -> 'T -> 'U -> 'U) -> Zmap<'Key,'T> -> 'U -> 'U - - val first : ('Key -> 'T -> bool) -> Zmap<'Key,'T> -> ('Key * 'T) option - val exists : ('Key -> 'T -> bool) -> Zmap<'Key,'T> -> bool - val forall : ('Key -> 'T -> bool) -> Zmap<'Key,'T> -> bool - - val choose : ('Key -> 'T -> 'U option) -> Zmap<'Key,'T> -> 'U option - val chooseL : ('Key -> 'T -> 'U option) -> Zmap<'Key,'T> -> 'U list - - val toList : Zmap<'Key,'T> -> ('Key * 'T) list - val ofList : IComparer<'Key> -> ('Key * 'T) list -> Zmap<'Key,'T> - - val keys : Zmap<'Key,'T> -> 'Key list - val values : Zmap<'Key,'T> -> 'T list diff --git a/src/buildfromsource/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj b/src/buildfromsource/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj index 4f2b71ef4b6..16883847faa 100644 --- a/src/buildfromsource/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj +++ b/src/buildfromsource/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj @@ -99,12 +99,6 @@ Utilities\filename.fs - - Utilities\zmap.fsi - - - Utilities\zmap.fs - Utilities\zset.fsi diff --git a/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj b/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj index 68d6522fd22..afd20bf59ac 100644 --- a/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj +++ b/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj @@ -137,12 +137,6 @@ Utilities\filename.fs - - Utilities\zmap.fsi - - - Utilities\zmap.fs - Utilities\zset.fsi diff --git a/src/fsharp/Fsc-proto/Fsc-proto.fsproj b/src/fsharp/Fsc-proto/Fsc-proto.fsproj index 711438aba0b..a0d7bbe60fa 100644 --- a/src/fsharp/Fsc-proto/Fsc-proto.fsproj +++ b/src/fsharp/Fsc-proto/Fsc-proto.fsproj @@ -121,12 +121,6 @@ filename.fs - - zmap.fsi - - - zmap.fs - zset.fsi diff --git a/src/fsharp/InnerLambdasToTopLevelFuncs.fs b/src/fsharp/InnerLambdasToTopLevelFuncs.fs index 9400e5ff225..22830dc249a 100644 --- a/src/fsharp/InnerLambdasToTopLevelFuncs.fs +++ b/src/fsharp/InnerLambdasToTopLevelFuncs.fs @@ -33,14 +33,6 @@ module Map = PreserveStackTrace(e) raise e -module Zmap = - let force k mp (str,soK) = - try Zmap.find k mp - with e -> - dprintf "Zmap.force: %s %s\n" str (soK k); - PreserveStackTrace(e) - raise e - //------------------------------------------------------------------------- // misc //------------------------------------------------------------------------- diff --git a/src/fsharp/lib.fs b/src/fsharp/lib.fs index c8d65730098..915c361f907 100755 --- a/src/fsharp/lib.fs +++ b/src/fsharp/lib.fs @@ -262,20 +262,12 @@ module List = Zset.elements s // get elements... no repeats //--------------------------------------------------------------------------- -// Zmap rebinds +// Map rebinds //------------------------------------------------------------------------- module Map = let force k mp = match Map.tryFind k mp with Some x -> x | None -> failwith "Map.force: lookup failed" -module Zmap = - let force k mp = match Zmap.tryFind k mp with Some x -> x | None -> failwith "Zmap.force: lookup failed" - - let mapKey key f mp = - match f (Zmap.tryFind key mp) with - | Some fx -> Zmap.add key fx mp - | None -> Zmap.remove key mp - //--------------------------------------------------------------------------- // Zset //------------------------------------------------------------------------- diff --git a/src/utils/TaggedCollections.fs b/src/utils/TaggedCollections.fs index 6eb89d326c7..13c39890c69 100644 --- a/src/utils/TaggedCollections.fs +++ b/src/utils/TaggedCollections.fs @@ -700,366 +700,4 @@ namespace Internal.Utilities.Collections.Tagged static member Create(comparer : 'ComparerTag,l : seq<'T>) : Set<'T,'ComparerTag> = Set<_,_>(comparer=comparer, tree=SetTree.ofSeq comparer l) - - [] - type MapTree<'Key,'Value> = - | MapNode of Key:'Key * Value:'Value * Left:MapTree<'Key,'Value> * Right:MapTree<'Key,'Value> * Size:int - - - [] - module MapTree = - - [] - type Constants<'Key, 'Value> private () = - static let empty = MapNode(Unchecked.defaultof<'Key>, Unchecked.defaultof<'Value>, Unchecked.defaultof>, Unchecked.defaultof>, 0) - static member Empty = empty - - let inline size (MapNode(Size=s)) = s - let inline key (MapNode(Key=k)) = k - let inline value (MapNode(Value=v)) = v - let inline left (MapNode(Left=l)) = l - let inline right (MapNode(Right=r)) = r - - let inline isEmpty (MapNode(Size=s)) = s = 0 - - let inline (++) l r = Checked.(+) l r - - let inline mk l k v r = - MapNode (k,v,l,r, size l ++ size r ++ 1) - - let inline mkLeaf k v = - MapNode (k, v, Constants.Empty, Constants.Empty, 1) - - let private rebalanceRight l k v (MapNode(rk,rv,rl,rr,_)) = - (* one of the nodes must have height > height t1 + 1 *) - if size rl > size l then (* balance left: combination *) - match rl with - | MapNode(rlk,rlv,rll,rlr,_) -> mk (mk l k v rll) rlk rlv (mk rlr rk rv rr) - else (* rotate left *) - mk (mk l k v rl) rk rv rr - - let private rebalanceLeft (MapNode(lk,lv,ll,lr,_)) k v r = - (* one of the nodes must have height > height t2 + 1 *) - if size lr > size r then - (* balance right: combination *) - match lr with - | MapNode(lrk,lrv,lrl,lrr,_) -> mk (mk ll lk lv lrl) lrk lrv (mk lrr k v r) - else - mk ll lk lv (mk lr k v r) - - let inline rebalance l k v r = - let ls, rs = size l, size r - if (rs >>> 1) > ls then rebalanceRight l k v r - elif (ls >>> 1) > rs then rebalanceLeft l k v r - else MapNode (k,v,l,r, ls ++ rs ++ 1) - - let rec add (comparer:IComparer<'Key>) k v (MapNode(k2,v2,l,r,s)) = - if s = 0 then mkLeaf k v - else - let c = comparer.Compare(k,k2) - if c < 0 then - let l' = add comparer k v l - let l's, rs = size l', size r - if (l's >>> 1) > rs then - rebalanceLeft l' k2 v2 r - else - MapNode (k2,v2,l',r, l's ++ rs ++ 1) - elif c > 0 then - let r' = add comparer k v r - let ls, r's = size l, size r' - if (r's >>> 1) > ls then - rebalanceRight l k2 v2 r' - else - MapNode (k2,v2,l,r', ls ++ r's ++ 1) - else - MapNode(k,v,l,r,s) - - let indexNotFound() = raise (new System.Collections.Generic.KeyNotFoundException("An index satisfying the predicate was not found in the collection")) - - let inline private findImpl (comparer:IComparer<'Key>) k m found notfound = - let rec loop m = - if (size m) = 0 then notfound () - else - let c = comparer.Compare(k, key m) - if c < 0 then loop (left m) - elif c > 0 then loop (right m) - else found (value m) - loop m - - let find comparer k m = findImpl comparer k m id (fun () -> indexNotFound()) - let tryFind comparer k m = findImpl comparer k m Some (fun () -> None) - - let partition1 (comparer: IComparer<'T>) f k v (acc1,acc2) = - if f k v then (add comparer k v acc1,acc2) else (acc1,add comparer k v acc2) - - let rec partitionAux (comparer: IComparer<'T>) f s acc = - match s with - | MapNode(Size=0) -> acc - | MapNode(k,v,l,r,_) -> - let acc = partitionAux comparer f r acc - let acc = partition1 comparer f k v acc - partitionAux comparer f l acc - - let partition (comparer: IComparer<'T>) f s = partitionAux comparer f s (Constants.Empty,Constants.Empty) - - let filter1 (comparer: IComparer<'T>) f k v acc = if f k v then add comparer k v acc else acc - - let rec filterAux (comparer: IComparer<'T>) f s acc = - match s with - | MapNode(Size=0) -> acc - | MapNode(k,v,l,r,_) -> - let acc = filterAux comparer f l acc - let acc = filter1 comparer f k v acc - filterAux comparer f r acc - - let filter (comparer: IComparer<'T>) f s = filterAux comparer f s Constants.Empty - - let rec spliceOutSuccessor m = - match m with - | MapNode(Size=0) -> failwith "internal error: Map.splice_out_succ_or_pred" - | MapNode(k2,v2,l,r,_) -> - match l with - | MapNode(Size=0) -> k2,v2,r - | _ -> let k3,v3,l' = spliceOutSuccessor l in k3,v3,mk l' k2 v2 r - - let rec remove (comparer: IComparer<'T>) k m = - match m with - | MapNode(Size=0) -> Constants.Empty - | MapNode(k2,v2,l,r,_) -> - let c = comparer.Compare(k,k2) - if c < 0 then rebalance (remove comparer k l) k2 v2 r - elif c = 0 then - match l,r with - | MapNode(Size=0),_ -> r - | _,MapNode(Size=0) -> l - | _ -> - let sk,sv,r' = spliceOutSuccessor r - mk l sk sv r' - else rebalance l k2 v2 (remove comparer k r) - - let rec containsKey (comparer: IComparer<'T>) k m = - match m with - | MapNode(Size=0) -> false - | MapNode(k2,_,l,r,_) -> - let c = comparer.Compare(k,k2) - if c < 0 then containsKey comparer k l - else (c = 0 || containsKey comparer k r) - - let rec iter f m = - match m with - | MapNode(Size=0) -> () - | MapNode(k2,v2,l,r,_) -> iter f l; f k2 v2; iter f r - - let rec first f m = - match m with - | MapNode(Size=0) -> None - | MapNode(k2,v2,l,r,_) -> - match first f l with - | Some _ as res -> res - | None -> - match f k2 v2 with - | Some _ as res -> res - | None -> first f r - - let rec exists f m = - match m with - | MapNode(Size=0) -> false - | MapNode(k2,v2,l,r,_) -> f k2 v2 || exists f l || exists f r - - let rec forAll f m = - match m with - | MapNode(Size=0) -> true - | MapNode(k2,v2,l,r,_) -> f k2 v2 && forAll f l && forAll f r - - let rec map f m = - match m with - | MapNode(Size=0) -> Constants.Empty - | MapNode(k,v,l,r,h) -> let v2 = f v in MapNode(k,v2,map f l, map f r,h) - - let rec mapi f m = - match m with - | MapNode(Size=0) -> Constants.Empty - | MapNode(k,v,l,r,h) -> let v2 = f k v in MapNode(k,v2, mapi f l, mapi f r,h) - - // Fold, right-to-left. - // - // NOTE: This differs from the behaviour of Set.fold which folds left-to-right. - let rec fold f m x = - match m with - | MapNode(Size=0) -> x - | MapNode(k,v,l,r,_) -> fold f l (f k v (fold f r x)) - - let foldSection (comparer: IComparer<'T>) lo hi f m x = - let rec fold_from_to f m x = - match m with - | MapNode(Size=0) -> x - | MapNode(k,v,l,r,_) -> - let clo_k = comparer.Compare(lo,k) - let ck_hi = comparer.Compare(k,hi) - let x = if clo_k < 0 then fold_from_to f l x else x - let x = if clo_k <= 0 && ck_hi <= 0 then f k v x else x - let x = if ck_hi < 0 then fold_from_to f r x else x - x - - if comparer.Compare(lo,hi) = 1 then x else fold_from_to f m x - - let rec foldMap (comparer: IComparer<'T>) f m z acc = - match m with - | MapNode(Size=0) -> acc,z - | MapNode(k,v,l,r,_) -> - let acc,z = foldMap comparer f r z acc - let v',z = f k v z - let acc = add comparer k v' acc - foldMap comparer f l z acc - - let toList m = fold (fun k v acc -> (k,v) :: acc) m [] - let toArray m = m |> toList |> Array.ofList - let ofList comparer l = List.fold (fun acc (k,v) -> add comparer k v acc) Constants.Empty l - - - let rec mkFromEnumerator comparer acc (e : IEnumerator<_>) = - if e.MoveNext() then - let (x,y) = e.Current - mkFromEnumerator comparer (add comparer x y acc) e - else acc - - let ofSeq comparer (c : seq<_>) = - use ie = c.GetEnumerator() - mkFromEnumerator comparer Constants.Empty ie - - let copyToArray s (arr: _[]) i = - let j = ref i - s |> iter (fun x y -> arr.[!j] <- KeyValuePair(x,y); j := !j + 1) - - - /// Imperative left-to-right iterators. - type MapIterator<'Key,'T>(s:MapTree<'Key,'T>) = - // collapseLHS: - // a) Always returns either [] or a list starting with SetOne. - // b) The "fringe" of the set stack is unchanged. - let rec collapseLHS stack = - match stack with - | [] -> [] - | MapNode(Size=0) :: rest -> collapseLHS rest - | (MapNode(_,_,MapNode(Size=0),MapNode(Size=0),_)) :: _ -> stack - | (MapNode(k,v,l,r,_)) :: rest -> collapseLHS (l :: (mkLeaf k v) :: r :: rest) - - /// invariant: always collapseLHS result - let mutable stack = collapseLHS [s] - /// true when MoveNext has been called - let mutable started = false - - let notStarted() = raise (new System.InvalidOperationException("Enumeration has not started. Call MoveNext.")) - let alreadyFinished() = raise (new System.InvalidOperationException("Enumeration already finished.")) - - member i.Current = - if started then - match stack with - | (MapNode(k,v,MapNode(Size=0),MapNode(Size=0),_)) :: _ -> new KeyValuePair<_,_>(k,v) - | [] -> alreadyFinished() - | _ -> failwith "Please report error: Map iterator, unexpected stack for current" - else - notStarted() - - member i.MoveNext() = - if started then - match stack with - | (MapNode(_,_,MapNode(Size=0),MapNode(Size=0),_)) :: rest -> - stack <- collapseLHS rest; - not stack.IsEmpty - | [] -> false - | _ -> failwith "Please report error: Map iterator, unexpected stack for moveNext" - else - // The first call to MoveNext "starts" the enumeration. - started <- true; - not stack.IsEmpty - - let toSeq s = - let i = ref (MapIterator(s)) - { new IEnumerator<_> with - member self.Current = (!i).Current - interface System.Collections.IEnumerator with - member self.Current = box (!i).Current - member self.MoveNext() = (!i).MoveNext() - member self.Reset() = i := MapIterator(s) - interface System.IDisposable with - member self.Dispose() = ()} - - - [] - [] - type internal Map<'Key,'T,'ComparerTag> when 'ComparerTag :> IComparer<'Key>( comparer: IComparer<'Key>, tree: MapTree<'Key,'T>) = - - static let refresh (m:Map<_,_,'ComparerTag>) t = - Map<_,_,'ComparerTag>(comparer=m.Comparer, tree=t) - - member s.Tree = tree - member s.Comparer : IComparer<'Key> = comparer - - static member Empty(comparer : 'ComparerTag) = Map<'Key,'T,'ComparerTag>(comparer=comparer, tree=MapTree.Constants.Empty) - member m.Add(k,v) = refresh m (MapTree.add comparer k v tree) - member m.IsEmpty = MapTree.isEmpty tree - member m.Item with get(k : 'Key) = MapTree.find comparer k tree - member m.First(f) = MapTree.first f tree - member m.Exists(f) = MapTree.exists f tree - member m.Filter(f) = MapTree.filter comparer f tree |> refresh m - member m.ForAll(f) = MapTree.forAll f tree - member m.Fold f acc = MapTree.fold f tree acc - member m.FoldSection lo hi f acc = MapTree.foldSection comparer lo hi f tree acc - member m.FoldAndMap f z = - let tree,z = MapTree.foldMap comparer f tree z MapTree.Constants.Empty - refresh m tree, z - member m.Iterate f = MapTree.iter f tree - member m.MapRange f = refresh m (MapTree.map f tree) - member m.Map f = refresh m (MapTree.mapi f tree) - member m.Partition(f) = - let r1,r2 = MapTree.partition comparer f tree - refresh m r1, refresh m r2 - member m.Count = MapTree.size tree - member m.ContainsKey(k) = MapTree.containsKey comparer k tree - member m.Remove(k) = refresh m (MapTree.remove comparer k tree) - member m.TryFind(k) = MapTree.tryFind comparer k tree - member m.ToList() = MapTree.toList tree - member m.ToArray() = MapTree.toArray tree - - static member FromList(comparer : 'ComparerTag,l) : Map<'Key,'T,'ComparerTag> = - Map<_,_,_>(comparer=comparer, tree=MapTree.ofList comparer l) - - static member Create(comparer : 'ComparerTag, ie : seq<_>) : Map<'Key,'T,'ComparerTag> = - Map<_,_,_>(comparer=comparer, tree=MapTree.ofSeq comparer ie) - - interface IEnumerable> with - member s.GetEnumerator() = MapTree.toSeq tree - - interface System.Collections.IEnumerable with - override s.GetEnumerator() = (MapTree.toSeq tree :> System.Collections.IEnumerator) - - override this.Equals(that) = - match that with - // Cast to the exact same type as this, otherwise not equal. - | :? Map<'Key,'T,'ComparerTag> as that -> ((this :> System.IComparable).CompareTo(that) = 0) - | _ -> false - - interface System.IComparable with - member m1.CompareTo(m2: obj) = - Seq.compareWith - (fun (kvp1 : KeyValuePair<_,_>) (kvp2 : KeyValuePair<_,_>)-> - let c = m1.Comparer.Compare(kvp1.Key,kvp2.Key) in - if c <> 0 then c else Unchecked.compare kvp1.Value kvp2.Value) - // Cast m2 to the exact same type as m1, see 4884. - // It is not OK to cast m2 to seq>, since different compares could permute the KVPs. - m1 (m2 :?> Map<'Key,'T,'ComparerTag>) - - member this.ComputeHashCode() = - let combineHash x y = (x <<< 1) + y + 631 - let mutable res = 0 - for KeyValue(x,y) in this do - res <- combineHash res (Unchecked.hash x) - res <- combineHash res (Unchecked.hash y) - abs res - - override this.GetHashCode() = this.ComputeHashCode() - - - type internal Map<'Key,'T> = Map<'Key, 'T, IComparer<'Key>> type internal Set<'T> = Set<'T, IComparer<'T>> diff --git a/src/utils/TaggedCollections.fsi b/src/utils/TaggedCollections.fsi index c877cbe7eb5..24d029668d7 100644 --- a/src/utils/TaggedCollections.fsi +++ b/src/utils/TaggedCollections.fsi @@ -116,109 +116,4 @@ namespace Internal.Utilities.Collections.Tagged override Equals : obj -> bool - type internal Set<'T> = Set<'T, IComparer<'T>> - - /// Immutable maps. Keys are ordered by construction function specified - /// when creating empty maps or by F# structural comparison if no - /// construction function is specified. - /// - /// - /// Maps based on structural comparison are - /// efficient for small keys. They are not a suitable choice if keys are recursive data structures - /// or require non-structural comparison semantics. - /// - - /// Immutable maps. A constraint tag carries information about the class of key-comparers being used. - [] - type internal Map<'Key,'Value,'ComparerTag> when 'ComparerTag :> IComparer<'Key> = - - /// Return a new map with the binding added to the given map. - member Add: 'Key * 'Value -> Map<'Key,'Value,'ComparerTag> - - /// Return True if there are no bindings in the map. - member IsEmpty: bool - - /// The empty map, and use the given comparer comparison function for all operations associated - /// with any maps built from this map. - static member Empty: 'ComparerTag -> Map<'Key,'Value,'ComparerTag> - - static member FromList : 'ComparerTag * ('Key * 'Value) list -> Map<'Key,'Value,'ComparerTag> - - /// Build a map that contains the bindings of the given IEnumerable - /// and where comparison of elements is based on the given comparison function. - static member Create: 'ComparerTag * seq<'Key * 'Value> -> Map<'Key,'Value,'ComparerTag> - - /// Test is an element is in the domain of the map. - member ContainsKey: 'Key -> bool - - /// The number of bindings in the map. - member Count: int - - /// Lookup an element in the map. Raise KeyNotFoundException if no binding - /// exists in the map. - member Item : 'Key -> 'Value with get - - /// Search the map looking for the first element where the given function returns a Some value. - member First: ('Key -> 'Value -> 'T option) -> 'T option - - /// Return True if the given predicate returns true for all of the - /// bindings in the map. Always returns true if the map is empty. - member ForAll: ('Key -> 'Value -> bool) -> bool - - /// Return True if the given predicate returns true for one of the - /// bindings in the map. Always returns false if the map is empty. - member Exists: ('Key -> 'Value -> bool) -> bool - - /// Build a new map containing the bindings for which the given predicate returns True. - member Filter: ('Key -> 'Value -> bool) -> Map<'Key,'Value,'ComparerTag> - - /// Fold over the bindings in the map. - member Fold: folder:('Key -> 'Value -> 'State -> 'State) -> 'State -> 'State - - /// Given the start and end points of a key range, - /// Fold over the bindings in the map that are in the range, - /// and the end points are included if present (the range is considered a closed interval). - member FoldSection: 'Key -> 'Key -> ('Key -> 'Value -> 'State -> 'State) -> 'State -> 'State - - /// Fold over the bindings in the map. - member FoldAndMap: ('Key -> 'Value -> 'State -> 'T * 'State) -> 'State -> Map<'Key,'T,'ComparerTag> * 'State - - /// Apply the given function to each binding in the dictionary. - member Iterate: action:('Key -> 'Value -> unit) -> unit - - /// Build a new collection whose elements are the results of applying the given function - /// to each of the elements of the collection. The index passed to the - /// function indicates the index of element being transformed. - member Map: mapping:('Key -> 'Value -> 'T) -> Map<'Key,'T,'ComparerTag> - - /// Build a new collection whose elements are the results of applying the given function - /// to each of the elements of the collection. - member MapRange: mapping:('Value -> 'T) -> Map<'Key,'T,'ComparerTag> - - /// Build two new maps, one containing the bindings for which the given predicate returns True, - /// and another for the remaining bindings. - member Partition: ('Key -> 'Value -> bool) -> Map<'Key,'Value,'ComparerTag> * Map<'Key,'Value,'ComparerTag> - - /// Remove an element from the domain of the map. No exception is raised if the element is not present. - member Remove: 'Key -> Map<'Key,'Value,'ComparerTag> - - /// Lookup an element in the map, returning a Some value if the element is in the domain - /// of the map and None if not. - member TryFind: 'Key -> 'Value option - - /// The elements of the set as a list. - member ToList : unit -> ('Key * 'Value) list - - /// The elements of the set as an array. - member ToArray: unit -> ('Key * 'Value) array - - interface IEnumerable> - - interface System.Collections.IEnumerable - - interface System.IComparable - - override Equals : obj -> bool - - type internal Map<'Key,'Value> = Map<'Key, 'Value, IComparer<'Key>> - + type internal Set<'T> = Set<'T, IComparer<'T>> \ No newline at end of file From efb31dcc8deb4de25249c439de82467cc75892b0 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Fri, 10 Aug 2018 19:29:59 +1000 Subject: [PATCH 73/92] Converted Map.force to MapCustom.force --- src/fsharp/InnerLambdasToTopLevelFuncs.fs | 44 +++++++++++------------ src/fsharp/lib.fs | 7 ---- 2 files changed, 22 insertions(+), 29 deletions(-) diff --git a/src/fsharp/InnerLambdasToTopLevelFuncs.fs b/src/fsharp/InnerLambdasToTopLevelFuncs.fs index 22830dc249a..45c6a8ad54c 100644 --- a/src/fsharp/InnerLambdasToTopLevelFuncs.fs +++ b/src/fsharp/InnerLambdasToTopLevelFuncs.fs @@ -25,9 +25,9 @@ let verboseTLR = false let internalError str = dprintf "Error: %s\n" str;raise (Failure str) -module Map = - let force k mp (str,soK) = - try Map.find k mp +module MapCustom = + let force (k:'Key) (mp:Map,'T>) (str,soK) = + try MapCustom.find k mp with e -> dprintf "Map.force: %s %s\n" str (soK k); PreserveStackTrace(e) @@ -196,8 +196,8 @@ module Pass1_DetermineTLRAndArities = /// ValRec considered: recursive && some f in mutual binding is not bound to a lambda let IsValueRecursionFree xinfo f = - let hasDelayedRepr f = isDelayedRepr f (Map.force {CompareObj=f} xinfo.Defns ("IsValueRecursionFree - hasDelayedRepr",(fun {CompareObj=v} -> nameOfVal v))) - let isRecursive,mudefs = Map.force {CompareObj=f} xinfo.RecursiveBindings ("IsValueRecursionFree",(fun {CompareObj=v} -> nameOfVal v)) + let hasDelayedRepr f = isDelayedRepr f (MapCustom.force f xinfo.Defns ("IsValueRecursionFree - hasDelayedRepr",nameOfVal)) + let isRecursive,mudefs = MapCustom.force f xinfo.RecursiveBindings ("IsValueRecursionFree",nameOfVal) not isRecursive || List.forall hasDelayedRepr mudefs let DumpArity arityM = @@ -567,8 +567,8 @@ module Pass2_DetermineReqdItems = let closeStep reqdItemsMap changed fc (env: ReqdItemsForDefn) = let directCallReqdEnvs = env.ReqdSubEnvs let directCallReqdTypars = directCallReqdEnvs |> List.map (fun f -> - let fc = Map.force {CompareObj=f} fclassM ("reqdTyparsFor",(fun x -> nameOfVal x.CompareObj)) - let env = Map.force {CompareObj=fc} reqdItemsMap ("reqdTyparsFor",(fun x -> string x.CompareObj)) + let fc = MapCustom.force f fclassM ("reqdTyparsFor",nameOfVal) + let env = MapCustom.force fc reqdItemsMap ("reqdTyparsFor",string) env.reqdTypars) let reqdTypars0 = env.reqdTypars @@ -687,13 +687,13 @@ exception AbortTLR of Range.range /// where /// aenvFor(v) = aenvi where (v,aenvi) in cmap. let FlatEnvPacks g fclassM topValS declist (reqdItemsMap: Map,ReqdItemsForDefn>) = - let fclassOf f = Map.force {CompareObj=f} fclassM ("fclassM",fun x -> nameOfVal x.CompareObj) + let fclassOf f = MapCustom.force f fclassM ("fclassM",nameOfVal) let packEnv carrierMaps (fc:BindingGroupSharingSameReqdItems) = if verboseTLR then dprintf "\ntlr: packEnv fc=%A\n" fc - let env = Map.force {CompareObj=fc} reqdItemsMap ("packEnv",fun x -> string x.CompareObj) + let env = MapCustom.force fc reqdItemsMap ("packEnv",string) // carrierMaps = (fclass,(v,aenv)map)map - let carrierMapFor f = Map.force {CompareObj=fclassOf f} carrierMaps ("carrierMapFor",fun x -> string x.CompareObj) + let carrierMapFor f = MapCustom.force (fclassOf f) carrierMaps ("carrierMapFor",string) let valsSubEnvFor f = MapCustom.keys (carrierMapFor f) // determine vals(env) - transclosure @@ -745,7 +745,7 @@ let FlatEnvPacks g fclassM topValS declist (reqdItemsMap: Map List.map (fun v -> (v,(mkCompGenLocal env.m v.LogicalName v.Type |> fst))) let cmap = MapCustom.ofList cmapPairs - let aenvFor v = Map.force {CompareObj=v} cmap ("aenvFor",fun x -> nameOfVal x.CompareObj) + let aenvFor v = MapCustom.force v cmap ("aenvFor",nameOfVal) let aenvExprFor v = exprForVal env.m (aenvFor v) // build PackedReqdItems @@ -828,9 +828,9 @@ let MakeSimpleArityInfo tps n = ValReprInfo (ValReprInfo.InferTyparInfo tps,List let CreateNewValuesForTLR g tlrS arityM fclassM envPackM = if verboseTLR then dprintf "CreateNewValuesForTLR------\n" let createFHat (f:Val) = - let wf = Map.force {CompareObj=f} arityM ("createFHat - wf",(fun v -> showL (valL v.CompareObj))) - let fc = Map.force {CompareObj=f} fclassM ("createFHat - fc",fun x -> nameOfVal x.CompareObj) - let envp = Map.force {CompareObj=fc} envPackM ("CreateNewValuesForTLR - envp",fun x -> string x.CompareObj) + let wf = MapCustom.force f arityM ("createFHat - wf",(fun v -> showL (valL v))) + let fc = MapCustom.force f fclassM ("createFHat - fc",nameOfVal) + let envp = MapCustom.force fc envPackM ("CreateNewValuesForTLR - envp",string) let name = f.LogicalName (* + "_TLR_" + string wf *) let m = f.Range let tps,tau = f.TypeScheme @@ -969,14 +969,14 @@ module Pass4_RewriteAssembly = let TransTLRBindings penv (binds:Bindings) = if isNil binds then List.empty,List.empty else let fc = BindingGroupSharingSameReqdItems binds - let envp = Map.force {CompareObj=fc} penv.envPackM ("TransTLRBindings",fun x -> string x.CompareObj) + let envp = MapCustom.force fc penv.envPackM ("TransTLRBindings",string) let fRebinding (TBind(fOrig,b,letSeqPtOpt)) = let m = fOrig.Range let tps,vss,_b,rty = stripTopLambda (b,fOrig.Type) let aenvExprs = envp.ep_aenvs |> List.map (exprForVal m) let vsExprs = vss |> List.map (mkRefTupledVars penv.g m) - let fHat = Map.force {CompareObj=fOrig} penv.fHatM ("fRebinding",fun x -> nameOfVal x.CompareObj) + let fHat = MapCustom.force fOrig penv.fHatM ("fRebinding",nameOfVal) (* REVIEW: is this mutation really, really necessary? *) (* Why are we applying TLR if the thing already has an arity? *) let fOrig = setValHasNoArity fOrig @@ -989,8 +989,8 @@ module Pass4_RewriteAssembly = fBind let fHatNewBinding (shortRecBinds:Bindings) (TBind(f,b,letSeqPtOpt)) = - let wf = Map.force {CompareObj=f} penv.arityM ("fHatNewBinding - arityM",fun x -> nameOfVal x.CompareObj) - let fHat = Map.force {CompareObj=f} penv.fHatM ("fHatNewBinding - fHatM",fun x -> nameOfVal x.CompareObj) + let wf = MapCustom.force f penv.arityM ("fHatNewBinding - arityM",nameOfVal) + let fHat = MapCustom.force f penv.fHatM ("fHatNewBinding - fHatM",nameOfVal) // Take off the variables let tps,vss,b,rty = stripTopLambda (b,f.Type) // Don't take all the variables - only up to length wf @@ -1052,14 +1052,14 @@ module Pass4_RewriteAssembly = match fx with | Expr.Val (fvref:ValRef,_,m) when (Zset.contains fvref.Deref penv.tlrS) && - (let wf = Map.force {CompareObj=fvref.Deref} penv.arityM ("TransApp - wf",fun x -> nameOfVal x.CompareObj) + (let wf = MapCustom.force fvref.Deref penv.arityM ("TransApp - wf",nameOfVal) IsArityMet fvref wf tys args) -> let f = fvref.Deref (* replace by direct call to corresponding fHat (and additional closure args) *) - let fc = Map.force {CompareObj=f} penv.fclassM ("TransApp - fc",fun x -> nameOfVal x.CompareObj) - let envp = Map.force {CompareObj=fc} penv.envPackM ("TransApp - envp",fun x -> string x.CompareObj) - let fHat = Map.force {CompareObj=f} penv.fHatM ("TransApp - fHat",fun x -> nameOfVal x.CompareObj) + let fc = MapCustom.force f penv.fclassM ("TransApp - fc",nameOfVal) + let envp = MapCustom.force fc penv.envPackM ("TransApp - envp",string) + let fHat = MapCustom.force f penv.fHatM ("TransApp - fHat",nameOfVal) let tys = (List.map mkTyparTy envp.ep_etps) @ tys let aenvExprs = List.map (exprForVal m) envp.ep_aenvs let args = aenvExprs @ args diff --git a/src/fsharp/lib.fs b/src/fsharp/lib.fs index 915c361f907..96c53d79d0e 100755 --- a/src/fsharp/lib.fs +++ b/src/fsharp/lib.fs @@ -261,13 +261,6 @@ module List = let s = Zset.addList xs (Zset.empty xOrder) // build set Zset.elements s // get elements... no repeats -//--------------------------------------------------------------------------- -// Map rebinds -//------------------------------------------------------------------------- - -module Map = - let force k mp = match Map.tryFind k mp with Some x -> x | None -> failwith "Map.force: lookup failed" - //--------------------------------------------------------------------------- // Zset //------------------------------------------------------------------------- From 28c95f26d1fbbf65e9de97a0e75e5607facb36a6 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sat, 11 Aug 2018 05:49:02 +1000 Subject: [PATCH 74/92] Renamed MapCusom to Zmap --- src/fsharp/CompileOps.fs | 8 +- src/fsharp/DetupleArgs.fs | 30 ++++---- src/fsharp/InnerLambdasToTopLevelFuncs.fs | 90 +++++++++++------------ src/fsharp/NicePrint.fs | 2 +- src/fsharp/TastOps.fs | 14 ++-- src/fsharp/TypeChecker.fs | 6 +- src/utils/SortKey.fs | 4 +- 7 files changed, 77 insertions(+), 77 deletions(-) diff --git a/src/fsharp/CompileOps.fs b/src/fsharp/CompileOps.fs index aac9ea5365e..1669c8f103c 100644 --- a/src/fsharp/CompileOps.fs +++ b/src/fsharp/CompileOps.fs @@ -5408,7 +5408,7 @@ let GetInitialTcState(m, ccuName, tcConfig:TcConfig, tcGlobals, tcImports:TcImpo tcsTcSigEnv=tcEnv0 tcsTcImplEnv=tcEnv0 tcsCreatesGeneratedProvidedTypes=false - tcsRootSigs = MapCustom.Empty () + tcsRootSigs = Zmap.Empty () tcsRootImpls = Zset.empty qnameOrder tcsCcuSig = NewEmptyModuleOrNamespaceType Namespace } @@ -5430,7 +5430,7 @@ let TypeCheckOneInputEventually (checkForErrors, tcConfig:TcConfig, tcImports:Tc | ParsedInput.SigFile (ParsedSigFileInput(_, qualNameOfFile, _, _, _) as file) -> // Check if we've seen this top module signature before. - if MapCustom.mem qualNameOfFile tcState.tcsRootSigs then + if Zmap.mem qualNameOfFile tcState.tcsRootSigs then errorR(Error(FSComp.SR.buildSignatureAlreadySpecified(qualNameOfFile.Text), m.StartRange)) // Check if the implementation came first in compilation order @@ -5441,7 +5441,7 @@ let TypeCheckOneInputEventually (checkForErrors, tcConfig:TcConfig, tcImports:Tc let! (tcEnv, sigFileType, createsGeneratedProvidedTypes) = TypeCheckOneSigFile (tcGlobals, tcState.tcsNiceNameGen, amap, tcState.tcsCcu, checkForErrors, tcConfig.conditionalCompilationDefines, tcSink, tcConfig.internalTestSpanStackReferring) tcState.tcsTcSigEnv file - let rootSigs = MapCustom.add qualNameOfFile sigFileType tcState.tcsRootSigs + let rootSigs = Zmap.add qualNameOfFile sigFileType tcState.tcsRootSigs // Add the signature to the signature env (unless it had an explicit signature) let ccuSigForFile = CombineCcuContentFragments m [sigFileType; tcState.tcsCcuSig] @@ -5555,7 +5555,7 @@ let TypeCheckClosedInputSetFinish (declaredImpls: TypedImplFile list, tcState) = tcState.tcsCcu.Deref.Contents <- NewCcuContents ILScopeRef.Local range0 tcState.tcsCcu.AssemblyName tcState.tcsCcuSig // Check all interfaces have implementations - tcState.tcsRootSigs |> MapCustom.iter (fun qualNameOfFile _ -> + tcState.tcsRootSigs |> Zmap.iter (fun qualNameOfFile _ -> if not (Zset.contains qualNameOfFile tcState.tcsRootImpls) then errorR(Error(FSComp.SR.buildSignatureWithoutImplementation(qualNameOfFile.Text), qualNameOfFile.Range))) diff --git a/src/fsharp/DetupleArgs.fs b/src/fsharp/DetupleArgs.fs index d18924db818..0e346fa5dc9 100644 --- a/src/fsharp/DetupleArgs.fs +++ b/src/fsharp/DetupleArgs.fs @@ -194,9 +194,9 @@ module GlobalUsageAnalysis = IterationIsAtTopLevel : bool } let z0 = - { Uses = MapCustom.Empty () - Defns = MapCustom.Empty () - RecursiveBindings = MapCustom.Empty () + { Uses = Zmap.Empty () + Defns = Zmap.Empty () + RecursiveBindings = Zmap.Empty () DecisionTreeBindings = Zset.empty valOrder TopLevelBindings = Zset.empty valOrder IterationIsAtTopLevel = true } @@ -205,9 +205,9 @@ module GlobalUsageAnalysis = /// Note: this routine is called very frequently let logUse (f:Val) tup z = {z with Uses = - match MapCustom.tryFind f z.Uses with - | Some sites -> MapCustom.add f (tup::sites) z.Uses - | None -> MapCustom.add f [tup] z.Uses } + match Zmap.tryFind f z.Uses with + | Some sites -> Zmap.add f (tup::sites) z.Uses + | None -> Zmap.add f [tup] z.Uses } /// Log the definition of a binding let logBinding z (isInDTree, v) = @@ -220,14 +220,14 @@ module GlobalUsageAnalysis = let logNonRecBinding z (bind:Binding) = let v = bind.Var let vs = [v] - {z with RecursiveBindings = MapCustom.add v (false, vs) z.RecursiveBindings - Defns = MapCustom.add v bind.Expr z.Defns } + {z with RecursiveBindings = Zmap.add v (false, vs) z.RecursiveBindings + Defns = Zmap.add v bind.Expr z.Defns } /// Log the definition of a recursive binding let logRecBindings z binds = let vs = valsOfBinds binds - {z with RecursiveBindings = (z.RecursiveBindings, vs) ||> List.fold (fun mubinds v -> MapCustom.add v (true, vs) mubinds) - Defns = (z.Defns, binds) ||> List.fold (fun eqns bind -> MapCustom.add bind.Var bind.Expr eqns) } + {z with RecursiveBindings = (z.RecursiveBindings, vs) ||> List.fold (fun mubinds v -> Zmap.add v (true, vs) mubinds) + Defns = (z.Defns, binds) ||> List.fold (fun eqns bind -> Zmap.add bind.Var bind.Expr eqns) } /// Work locally under a lambda of some kind let foldUnderLambda f z x = @@ -537,7 +537,7 @@ let decideFormalSuggestedCP g z tys vss = TupleTS tss let trimTsByVal z ts v = - match MapCustom.tryFind v z.Uses with + match Zmap.tryFind v z.Uses with | None -> UnknownTS (* formal has no usage info, it is unused *) | Some sites -> let trim ts (accessors, _inst, _args) = trimTsByAccess accessors ts @@ -601,7 +601,7 @@ let determineTransforms g (z : GlobalUsageAnalysis.Results) = let selectTransform (f: Val) sites = if not (eligibleVal g f.Range f) then None else // Consider f, if it has top-level lambda (meaning has term args) - match MapCustom.tryFind f z.Defns with + match Zmap.tryFind f z.Defns with | None -> None // no binding site, so no transform | Some e -> let tps, vss, _b, rty = stripTopLambda (e, f.Type) @@ -612,8 +612,8 @@ let determineTransforms g (z : GlobalUsageAnalysis.Results) = let callPatterns = sitesCPs sites // callPatterns from sites decideTransform g z f callPatterns (m, tps, vss, rty) // make transform (if required) - let vtransforms = MapCustom.chooseL selectTransform z.Uses - let vtransforms = MapCustom.ofList vtransforms + let vtransforms = Zmap.chooseL selectTransform z.Uses + let vtransforms = Zmap.ofList vtransforms vtransforms @@ -628,7 +628,7 @@ type penv = ccu : CcuThunk g : TcGlobals } -let hasTransfrom penv f = MapCustom.tryFind f penv.transforms +let hasTransfrom penv f = Zmap.tryFind f penv.transforms //------------------------------------------------------------------------- // pass - app fixup - collapseArgs diff --git a/src/fsharp/InnerLambdasToTopLevelFuncs.fs b/src/fsharp/InnerLambdasToTopLevelFuncs.fs index 45c6a8ad54c..09a33e98e66 100644 --- a/src/fsharp/InnerLambdasToTopLevelFuncs.fs +++ b/src/fsharp/InnerLambdasToTopLevelFuncs.fs @@ -25,9 +25,9 @@ let verboseTLR = false let internalError str = dprintf "Error: %s\n" str;raise (Failure str) -module MapCustom = +module Zmap = let force (k:'Key) (mp:Map,'T>) (str,soK) = - try MapCustom.find k mp + try Zmap.find k mp with e -> dprintf "Map.force: %s %s\n" str (soK k); PreserveStackTrace(e) @@ -138,7 +138,7 @@ let GetValsBoundUnderMustInline xinfo = Zset.union (GetValsBoundInExpr repr) rejectS else rejectS let rejectS = Zset.empty valOrder - let rejectS = MapCustom.fold accRejectFrom xinfo.Defns rejectS + let rejectS = Zmap.fold accRejectFrom xinfo.Defns rejectS rejectS //------------------------------------------------------------------------- @@ -173,7 +173,7 @@ let IsMandatoryNonTopLevel g (f:Val) = module Pass1_DetermineTLRAndArities = let GetMaxNumArgsAtUses xinfo f = - match MapCustom.tryFind f xinfo.Uses with + match Zmap.tryFind f xinfo.Uses with | None -> 0 (* no call sites *) | Some sites -> sites |> List.map (fun (_accessors,_tinst,args) -> List.length args) |> List.max @@ -196,17 +196,17 @@ module Pass1_DetermineTLRAndArities = /// ValRec considered: recursive && some f in mutual binding is not bound to a lambda let IsValueRecursionFree xinfo f = - let hasDelayedRepr f = isDelayedRepr f (MapCustom.force f xinfo.Defns ("IsValueRecursionFree - hasDelayedRepr",nameOfVal)) - let isRecursive,mudefs = MapCustom.force f xinfo.RecursiveBindings ("IsValueRecursionFree",nameOfVal) + let hasDelayedRepr f = isDelayedRepr f (Zmap.force f xinfo.Defns ("IsValueRecursionFree - hasDelayedRepr",nameOfVal)) + let isRecursive,mudefs = Zmap.force f xinfo.RecursiveBindings ("IsValueRecursionFree",nameOfVal) not isRecursive || List.forall hasDelayedRepr mudefs let DumpArity arityM = let dump f n = dprintf "tlr: arity %50s = %d\n" (showL (valL f)) n - MapCustom.iter dump arityM + Zmap.iter dump arityM let DetermineTLRAndArities g expr = let xinfo = GetUsageInfoOfImplFile g expr - let fArities = MapCustom.chooseL (SelectTLRVals g xinfo) xinfo.Defns + let fArities = Zmap.chooseL (SelectTLRVals g xinfo) xinfo.Defns let fArities = List.filter (fst >> IsValueRecursionFree xinfo) fArities // Do not TLR v if it is bound under a mustinline defn // There is simply no point - the original value will be duplicated and TLR'd anyway @@ -223,7 +223,7 @@ module Pass1_DetermineTLRAndArities = missed |> Zset.iter (fun v -> dprintf "TopLevel but not TLR = %s\n" v.LogicalName) #endif (* REPORT OVER *) - let arityM = MapCustom.ofList fArities + let arityM = Zmap.ofList fArities #if DEBUG if verboseTLR then DumpArity arityM #endif @@ -429,8 +429,8 @@ module Pass2_DetermineReqdItems = let state0 = { stack = [] - reqdItemsMap = MapCustom.Empty () - fclassM = MapCustom.Empty () + reqdItemsMap = Zmap.Empty () + fclassM = Zmap.Empty () revDeclist = [] recShortCallS = Zset.empty valOrder } @@ -454,8 +454,8 @@ module Pass2_DetermineReqdItems = | (fclass,_reqdVals0,env)::stack -> (* ASSERT: same fclass *) {state with stack = stack - reqdItemsMap = MapCustom.add fclass env state.reqdItemsMap - fclassM = List.fold (fun mp (k,v) -> MapCustom.add k v mp) state.fclassM fclass.Pairs } + reqdItemsMap = Zmap.add fclass env state.reqdItemsMap + fclassM = List.fold (fun mp (k,v) -> Zmap.add k v mp) state.fclassM fclass.Pairs } /// Log requirements for gv in the relevant stack frames let LogRequiredFrom gv items state = @@ -490,7 +490,7 @@ module Pass2_DetermineReqdItems = let ExprEnvIntercept (tlrS,arityM) exprF z expr = let accInstance z (fvref:ValRef,tps,args) (* f known local *) = let f = fvref.Deref - match MapCustom.tryFind f arityM with + match Zmap.tryFind f arityM with | Some wf -> // f is TLR with arity wf @@ -567,8 +567,8 @@ module Pass2_DetermineReqdItems = let closeStep reqdItemsMap changed fc (env: ReqdItemsForDefn) = let directCallReqdEnvs = env.ReqdSubEnvs let directCallReqdTypars = directCallReqdEnvs |> List.map (fun f -> - let fc = MapCustom.force f fclassM ("reqdTyparsFor",nameOfVal) - let env = MapCustom.force fc reqdItemsMap ("reqdTyparsFor",string) + let fc = Zmap.force f fclassM ("reqdTyparsFor",nameOfVal) + let env = Zmap.force fc reqdItemsMap ("reqdTyparsFor",string) env.reqdTypars) let reqdTypars0 = env.reqdTypars @@ -579,7 +579,7 @@ module Pass2_DetermineReqdItems = if verboseTLR then dprintf "closeStep: fc=%30A nSubs=%d reqdTypars0=%s reqdTypars=%s\n" fc directCallReqdEnvs.Length (showTyparSet reqdTypars0) (showTyparSet reqdTypars) directCallReqdEnvs |> List.iter (fun f -> dprintf "closeStep: dcall f=%s\n" f.LogicalName) - directCallReqdEnvs |> List.iter (fun f -> dprintf "closeStep: dcall fc=%A\n" (MapCustom.find f fclassM)) + directCallReqdEnvs |> List.iter (fun f -> dprintf "closeStep: dcall fc=%A\n" (Zmap.find f fclassM)) directCallReqdTypars |> List.iter (fun _reqdTypars -> dprintf "closeStep: dcall reqdTypars=%s\n" (showTyparSet reqdTypars0)) #else ignore fc @@ -588,7 +588,7 @@ module Pass2_DetermineReqdItems = let rec fixpoint reqdItemsMap = let changed = false - let changed,reqdItemsMap = MapCustom.foldMap (closeStep reqdItemsMap) changed reqdItemsMap + let changed,reqdItemsMap = Zmap.foldMap (closeStep reqdItemsMap) changed reqdItemsMap if changed then fixpoint reqdItemsMap else @@ -620,9 +620,9 @@ module Pass2_DetermineReqdItems = // close the reqdTypars under the subEnv reln let reqdItemsMap = CloseReqdTypars fclassM reqdItemsMap // filter out trivial fclass - with no TLR defns - let reqdItemsMap = MapCustom.remove (BindingGroupSharingSameReqdItems List.empty) reqdItemsMap + let reqdItemsMap = Zmap.remove (BindingGroupSharingSameReqdItems List.empty) reqdItemsMap // restrict declist to those with reqdItemsMap bindings (the non-trivial ones) - let declist = List.filter (MapCustom.memberOf reqdItemsMap) declist + let declist = List.filter (Zmap.memberOf reqdItemsMap) declist #if DEBUG // diagnostic dump if verboseTLR then @@ -687,14 +687,14 @@ exception AbortTLR of Range.range /// where /// aenvFor(v) = aenvi where (v,aenvi) in cmap. let FlatEnvPacks g fclassM topValS declist (reqdItemsMap: Map,ReqdItemsForDefn>) = - let fclassOf f = MapCustom.force f fclassM ("fclassM",nameOfVal) + let fclassOf f = Zmap.force f fclassM ("fclassM",nameOfVal) let packEnv carrierMaps (fc:BindingGroupSharingSameReqdItems) = if verboseTLR then dprintf "\ntlr: packEnv fc=%A\n" fc - let env = MapCustom.force fc reqdItemsMap ("packEnv",string) + let env = Zmap.force fc reqdItemsMap ("packEnv",string) // carrierMaps = (fclass,(v,aenv)map)map - let carrierMapFor f = MapCustom.force (fclassOf f) carrierMaps ("carrierMapFor",string) - let valsSubEnvFor f = MapCustom.keys (carrierMapFor f) + let carrierMapFor f = Zmap.force (fclassOf f) carrierMaps ("carrierMapFor",string) + let valsSubEnvFor f = Zmap.keys (carrierMapFor f) // determine vals(env) - transclosure let vals = env.ReqdVals @ List.collect valsSubEnvFor env.ReqdSubEnvs // list, with repeats @@ -744,25 +744,25 @@ let FlatEnvPacks g fclassM topValS declist (reqdItemsMap: Map List.map (fun v -> (v,(mkCompGenLocal env.m v.LogicalName v.Type |> fst))) - let cmap = MapCustom.ofList cmapPairs - let aenvFor v = MapCustom.force v cmap ("aenvFor",nameOfVal) + let cmap = Zmap.ofList cmapPairs + let aenvFor v = Zmap.force v cmap ("aenvFor",nameOfVal) let aenvExprFor v = exprForVal env.m (aenvFor v) // build PackedReqdItems let reqdTypars = env.reqdTypars - let aenvs = MapCustom.values cmap + let aenvs = Zmap.values cmap let pack = cmapPairs |> List.map (fun (v,aenv) -> mkInvisibleBind aenv (exprForVal env.m v)) let unpack = let unpackCarrier (v,aenv) = mkInvisibleBind (setValHasNoArity v) (exprForVal env.m aenv) let unpackSubenv f = let subCMap = carrierMapFor f - let vaenvs = MapCustom.toList subCMap + let vaenvs = Zmap.toList subCMap vaenvs |> List.map (fun (subv,subaenv) -> mkBind NoSequencePointAtInvisibleBinding subaenv (aenvExprFor subv)) - List.map unpackCarrier (MapCustom.toList cmap) @ + List.map unpackCarrier (Zmap.toList cmap) @ List.collect unpackSubenv env.ReqdSubEnvs // extend carrierMaps - let carrierMaps = MapCustom.add fc cmap carrierMaps + let carrierMaps = Zmap.add fc cmap carrierMaps // dump if verboseTLR then @@ -779,9 +779,9 @@ let FlatEnvPacks g fclassM topValS declist (reqdItemsMap: Map () + let carriedMaps = Zmap.Empty () let envPacks,_carriedMaps = List.mapFold packEnv carriedMaps declist (* List.mapFold in dec order *) - let envPacks = MapCustom.ofList envPacks + let envPacks = Zmap.ofList envPacks envPacks @@ -828,9 +828,9 @@ let MakeSimpleArityInfo tps n = ValReprInfo (ValReprInfo.InferTyparInfo tps,List let CreateNewValuesForTLR g tlrS arityM fclassM envPackM = if verboseTLR then dprintf "CreateNewValuesForTLR------\n" let createFHat (f:Val) = - let wf = MapCustom.force f arityM ("createFHat - wf",(fun v -> showL (valL v))) - let fc = MapCustom.force f fclassM ("createFHat - fc",nameOfVal) - let envp = MapCustom.force fc envPackM ("CreateNewValuesForTLR - envp",string) + let wf = Zmap.force f arityM ("createFHat - wf",(fun v -> showL (valL v))) + let fc = Zmap.force f fclassM ("createFHat - fc",nameOfVal) + let envp = Zmap.force fc envPackM ("CreateNewValuesForTLR - envp",string) let name = f.LogicalName (* + "_TLR_" + string wf *) let m = f.Range let tps,tau = f.TypeScheme @@ -847,7 +847,7 @@ let CreateNewValuesForTLR g tlrS arityM fclassM envPackM = let fs = Zset.elements tlrS let ffHats = List.map (fun f -> f,createFHat f) fs - let fHatM = MapCustom.ofList ffHats + let fHatM = Zmap.ofList ffHats fHatM @@ -969,14 +969,14 @@ module Pass4_RewriteAssembly = let TransTLRBindings penv (binds:Bindings) = if isNil binds then List.empty,List.empty else let fc = BindingGroupSharingSameReqdItems binds - let envp = MapCustom.force fc penv.envPackM ("TransTLRBindings",string) + let envp = Zmap.force fc penv.envPackM ("TransTLRBindings",string) let fRebinding (TBind(fOrig,b,letSeqPtOpt)) = let m = fOrig.Range let tps,vss,_b,rty = stripTopLambda (b,fOrig.Type) let aenvExprs = envp.ep_aenvs |> List.map (exprForVal m) let vsExprs = vss |> List.map (mkRefTupledVars penv.g m) - let fHat = MapCustom.force fOrig penv.fHatM ("fRebinding",nameOfVal) + let fHat = Zmap.force fOrig penv.fHatM ("fRebinding",nameOfVal) (* REVIEW: is this mutation really, really necessary? *) (* Why are we applying TLR if the thing already has an arity? *) let fOrig = setValHasNoArity fOrig @@ -989,8 +989,8 @@ module Pass4_RewriteAssembly = fBind let fHatNewBinding (shortRecBinds:Bindings) (TBind(f,b,letSeqPtOpt)) = - let wf = MapCustom.force f penv.arityM ("fHatNewBinding - arityM",nameOfVal) - let fHat = MapCustom.force f penv.fHatM ("fHatNewBinding - fHatM",nameOfVal) + let wf = Zmap.force f penv.arityM ("fHatNewBinding - arityM",nameOfVal) + let fHat = Zmap.force f penv.fHatM ("fHatNewBinding - fHatM",nameOfVal) // Take off the variables let tps,vss,b,rty = stripTopLambda (b,f.Type) // Don't take all the variables - only up to length wf @@ -1014,7 +1014,7 @@ module Pass4_RewriteAssembly = newBinds,rebinds let GetAEnvBindings penv fc = - match MapCustom.tryFind fc penv.envPackM with + match Zmap.tryFind fc penv.envPackM with | None -> List.empty // no env for this mutual binding | Some envp -> envp.ep_pack // environment pack bindings @@ -1052,14 +1052,14 @@ module Pass4_RewriteAssembly = match fx with | Expr.Val (fvref:ValRef,_,m) when (Zset.contains fvref.Deref penv.tlrS) && - (let wf = MapCustom.force fvref.Deref penv.arityM ("TransApp - wf",nameOfVal) + (let wf = Zmap.force fvref.Deref penv.arityM ("TransApp - wf",nameOfVal) IsArityMet fvref wf tys args) -> let f = fvref.Deref (* replace by direct call to corresponding fHat (and additional closure args) *) - let fc = MapCustom.force f penv.fclassM ("TransApp - fc",nameOfVal) - let envp = MapCustom.force fc penv.envPackM ("TransApp - envp",string) - let fHat = MapCustom.force f penv.fHatM ("TransApp - fHat",nameOfVal) + let fc = Zmap.force f penv.fclassM ("TransApp - fc",nameOfVal) + let envp = Zmap.force fc penv.envPackM ("TransApp - envp",string) + let fHat = Zmap.force f penv.fHatM ("TransApp - fHat",nameOfVal) let tys = (List.map mkTyparTy envp.ep_etps) @ tys let aenvExprs = List.map (exprForVal m) envp.ep_aenvs let args = aenvExprs @ args diff --git a/src/fsharp/NicePrint.fs b/src/fsharp/NicePrint.fs index 5755513dfde..e6c067fdc9d 100755 --- a/src/fsharp/NicePrint.fs +++ b/src/fsharp/NicePrint.fs @@ -762,7 +762,7 @@ module private PrintTypes = let varL = layoutTyparRef denv typar let varL = if denv.showAttributes then layoutTyparAttribs denv typar.Kind typar.Attribs varL else varL - match MapCustom.tryFind typar env.inplaceConstraints with + match Zmap.tryFind typar env.inplaceConstraints with | Some (typarConstraintTy) -> if Zset.contains typar env.singletons then leftL (tagPunctuation "#") ^^ layoutTypeWithInfo denv env typarConstraintTy diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index c9c820d095f..c45c9631792 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -2527,14 +2527,14 @@ module SimplifyTypes = | TType_measure _ -> z let incM x m = - if MapCustom.mem x m then MapCustom.add x (1 + MapCustom.find x m) m - else MapCustom.add x 1 m + if Zmap.mem x m then Zmap.add x (1 + Zmap.find x m) m + else Zmap.add x 1 m let accTyparCounts z ty = // Walk type to determine typars and their counts (for pprinting decisions) foldTypeButNotConstraints (fun z ty -> match ty with | TType_var tp when tp.Rigidity = TyparRigidity.Rigid -> incM tp z | _ -> z) z ty - let emptyTyparCounts = MapCustom.Empty () + let emptyTyparCounts = Zmap.Empty () // print multiple fragments of the same type using consistent naming and formatting let accTyparCountsMulti acc l = List.fold accTyparCounts acc l @@ -2546,11 +2546,11 @@ module SimplifyTypes = let typeSimplificationInfo0 = { singletons = Zset.empty typarOrder - inplaceConstraints = MapCustom.Empty () + inplaceConstraints = Zmap.Empty () postfixConstraints = [] } let categorizeConstraints simplify m cxs = - let singletons = if simplify then MapCustom.chooseL (fun tp n -> if n = 1 then Some tp else None) m else [] + let singletons = if simplify then Zmap.chooseL (fun tp n -> if n = 1 then Some tp else None) m else [] let singletons = Zset.addList singletons (Zset.empty typarOrder) // Here, singletons are typars that occur once in the type. // However, they may also occur in a type constraint. @@ -2568,7 +2568,7 @@ module SimplifyTypes = let inplace = inplace |> List.map (function (tp, TyparConstraint.CoercesTo(ty, _)) -> tp, ty | _ -> failwith "not isTTyparCoercesToType") { singletons = singletons - inplaceConstraints = MapCustom.ofList inplace + inplaceConstraints = Zmap.ofList inplace postfixConstraints = postfix } let CollectInfo simplify tys cxs = categorizeConstraints simplify (accTyparCountsMulti emptyTyparCounts tys) cxs @@ -3248,7 +3248,7 @@ module DebugPrint = begin + typar.DisplayName)) let varL = tpL |> stampL typar.Stamp - match MapCustom.tryFind typar env.inplaceConstraints with + match Zmap.tryFind typar env.inplaceConstraints with | Some (typarConstraintTy) -> if Zset.contains typar env.singletons then leftL (tagText "#") ^^ auxTyparConstraintTypL env typarConstraintTy diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index 62982a5cc6b..4b818b7f356 100755 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -12427,12 +12427,12 @@ module IncrClassChecking = static member Empty(g, names) = { TakenFieldNames=Set.ofList names RepInfoTcGlobals=g - ValReprs = MapCustom.Empty () + ValReprs = Zmap.Empty () ValsWithRepresentation = Zset.empty valOrder } /// Find the representation of a value member localRep.LookupRepr (v:Val) = - match MapCustom.tryFind v localRep.ValReprs with + match Zmap.tryFind v localRep.ValReprs with | None -> error(InternalError("LookupRepr: failed to find representation for value", v.Range)) | Some res -> res @@ -12545,7 +12545,7 @@ module IncrClassChecking = // OK, representation chosen, now add it {localRep with TakenFieldNames=takenFieldNames - ValReprs = MapCustom.add v repr localRep.ValReprs} + ValReprs = Zmap.add v repr localRep.ValReprs} member localRep.ValNowWithRepresentation (v:Val) = {localRep with ValsWithRepresentation = Zset.add v localRep.ValsWithRepresentation} diff --git a/src/utils/SortKey.fs b/src/utils/SortKey.fs index a2389b54c2d..e21535cbcd1 100644 --- a/src/utils/SortKey.fs +++ b/src/utils/SortKey.fs @@ -27,7 +27,7 @@ with [] -type MapCustom<'Key,'Value>() = +type Zmap<'Key,'Value>() = static member Empty<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct>() : Map,'Value> = Map.empty, 'Value> @@ -75,7 +75,7 @@ type MapCustom<'Key,'Value>() = static member foldMap<'Comparer, 'State, 'U when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (folder:'State->'Key->'Value->'State*'U) (initialState:'State) (initialMap:Map,'Value>) : 'State * Map,'U> = let f = OptimizedClosures.FSharpFunc<_,_,_,_>.Adapt folder let struct (finalState, finalMap) = - (initialMap, struct (initialState, MapCustom.Empty<'Comparer> ())) + (initialMap, struct (initialState, Zmap.Empty<'Comparer> ())) ||> Map.foldBack (fun {CompareObj=k} v struct (acc, m) -> let acc', v' = f.Invoke (acc, k, v) let m' = Map.add {CompareObj=k} v' m From 14b1214f1faa942a3b5275a07affbc2a0bd246fc Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sat, 11 Aug 2018 06:03:56 +1000 Subject: [PATCH 75/92] Type alias : zmap<...> = Map...> --- src/fsharp/CompileOps.fs | 4 +-- src/fsharp/DetupleArgs.fs | 14 +++++----- src/fsharp/InnerLambdasToTopLevelFuncs.fs | 22 +++++++-------- src/fsharp/TastOps.fs | 6 ++--- src/fsharp/TypeChecker.fs | 4 +-- src/utils/SortKey.fs | 33 ++++++++++++----------- 6 files changed, 42 insertions(+), 41 deletions(-) diff --git a/src/fsharp/CompileOps.fs b/src/fsharp/CompileOps.fs index 1669c8f103c..933d1b83520 100644 --- a/src/fsharp/CompileOps.fs +++ b/src/fsharp/CompileOps.fs @@ -5336,7 +5336,7 @@ type QualifiedNameOfFileByText = interface System.Collections.Generic.IComparer with member __.Compare(v1, v2) = qnameOrder.Compare (v1,v2) -type RootSigs = Map, ModuleOrNamespaceType> +type RootSigs = zmap type RootImpls = Zset type TcState = @@ -5408,7 +5408,7 @@ let GetInitialTcState(m, ccuName, tcConfig:TcConfig, tcGlobals, tcImports:TcImpo tcsTcSigEnv=tcEnv0 tcsTcImplEnv=tcEnv0 tcsCreatesGeneratedProvidedTypes=false - tcsRootSigs = Zmap.Empty () + tcsRootSigs = Zmap.empty () tcsRootImpls = Zset.empty qnameOrder tcsCcuSig = NewEmptyModuleOrNamespaceType Namespace } diff --git a/src/fsharp/DetupleArgs.fs b/src/fsharp/DetupleArgs.fs index 0e346fa5dc9..8358c0bcb7e 100644 --- a/src/fsharp/DetupleArgs.fs +++ b/src/fsharp/DetupleArgs.fs @@ -183,20 +183,20 @@ module GlobalUsageAnalysis = /// (b) log it's binding site representation. type Results = { /// v -> context / APP inst args - Uses : Map, (accessor list * TType list * Expr list) list> + Uses : zmap /// v -> binding repr - Defns : Map, Expr> + Defns : zmap /// bound in a decision tree? DecisionTreeBindings : Zset /// v -> v list * recursive? -- the others in the mutual binding - RecursiveBindings : Map, bool * Vals> + RecursiveBindings : zmap TopLevelBindings : Zset IterationIsAtTopLevel : bool } let z0 = - { Uses = Zmap.Empty () - Defns = Zmap.Empty () - RecursiveBindings = Zmap.Empty () + { Uses = Zmap.empty () + Defns = Zmap.empty () + RecursiveBindings = Zmap.empty () DecisionTreeBindings = Zset.empty valOrder TopLevelBindings = Zset.empty valOrder IterationIsAtTopLevel = true } @@ -624,7 +624,7 @@ let determineTransforms g (z : GlobalUsageAnalysis.Results) = type penv = { // The planned transforms - transforms : Map, Transform> + transforms : zmap ccu : CcuThunk g : TcGlobals } diff --git a/src/fsharp/InnerLambdasToTopLevelFuncs.fs b/src/fsharp/InnerLambdasToTopLevelFuncs.fs index 09a33e98e66..e52ead8e3eb 100644 --- a/src/fsharp/InnerLambdasToTopLevelFuncs.fs +++ b/src/fsharp/InnerLambdasToTopLevelFuncs.fs @@ -26,7 +26,7 @@ let verboseTLR = false let internalError str = dprintf "Error: %s\n" str;raise (Failure str) module Zmap = - let force (k:'Key) (mp:Map,'T>) (str,soK) = + let force (k:'Key) (mp:zmap<'Key,'Comparer,'T>) (str,soK) = try Zmap.find k mp with e -> dprintf "Map.force: %s %s\n" str (soK k); @@ -421,16 +421,16 @@ module Pass2_DetermineReqdItems = /// recShortCalls to f will require a binding for f in terms of fHat within the fHatBody. type state = { stack : (BindingGroupSharingSameReqdItems * Generators * ReqdItemsForDefn) list - reqdItemsMap : Map,ReqdItemsForDefn> - fclassM : Map,BindingGroupSharingSameReqdItems> + reqdItemsMap : zmap + fclassM : zmap revDeclist : BindingGroupSharingSameReqdItems list recShortCallS : Zset } let state0 = { stack = [] - reqdItemsMap = Zmap.Empty () - fclassM = Zmap.Empty () + reqdItemsMap = Zmap.empty () + fclassM = Zmap.empty () revDeclist = [] recShortCallS = Zset.empty valOrder } @@ -686,7 +686,7 @@ exception AbortTLR of Range.range /// and TBIND(asubEnvi = aenvFor(v)) for each (asubEnvi,v) in cmap(subEnvk) ranging over required subEnvk. /// where /// aenvFor(v) = aenvi where (v,aenvi) in cmap. -let FlatEnvPacks g fclassM topValS declist (reqdItemsMap: Map,ReqdItemsForDefn>) = +let FlatEnvPacks g fclassM topValS declist (reqdItemsMap: zmap) = let fclassOf f = Zmap.force f fclassM ("fclassM",nameOfVal) let packEnv carrierMaps (fc:BindingGroupSharingSameReqdItems) = if verboseTLR then dprintf "\ntlr: packEnv fc=%A\n" fc @@ -779,7 +779,7 @@ let FlatEnvPacks g fclassM topValS declist (reqdItemsMap: Map () + let carriedMaps = Zmap.empty () let envPacks,_carriedMaps = List.mapFold packEnv carriedMaps declist (* List.mapFold in dec order *) let envPacks = Zmap.ofList envPacks envPacks @@ -862,12 +862,12 @@ module Pass4_RewriteAssembly = g : TcGlobals tlrS : Zset topValS : Zset - arityM : Map,int> - fclassM : Map,BindingGroupSharingSameReqdItems> + arityM : zmap + fclassM : zmap recShortCallS : Zset - envPackM : Map,PackedReqdItems> + envPackM : zmap /// The mapping from 'f' values to 'fHat' values - fHatM : Map,Val> + fHatM : zmap } diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index c45c9631792..e7b46412afe 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -2534,19 +2534,19 @@ module SimplifyTypes = // Walk type to determine typars and their counts (for pprinting decisions) foldTypeButNotConstraints (fun z ty -> match ty with | TType_var tp when tp.Rigidity = TyparRigidity.Rigid -> incM tp z | _ -> z) z ty - let emptyTyparCounts = Zmap.Empty () + let emptyTyparCounts = Zmap.empty () // print multiple fragments of the same type using consistent naming and formatting let accTyparCountsMulti acc l = List.fold accTyparCounts acc l type TypeSimplificationInfo = { singletons : Typar Zset - inplaceConstraints : Map, TType> + inplaceConstraints : zmap postfixConstraints : (Typar * TyparConstraint) list } let typeSimplificationInfo0 = { singletons = Zset.empty typarOrder - inplaceConstraints = Zmap.Empty () + inplaceConstraints = Zmap.empty () postfixConstraints = [] } let categorizeConstraints simplify m cxs = diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index 4b818b7f356..046c1763c4a 100755 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -12420,14 +12420,14 @@ module IncrClassChecking = TakenFieldNames:Set RepInfoTcGlobals:TcGlobals /// vals mapped to representations - ValReprs : Map, IncrClassValRepr> + ValReprs : zmap /// vals represented as fields or members from this point on ValsWithRepresentation : Zset } static member Empty(g, names) = { TakenFieldNames=Set.ofList names RepInfoTcGlobals=g - ValReprs = Zmap.Empty () + ValReprs = Zmap.empty () ValsWithRepresentation = Zset.empty valOrder } /// Find the representation of a value diff --git a/src/utils/SortKey.fs b/src/utils/SortKey.fs index e21535cbcd1..7072b9f8024 100644 --- a/src/utils/SortKey.fs +++ b/src/utils/SortKey.fs @@ -25,57 +25,58 @@ with Unchecked.defaultof<'Comparer>.Compare(lhs.CompareObj, (rhs:?>SortKey<'Key,'Comparer>).CompareObj) #endif +type zmap<'Key,'Comparer,'Value when 'Comparer :> IComparer<'Key> and 'Comparer : struct> = Map,'Value> [] type Zmap<'Key,'Value>() = - static member Empty<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct>() : Map,'Value> = + static member empty<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct>() : zmap<'Key,'Comparer,'Value> = Map.empty, 'Value> - static member ofList<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> lst : Map,'Value> = + static member ofList<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> lst : zmap<'Key,'Comparer,'Value> = lst |> List.map (fun (k,v) -> {CompareObj=k},v) |> Map.ofList - static member inline chooseL<'Comparer, 'U when 'Comparer :> IComparer<'Key> and 'Comparer : struct> f (m:Map,'Value>) = + static member inline chooseL<'Comparer, 'U when 'Comparer :> IComparer<'Key> and 'Comparer : struct> f (m:zmap<'Key,'Comparer,'Value>) = Map.foldBack (fun k v (s:list<'U>) -> match f k.CompareObj v with None -> s | Some x -> x::s) m [] - static member inline tryFind<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (k:'Key) (m:Map,'Value>) = + static member inline tryFind<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (k:'Key) (m:zmap<'Key,'Comparer,'Value>) = Map.tryFind {CompareObj=k} m - static member inline mem<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (k:'Key) (m:Map,'Value>) = + static member inline mem<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (k:'Key) (m:zmap<'Key,'Comparer,'Value>) = Map.containsKey {CompareObj=k} m - static member inline memberOf<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (m:Map,'Value>) (k:'Key) = + static member inline memberOf<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (m:zmap<'Key,'Comparer,'Value>) (k:'Key) = Map.containsKey {CompareObj=k} m - static member inline add<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (k:'Key) (v:'Value) (m:Map,'Value>) = + static member inline add<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (k:'Key) (v:'Value) (m:zmap<'Key,'Comparer,'Value>) = Map.add {CompareObj=k} v m - static member inline find<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (k:'Key) (m:Map,'Value>) = + static member inline find<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (k:'Key) (m:zmap<'Key,'Comparer,'Value>) = Map.find {CompareObj=k} m - static member inline fold<'Comparer, 'State when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (folder:'Key->'Value->'State->'State) (m:Map,'Value>) (state:'State) : 'State = + static member inline fold<'Comparer, 'State when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (folder:'Key->'Value->'State->'State) (m:zmap<'Key,'Comparer,'Value>) (state:'State) : 'State = Map.foldBack (fun {CompareObj=k} t s -> folder k t s) m state - static member inline remove<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (k:'Key) (m:Map,'Value>) = + static member inline remove<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (k:'Key) (m:zmap<'Key,'Comparer,'Value>) = Map.remove {CompareObj=k} m - static member inline keys<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (m:Map,'Value>) = + static member inline keys<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (m:zmap<'Key,'Comparer,'Value>) = Map.foldBack (fun {CompareObj=k} _ s -> k::s) m [] - static member inline values<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (m:Map,'Value>) = + static member inline values<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (m:zmap<'Key,'Comparer,'Value>) = Map.foldBack (fun _ v s -> v::s) m [] - static member inline toList<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (m:Map,'Value>) = + static member inline toList<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (m:zmap<'Key,'Comparer,'Value>) = Map.foldBack (fun {CompareObj=k} v acc -> (k,v) :: acc) m [] - static member inline iter<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (f:'Key->'Value->unit) (m:Map,'Value>) = + static member inline iter<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (f:'Key->'Value->unit) (m:zmap<'Key,'Comparer,'Value>) = Map.iter (fun {CompareObj=k} v -> f k v) m - static member foldMap<'Comparer, 'State, 'U when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (folder:'State->'Key->'Value->'State*'U) (initialState:'State) (initialMap:Map,'Value>) : 'State * Map,'U> = + static member foldMap<'Comparer, 'State, 'U when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (folder:'State->'Key->'Value->'State*'U) (initialState:'State) (initialMap:zmap<'Key,'Comparer,'Value>) : 'State * zmap<'Key,'Comparer,'U> = let f = OptimizedClosures.FSharpFunc<_,_,_,_>.Adapt folder let struct (finalState, finalMap) = - (initialMap, struct (initialState, Zmap.Empty<'Comparer> ())) + (initialMap, struct (initialState, Zmap.empty<'Comparer> ())) ||> Map.foldBack (fun {CompareObj=k} v struct (acc, m) -> let acc', v' = f.Invoke (acc, k, v) let m' = Map.add {CompareObj=k} v' m From 210bc9fdc2647d54f0ac734319c07d63c1ce154b Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sat, 11 Aug 2018 08:59:53 +1000 Subject: [PATCH 76/92] Created SetCustom to remove Zset --- src/fsharp/IlxGen.fs | 2 +- src/fsharp/InnerLambdasToTopLevelFuncs.fs | 2 +- src/fsharp/LowerCallsAndSeqs.fs | 3 +- src/fsharp/Optimizer.fs | 15 +++++----- src/fsharp/PostInferenceChecks.fs | 5 ++-- src/fsharp/QuotationTranslator.fs | 2 +- src/fsharp/TastOps.fs | 28 ++++++++----------- src/fsharp/TastOps.fsi | 1 - src/fsharp/TypeChecker.fs | 6 ++-- src/fsharp/autobox.fs | 11 +++++--- src/fsharp/tast.fs | 2 +- src/utils/SortKey.fs | 34 +++++++++++++++++++++++ 12 files changed, 73 insertions(+), 38 deletions(-) diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index 75674b4ef99..5c575d8a51b 100644 --- a/src/fsharp/IlxGen.fs +++ b/src/fsharp/IlxGen.fs @@ -3903,7 +3903,7 @@ and GetIlxClosureFreeVars cenv m selfv eenvouter takenNames expr = // pointer which gives the current closure itself. This is in the case e.g. let rec f = ... f ... let cloFreeVars = cloFreeVarResults.FreeLocals - |> Zset.elements + |> SetCustom.elements |> List.filter (fun fv -> match StorageForVal m fv eenvouter with | (StaticField _ | StaticProperty _ | Method _ | Null) -> false diff --git a/src/fsharp/InnerLambdasToTopLevelFuncs.fs b/src/fsharp/InnerLambdasToTopLevelFuncs.fs index e52ead8e3eb..30320abd2e3 100644 --- a/src/fsharp/InnerLambdasToTopLevelFuncs.fs +++ b/src/fsharp/InnerLambdasToTopLevelFuncs.fs @@ -516,7 +516,7 @@ module Pass2_DetermineReqdItems = let frees = FreeInBindings tlrBs let reqdTypars0 = frees.FreeTyvars.FreeTypars |> Zset.elements (* put in env *) // occurrences contribute to env - let reqdVals0 = frees.FreeLocals |> Zset.elements + let reqdVals0 = frees.FreeLocals |> SetCustom.elements // tlrBs are not reqdVals0 for themselves let reqdVals0 = reqdVals0 |> List.filter (fun gv -> not (fclass.Contains gv)) let reqdVals0 = reqdVals0 |> Zset.ofList valOrder diff --git a/src/fsharp/LowerCallsAndSeqs.fs b/src/fsharp/LowerCallsAndSeqs.fs index 6fc9b6065e6..ae963e4a8b6 100644 --- a/src/fsharp/LowerCallsAndSeqs.fs +++ b/src/fsharp/LowerCallsAndSeqs.fs @@ -17,6 +17,7 @@ open Microsoft.FSharp.Compiler.Lib open Microsoft.FSharp.Compiler.TcGlobals open Microsoft.FSharp.Compiler.InfoReader open Microsoft.FSharp.Compiler.MethodCalls +open Internal.Utilities.Collections //---------------------------------------------------------------------------- // Eta-expansion of calls to top-level-methods @@ -92,7 +93,7 @@ type LoweredSeqFirstPhaseResult = /// The state variables allocated for one portion of the sequence expression (i.e. the local let-bound variables which become state variables) stateVars: ValRef list } -let isVarFreeInExpr v e = Zset.contains v (freeInExpr CollectTyparsAndLocals e).FreeLocals +let isVarFreeInExpr v e = SetCustom.contains v (freeInExpr CollectTyparsAndLocals e).FreeLocals /// Analyze a TAST expression to detect the elaborated form of a sequence expression. /// Then compile it to a state machine represented as a TAST containing goto, return and label nodes. diff --git a/src/fsharp/Optimizer.fs b/src/fsharp/Optimizer.fs index d5bdf9a282d..d853458a3a3 100644 --- a/src/fsharp/Optimizer.fs +++ b/src/fsharp/Optimizer.fs @@ -32,6 +32,7 @@ open Microsoft.FSharp.Compiler.Layout.TaggedTextOps open Microsoft.FSharp.Compiler.TypeRelations open System.Collections.Generic +open Internal.Utilities.Collections #if DEBUG let verboseOptimizationInfo = @@ -996,7 +997,7 @@ let AbstractLazyModulInfoByHiding isAssemblyBoundary mhi = | CurriedLambdaValue (_, _, _, expr, _) | ConstExprValue(_, expr) when (let fvs = freeInExpr CollectAll expr (isAssemblyBoundary && not (freeVarsAllPublic fvs)) || - Zset.exists hiddenVal fvs.FreeLocals || + SetCustom.exists hiddenVal fvs.FreeLocals || Zset.exists hiddenTycon fvs.FreeTyvars.FreeTycons || Zset.exists hiddenTyconRepr fvs.FreeLocalTyconReprs || Zset.exists hiddenRecdField fvs.FreeRecdFields || @@ -1082,7 +1083,7 @@ let AbstractExprInfoByVars (boundVars:Val list, boundTyVars) ivalue = // Check for escape in lambda | CurriedLambdaValue (_, _, _, expr, _) | ConstExprValue(_, expr) when (let fvs = freeInExpr (if isNil boundTyVars then CollectLocals else CollectTyparsAndLocals) expr - (not (isNil boundVars) && List.exists (Zset.memberOf fvs.FreeLocals) boundVars) || + (not (isNil boundVars) && List.exists (SetCustom.memberOf fvs.FreeLocals) boundVars) || (not (isNil boundTyVars) && List.exists (Zset.memberOf fvs.FreeTyvars.FreeTypars) boundTyVars) || (fvs.UsesMethodLocalConstructs )) -> @@ -1208,7 +1209,7 @@ let ValueIsUsedOrHasEffect cenv fvs (b:Binding, binfo) = Option.isSome v.MemberInfo || binfo.HasEffect || v.IsFixed || - Zset.contains v (fvs()) + SetCustom.contains v (fvs()) let rec SplitValuesByIsUsedOrHasEffect cenv fvs x = x |> List.filter (ValueIsUsedOrHasEffect cenv fvs) |> List.unzip @@ -1310,7 +1311,7 @@ let TryEliminateBinding cenv _env (TBind(vspec1, e1, spBind)) e2 _m = && (not (vspec2.LogicalName.Contains(suffixForVariablesThatMayNotBeEliminated))) // REVIEW: this looks slow. Look only for one variable instead && (let fvs = accFreeInExprs CollectLocals args emptyFreeVars - not (Zset.contains vspec1 fvs.FreeLocals)) + not (SetCustom.contains vspec1 fvs.FreeLocals)) // Immediate consumption of value as 2nd or subsequent argument to a construction or projection operation let rec GetImmediateUseContext rargsl argsr = @@ -1331,7 +1332,7 @@ let TryEliminateBinding cenv _env (TBind(vspec1, e1, spBind)) e2 _m = | Expr.Match(spMatch, _exprm, TDSwitch(Expr.Val(VRefLocal vspec2, _, _), cases, dflt, _), targets, m, ty2) when (valEq vspec1 vspec2 && let fvs = accFreeInTargets CollectLocals targets (accFreeInSwitchCases CollectLocals cases dflt emptyFreeVars) - not (Zset.contains vspec1 fvs.FreeLocals)) -> + not (SetCustom.contains vspec1 fvs.FreeLocals)) -> let spMatch = spBind.Combine(spMatch) Some (Expr.Match(spMatch, e1.Range, TDSwitch(e1, cases, dflt, m), targets, m, ty2)) @@ -2728,7 +2729,7 @@ and OptimizeLambdas (vspec: Val option) cenv env topValInfo e ety = | None -> CurriedLambdaValue (lambdaId, arities, bsize, expr', ety) | Some baseVal -> let fvs = freeInExpr CollectLocals body' - if fvs.UsesMethodLocalConstructs || fvs.FreeLocals.Contains baseVal then + if fvs.UsesMethodLocalConstructs || (fvs.FreeLocals |> SetCustom.contains baseVal) then UnknownValue else let expr2 = mkMemberLambdas m tps ctorThisValOpt None vsl (body', bodyty) @@ -2804,7 +2805,7 @@ and ComputeSplitToMethodCondition flag threshold cenv env (e:Expr, einfo) = (let fvs = freeInExpr CollectLocals e not fvs.UsesUnboundRethrow && not fvs.UsesMethodLocalConstructs && - fvs.FreeLocals |> Zset.forall (fun v -> + fvs.FreeLocals |> SetCustom.forall (fun v -> // no direct-self-recursive references not (env.dontSplitVars.ContainsVal v) && (v.ValReprInfo.IsSome || diff --git a/src/fsharp/PostInferenceChecks.fs b/src/fsharp/PostInferenceChecks.fs index 55fca9c2102..3819310be7f 100644 --- a/src/fsharp/PostInferenceChecks.fs +++ b/src/fsharp/PostInferenceChecks.fs @@ -24,6 +24,7 @@ open Microsoft.FSharp.Compiler.Infos open Microsoft.FSharp.Compiler.PrettyNaming open Microsoft.FSharp.Compiler.InfoReader open Microsoft.FSharp.Compiler.TypeRelations +open Internal.Utilities.Collections //-------------------------------------------------------------------------- // TestHooks - for dumping range to support source transforms @@ -407,8 +408,8 @@ let CheckEscapes cenv allowProtected m syntacticArgs body = (* m is a range suit if not allowProtected && frees.UsesMethodLocalConstructs then errorR(Error(FSComp.SR.chkProtectedOrBaseCalled(), m)) - elif Zset.exists cantBeFree fvs then - let v = List.find cantBeFree (Zset.elements fvs) + elif SetCustom.exists cantBeFree fvs then + let v = List.find cantBeFree (SetCustom.elements fvs) // byref error before mutable error (byrefs are mutable...). if (isByrefLikeTy cenv.g m v.Type) then diff --git a/src/fsharp/QuotationTranslator.fs b/src/fsharp/QuotationTranslator.fs index 9c7bc53e333..d02865def5e 100644 --- a/src/fsharp/QuotationTranslator.fs +++ b/src/fsharp/QuotationTranslator.fs @@ -219,7 +219,7 @@ and private ConvExprCore cenv (env : QuotationTranslationEnv) (expr: Expr) : QP. let idx = cenv.exprSplices.Count let ty = tyOfExpr cenv.g expr - match (freeInExpr CollectTyparsAndLocalsNoCaching x0).FreeLocals |> Seq.tryPick (fun v -> if env.vs.ContainsVal v then Some v else None) with + match (freeInExpr CollectTyparsAndLocalsNoCaching x0).FreeLocals |> Seq.tryPick (fun {CompareObj=v} -> if env.vs.ContainsVal v then Some v else None) with | Some v -> errorR(Error(FSComp.SR.crefBoundVarUsedInSplice(v.DisplayName), v.Range)) | None -> () diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index e7b46412afe..a2565848d61 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -1835,11 +1835,7 @@ let ValRefIsExplicitImpl g (vref:ValRef) = ValIsExplicitImpl g vref.Deref // an equation assigned by type inference. //--------------------------------------------------------------------------- -let emptyFreeLocals = Zset.empty valOrder -let unionFreeLocals s1 s2 = - if s1 === emptyFreeLocals then s2 - elif s2 === emptyFreeLocals then s1 - else Zset.union s1 s2 +let emptyFreeLocals = SetCustom.empty () let emptyFreeRecdFields = Zset.empty recdFieldRefOrder let unionFreeRecdFields s1 s2 = @@ -1883,7 +1879,7 @@ let unionFreeTyvars fvs1 fvs2 = if fvs1 === emptyFreeTyvars then fvs2 else if fvs2 === emptyFreeTyvars then fvs1 else { FreeTycons = unionFreeTycons fvs1.FreeTycons fvs2.FreeTycons - FreeTraitSolutions = unionFreeLocals fvs1.FreeTraitSolutions fvs2.FreeTraitSolutions + FreeTraitSolutions = Set.union fvs1.FreeTraitSolutions fvs2.FreeTraitSolutions FreeTypars = unionFreeTypars fvs1.FreeTypars fvs2.FreeTypars } type FreeVarOptions = @@ -2018,8 +2014,8 @@ and accFreeInTraitSln opts sln acc = | ClosedExprSln _ -> acc // nothing to accumulate because it's a closed expression referring only to erasure of provided method calls and accFreeLocalValInTraitSln _opts v fvs = - if Zset.contains v fvs.FreeTraitSolutions then fvs - else { fvs with FreeTraitSolutions = Zset.add v fvs.FreeTraitSolutions} + if SetCustom.contains v fvs.FreeTraitSolutions then fvs + else { fvs with FreeTraitSolutions = SetCustom.add v fvs.FreeTraitSolutions} and accFreeValRefInTraitSln opts (vref:ValRef) fvs = if vref.IsLocalRef then @@ -4123,7 +4119,7 @@ let freeVarsAllPublic fvs = // // CODEREVIEW: // What about non-local vals. This fix assumes non-local vals must be public. OK? - Zset.forall isPublicVal fvs.FreeLocals && + SetCustom.forall isPublicVal fvs.FreeLocals && Zset.forall isPublicUnionCase fvs.FreeUnionCases && Zset.forall isPublicRecdField fvs.FreeRecdFields && Zset.forall isPublicTycon fvs.FreeTyvars.FreeTycons @@ -4161,7 +4157,7 @@ let emptyFreeVars = let unionFreeVars fvs1 fvs2 = if fvs1 === emptyFreeVars then fvs2 else if fvs2 === emptyFreeVars then fvs1 else - { FreeLocals = unionFreeLocals fvs1.FreeLocals fvs2.FreeLocals; + { FreeLocals = Set.union fvs1.FreeLocals fvs2.FreeLocals; FreeTyvars = unionFreeTyvars fvs1.FreeTyvars fvs2.FreeTyvars; UsesMethodLocalConstructs = fvs1.UsesMethodLocalConstructs || fvs2.UsesMethodLocalConstructs; UsesUnboundRethrow = fvs1.UsesUnboundRethrow || fvs2.UsesUnboundRethrow; @@ -4186,8 +4182,8 @@ let accFreeVarsInTraitSln opts tys acc = accFreeTyvars opts accFreeInTraitSln ty let boundLocalVal opts v fvs = if not opts.includeLocals then fvs else let fvs = accFreevarsInVal opts v fvs - if not (Zset.contains v fvs.FreeLocals) then fvs - else {fvs with FreeLocals= Zset.remove v fvs.FreeLocals} + if not (SetCustom.contains v fvs.FreeLocals) then fvs + else {fvs with FreeLocals= SetCustom.remove v fvs.FreeLocals} let boundProtect fvs = if fvs.UsesMethodLocalConstructs then {fvs with UsesMethodLocalConstructs = false} else fvs @@ -4250,10 +4246,10 @@ and accFreeInValFlags opts flag acc = and accFreeLocalVal opts v fvs = if not opts.includeLocals then fvs else - if Zset.contains v fvs.FreeLocals then fvs + if SetCustom.contains v fvs.FreeLocals then fvs else let fvs = accFreevarsInVal opts v fvs - {fvs with FreeLocals=Zset.add v fvs.FreeLocals} + {fvs with FreeLocals=SetCustom.add v fvs.FreeLocals} and accLocalTyconRepr opts b fvs = if not opts.includeLocalTyconReprs then fvs else @@ -8349,8 +8345,8 @@ let (|CompiledForEachExpr|_|) g expr = enumerableVar.IsCompilerGenerated && enumeratorVar.IsCompilerGenerated && (let fvs = (freeInExpr CollectLocals bodyExpr) - not (Zset.contains enumerableVar fvs.FreeLocals) && - not (Zset.contains enumeratorVar fvs.FreeLocals)) -> + not (SetCustom.contains enumerableVar fvs.FreeLocals) && + not (SetCustom.contains enumeratorVar fvs.FreeLocals)) -> // Extract useful ranges let mEnumExpr = enumerableExpr.Range diff --git a/src/fsharp/TastOps.fsi b/src/fsharp/TastOps.fsi index e5c9a643d02..65580230a82 100755 --- a/src/fsharp/TastOps.fsi +++ b/src/fsharp/TastOps.fsi @@ -569,7 +569,6 @@ val isEmptyFreeTyvars : FreeTyvars -> bool val unionFreeTyvars : FreeTyvars -> FreeTyvars -> FreeTyvars val emptyFreeLocals : FreeLocals -val unionFreeLocals : FreeLocals -> FreeLocals -> FreeLocals type FreeVarOptions diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index 046c1763c4a..67f9ff60eaa 100755 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -2082,7 +2082,7 @@ module GeneralizationHelpers = if item.WillNeverHaveFreeTypars then item.CachedFreeTraitSolutions else let ftyvs = item.GetFreeTyvars() ftyvs.FreeTraitSolutions - if ftycs.IsEmpty then acc else unionFreeLocals ftycs acc + if ftycs.IsEmpty then acc else Set.union ftycs acc List.fold acc_in_free_item emptyFreeLocals env.eUngeneralizableItems @@ -12491,7 +12491,7 @@ module IncrClassChecking = // All struct variables are forced into fields. Structs may not contain "let" bindings, so no new variables can be // introduced. - if v.IsMutable || relevantForcedFieldVars.Contains v || tcref.IsStructOrEnumTycon then + if v.IsMutable || (relevantForcedFieldVars |> SetCustom.contains v) || tcref.IsStructOrEnumTycon then //dprintfn "Representing %s as a field %s" v.LogicalName name let rfref = RFRef(tcref, name) reportIfUnused() @@ -16697,7 +16697,7 @@ let TcMutRecDefnsEscapeCheck (binds: MutRecShapes<_, _, _, _, _>) env = let freeInEnv = GeneralizationHelpers.ComputeUnabstractableTraitSolutions env let checkBinds (binds: Binding list) = for bind in binds do - if Zset.contains bind.Var freeInEnv then + if SetCustom.contains bind.Var freeInEnv then let nm = bind.Var.DisplayName errorR(Error(FSComp.SR.tcMemberUsedInInvalidWay(nm, nm, nm), bind.Var.Range)) diff --git a/src/fsharp/autobox.fs b/src/fsharp/autobox.fs index 4c929e006ce..04577a00793 100644 --- a/src/fsharp/autobox.fs +++ b/src/fsharp/autobox.fs @@ -10,6 +10,7 @@ open Microsoft.FSharp.Compiler.Tastops open Microsoft.FSharp.Compiler.Lib open Microsoft.FSharp.Compiler.TcGlobals open Microsoft.FSharp.Compiler.TypeRelations +open Internal.Utilities.Collections //---------------------------------------------------------------------------- // Decide the set of mutable locals to promote to heap-allocated reference cells @@ -25,7 +26,7 @@ let DecideEscapes syntacticArgs body = not passedIn && (v.IsMutable && v.ValReprInfo.IsNone) let frees = freeInExpr CollectLocals body - frees.FreeLocals |> Zset.filter cantBeFree + frees.FreeLocals |> SetCustom.filter cantBeFree /// Find all the mutable locals that escape a lambda expression, ignoring the arguments to the lambda let DecideLambda exprF cenv topValInfo expr ety z = @@ -38,7 +39,7 @@ let DecideLambda exprF cenv topValInfo expr ety z = let args = Option.fold snoc args baseValOpt let syntacticArgs = Option.fold snoc args ctorThisValOpt - let z = Zset.union z (DecideEscapes syntacticArgs body) + let z = SetCustom.union z (DecideEscapes syntacticArgs body) let z = match exprF with Some f -> f z body | None -> z z | _ -> z @@ -84,7 +85,7 @@ let DecideExpr cenv exprF z expr = let CheckMethod z (TObjExprMethod(_, _attribs, _tps, vs, body, _m)) = let vs = List.concat vs let syntacticArgs = (match baseValOpt with Some x -> x:: vs | None -> vs) - let z = Zset.union z (DecideEscapes syntacticArgs body) + let z = Set.union z (DecideEscapes syntacticArgs body) exprF z body let CheckMethods z l = (z, l) ||> List.fold CheckMethod @@ -167,14 +168,16 @@ let TransformBinding g (nvs: ValMap<_>) exprF (TBind(v, expr, m)) = /// Rewrite mutable locals to reference cells across an entire implementation file let TransformImplFile g amap implFile = let fvs = DecideImplFile g amap implFile - if Zset.isEmpty fvs then + if Set.isEmpty fvs then implFile else for fv in fvs do + let fv = fv.CompareObj warning (Error(FSComp.SR.abImplicitHeapAllocation(fv.DisplayName), fv.Range)) let nvs = [ for fv in fvs do + let fv = fv.CompareObj let nty = mkRefCellTy g fv.Type let nv, nve = if fv.IsCompilerGenerated then mkCompGenLocal fv.Range fv.LogicalName nty diff --git a/src/fsharp/tast.fs b/src/fsharp/tast.fs index 184fe0f2edb..e266f9dee17 100644 --- a/src/fsharp/tast.fs +++ b/src/fsharp/tast.fs @@ -4970,7 +4970,7 @@ and //--------------------------------------------------------------------------- /// Represents a set of free local values. -and FreeLocals = Zset +and FreeLocals = Internal.Utilities.Collections.zset /// Represents a set of free type parameters and FreeTypars = Zset diff --git a/src/utils/SortKey.fs b/src/utils/SortKey.fs index 7072b9f8024..b65a8f7258c 100644 --- a/src/utils/SortKey.fs +++ b/src/utils/SortKey.fs @@ -83,3 +83,37 @@ type Zmap<'Key,'Value>() = struct (acc', m')) finalState, finalMap +type zset<'Key,'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> = Set> + +[] +type SetCustom<'Key>() = + static member empty<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct>() : zset<'Key,'Comparer> = + Set.empty> + + static member inline contains<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (k:'Key) (s:zset<'Key,'Comparer>) = + Set.contains {CompareObj=k} s + + static member inline exists<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (f:'Key->bool) (s:zset<'Key,'Comparer>) = + Set.exists (fun {CompareObj=k} -> f k) s + + static member inline add<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (k:'Key) (s:zset<'Key,'Comparer>) = + Set.add {CompareObj=k} s + + static member inline remove<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (k:'Key) (s:zset<'Key,'Comparer>) = + Set.remove {CompareObj=k} s + + static member inline forall<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (f:'Key->bool) (s:zset<'Key,'Comparer>) = + Set.forall (fun {CompareObj=k} -> f k) s + + static member inline memberOf<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (s:zset<'Key,'Comparer>) (k:'Key) = + Set.contains {CompareObj=k} s + + static member inline elements<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (s:zset<'Key,'Comparer>) = + Set.foldBack (fun e l -> e.CompareObj::l) s [] + + static member inline filter<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (f:'Key->bool) (s:zset<'Key,'Comparer>) = + Set.filter (fun {CompareObj=k} -> f k) s + + static member inline union<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (set1:zset<'Key,'Comparer>) (set2:zset<'Key,'Comparer>) = + Set.union set1 set2 + From 36a134678ee057f5ea65683b101bf05bb2bcf340 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sat, 11 Aug 2018 12:14:57 +1000 Subject: [PATCH 77/92] mhiVals to SetCustom --- src/fsharp/Optimizer.fs | 4 ++-- src/fsharp/TastOps.fs | 27 ++++++++++++++++++++++----- src/fsharp/TastOps.fsi | 2 +- 3 files changed, 25 insertions(+), 8 deletions(-) diff --git a/src/fsharp/Optimizer.fs b/src/fsharp/Optimizer.fs index d853458a3a3..312ace8165a 100644 --- a/src/fsharp/Optimizer.fs +++ b/src/fsharp/Optimizer.fs @@ -976,7 +976,7 @@ let AbstractLazyModulInfoByHiding isAssemblyBoundary mhi = let hiddenTycon, hiddenTyconRepr, hiddenVal, hiddenRecdField, hiddenUnionCase = Zset.memberOf mhi.mhiTycons, Zset.memberOf mhi.mhiTyconReprs, - Zset.memberOf mhi.mhiVals, + SetCustom.memberOf mhi.mhiVals, Zset.memberOf mhi.mhiRecdFields, Zset.memberOf mhi.mhiUnionCases @@ -3076,7 +3076,7 @@ and OptimizeModuleExpr cenv env x = not (ValueIsUsedOrHasEffect cenv (fun () -> fvs.FreeLocals) (bind, binfo)) && // Check the thing is hidden by the signature (if any) - hidden.mhiVals.Contains bind.Var && + (hidden.mhiVals |> SetCustom.contains bind.Var) && // Check the thing is not compiled as a static field or property, since reflected definitions and other reflective stuff might need it not (IsCompiledAsStaticProperty cenv.g bind.Var)) diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index a2565848d61..ddddf5be661 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -3815,14 +3815,14 @@ type SignatureRepackageInfo = type SignatureHidingInfo = { mhiTycons : Zset; mhiTyconReprs : Zset; - mhiVals : Zset; + mhiVals : zset mhiRecdFields : Zset; mhiUnionCases : Zset } static member Empty = { mhiTycons = Zset.empty tyconOrder; mhiTyconReprs = Zset.empty tyconOrder; - mhiVals = Zset.empty valOrder; + mhiVals = SetCustom.empty () mhiRecdFields = Zset.empty recdFieldRefOrder; mhiUnionCases = Zset.empty unionCaseRefOrder } @@ -3911,7 +3911,7 @@ let accValRemap g aenv (msigty:ModuleOrNamespaceType) (implVal:Val) (mrpi, mhi) match sigValOpt with | None -> if verbose then dprintf "accValRemap, hide = %s#%d\n" implVal.LogicalName implVal.Stamp - let mhi = { mhi with mhiVals = Zset.add implVal mhi.mhiVals } + let mhi = { mhi with mhiVals = SetCustom.add implVal mhi.mhiVals } (mrpi, mhi) | Some (sigVal:Val) -> // The value is in the signature. Add the repackage entry. @@ -4042,7 +4042,7 @@ let accValHidingInfoAtAssemblyBoundary (vspec:Val) mhi = // anything that's not a module or member binding gets assembly visibility not vspec.IsMemberOrModuleBinding then // The value is not public, hence hidden at the assembly boundary. - { mhi with mhiVals = Zset.add vspec mhi.mhiVals } + { mhi with mhiVals = SetCustom.add vspec mhi.mhiVals } else mhi @@ -4077,9 +4077,26 @@ let IsHidden setF accessF remapF debugF = if verbose then dprintf "IsHidden, #mrmi = %d, %s = %b\n" mrmi.Length (showL (debugF x)) res; res +let IsHidden' setF accessF remapF debugF = + let rec check mrmi x = + if verbose then dprintf "IsHidden %s ??\n" (showL (debugF x)); + // Internal/private? + not (canAccessFromEverywhere (accessF x)) || + (match mrmi with + | [] -> false // Ah! we escaped to freedom! + | (rpi, mhi) :: rest -> + // Explicitly hidden? + SetCustom.contains x (setF mhi) || + // Recurse... + check rest (remapF rpi x)) + fun mrmi x -> + let res = check mrmi x + if verbose then dprintf "IsHidden, #mrmi = %d, %s = %b\n" mrmi.Length (showL (debugF x)) res; + res + let IsHiddenTycon mrmi x = IsHidden (fun mhi -> mhi.mhiTycons) (fun tc -> tc.Accessibility) (fun rpi x -> (remapTyconRef rpi.tyconRefRemap (mkLocalTyconRef x)).Deref) DebugPrint.tyconL mrmi x let IsHiddenTyconRepr mrmi x = IsHidden (fun mhi -> mhi.mhiTyconReprs) (fun v -> v.TypeReprAccessibility) (fun rpi x -> (remapTyconRef rpi.tyconRefRemap (mkLocalTyconRef x)).Deref) DebugPrint.tyconL mrmi x -let IsHiddenVal mrmi x = IsHidden (fun mhi -> mhi.mhiVals) (fun v -> v.Accessibility) (fun rpi x -> (remapValRef rpi (mkLocalValRef x)).Deref) DebugPrint.valL mrmi x +let IsHiddenVal mrmi x = IsHidden' (fun mhi -> mhi.mhiVals) (fun v -> v.Accessibility) (fun rpi x -> (remapValRef rpi (mkLocalValRef x)).Deref) DebugPrint.valL mrmi x let IsHiddenRecdField mrmi x = IsHidden (fun mhi -> mhi.mhiRecdFields) (fun rfref -> rfref.RecdField.Accessibility) (fun rpi x -> remapRecdFieldRef rpi.tyconRefRemap x) DebugPrint.recdFieldRefL mrmi x diff --git a/src/fsharp/TastOps.fsi b/src/fsharp/TastOps.fsi index 65580230a82..e783af25801 100755 --- a/src/fsharp/TastOps.fsi +++ b/src/fsharp/TastOps.fsi @@ -859,7 +859,7 @@ type SignatureRepackageInfo = type SignatureHidingInfo = { mhiTycons : Zset; mhiTyconReprs : Zset; - mhiVals : Zset; + mhiVals : zset mhiRecdFields : Zset; mhiUnionCases : Zset } static member Empty : SignatureHidingInfo From bdbbe7d394d335f8fa2005125084e1e0fd52bdcc Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sat, 11 Aug 2018 14:04:50 +1000 Subject: [PATCH 78/92] converted all zsets --- src/fsharp/DetupleArgs.fs | 16 +++---- src/fsharp/DetupleArgs.fsi | 12 ++--- src/fsharp/IlxGen.fs | 18 +++---- src/fsharp/InnerLambdasToTopLevelFuncs.fs | 58 +++++++++++------------ src/fsharp/Optimizer.fs | 8 ++-- src/fsharp/TypeChecker.fs | 8 ++-- src/utils/SortKey.fs | 17 +++++++ 7 files changed, 77 insertions(+), 60 deletions(-) diff --git a/src/fsharp/DetupleArgs.fs b/src/fsharp/DetupleArgs.fs index 8358c0bcb7e..35bdae056e7 100644 --- a/src/fsharp/DetupleArgs.fs +++ b/src/fsharp/DetupleArgs.fs @@ -161,11 +161,11 @@ let (|TyappAndApp|_|) e = //------------------------------------------------------------------------- module GlobalUsageAnalysis = - let bindAccBounds vals (_isInDTree, v) = Zset.add v vals + let bindAccBounds vals (_isInDTree, v) = SetCustom.add v vals let GetValsBoundInExpr expr = let folder = {ExprFolder0 with valBindingSiteIntercept = bindAccBounds} - let z0 = Zset.empty valOrder + let z0 = SetCustom.empty () let z = FoldExpr folder z0 expr z @@ -187,18 +187,18 @@ module GlobalUsageAnalysis = /// v -> binding repr Defns : zmap /// bound in a decision tree? - DecisionTreeBindings : Zset + DecisionTreeBindings : zset /// v -> v list * recursive? -- the others in the mutual binding RecursiveBindings : zmap - TopLevelBindings : Zset + TopLevelBindings : zset IterationIsAtTopLevel : bool } let z0 = { Uses = Zmap.empty () Defns = Zmap.empty () RecursiveBindings = Zmap.empty () - DecisionTreeBindings = Zset.empty valOrder - TopLevelBindings = Zset.empty valOrder + DecisionTreeBindings = SetCustom.empty () + TopLevelBindings = SetCustom.empty () IterationIsAtTopLevel = true } /// Log the use of a value with a particular tuple chape at a callsite @@ -211,8 +211,8 @@ module GlobalUsageAnalysis = /// Log the definition of a binding let logBinding z (isInDTree, v) = - let z = if isInDTree then {z with DecisionTreeBindings = Zset.add v z.DecisionTreeBindings} else z - let z = if z.IterationIsAtTopLevel then {z with TopLevelBindings = Zset.add v z.TopLevelBindings} else z + let z = if isInDTree then {z with DecisionTreeBindings = SetCustom.add v z.DecisionTreeBindings} else z + let z = if z.IterationIsAtTopLevel then {z with TopLevelBindings = SetCustom.add v z.TopLevelBindings} else z z diff --git a/src/fsharp/DetupleArgs.fsi b/src/fsharp/DetupleArgs.fsi index 7479c8707c2..8dc18d71096 100644 --- a/src/fsharp/DetupleArgs.fsi +++ b/src/fsharp/DetupleArgs.fsi @@ -10,7 +10,7 @@ open Microsoft.FSharp.Compiler.TcGlobals val DetupleImplFile : CcuThunk -> TcGlobals -> TypedImplFile -> TypedImplFile module GlobalUsageAnalysis = - val GetValsBoundInExpr : Expr -> Zset + val GetValsBoundInExpr : Expr -> zset type accessor @@ -19,15 +19,15 @@ module GlobalUsageAnalysis = /// Later could support "safe" change operations, and optimisations could be in terms of those. type Results = { /// v -> context / APP inst args - Uses : Map, (accessor list * TType list * Expr list) list>; + Uses : zmap /// v -> binding repr - Defns : Map, Expr>; + Defns : zmap /// bound in a decision tree? - DecisionTreeBindings : Zset; + DecisionTreeBindings : zset /// v -> recursive? * v list -- the others in the mutual binding - RecursiveBindings : Map, (bool * Vals)>; + RecursiveBindings : zmap /// val not defined under lambdas - TopLevelBindings : Zset; + TopLevelBindings : zset /// top of expr toplevel? (true) IterationIsAtTopLevel : bool; } diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index 5c575d8a51b..ba17460d198 100644 --- a/src/fsharp/IlxGen.fs +++ b/src/fsharp/IlxGen.fs @@ -3663,7 +3663,7 @@ and GenObjectExpr cenv cgbuf eenvouter expr (baseType,baseValOpt,basecall,overri and GenSequenceExpr cenv (cgbuf:CodeGenBuffer) eenvouter (nextEnumeratorValRef:ValRef,pcvref:ValRef,currvref:ValRef,stateVars,generateNextExpr,closeExpr,checkCloseExpr:Expr,seqElemTy, m) sequel = let stateVars = [ pcvref; currvref ] @ stateVars - let stateVarsSet = stateVars |> List.map (fun vref -> vref.Deref) |> Zset.ofList valOrder + let stateVarsSet = stateVars |> List.map (fun vref -> vref.Deref) |> SetCustom.ofList // pretend that the state variables are bound let eenvouter = @@ -3701,7 +3701,7 @@ and GenSequenceExpr cenv (cgbuf:CodeGenBuffer) eenvouter (nextEnumeratorValRef:V ... *) /// State variables always get zero-initialized - if stateVarsSet.Contains fv then + if stateVarsSet |> SetCustom.contains fv then GenDefaultValue cenv cgbuf eenv (fv.Type,m) else GenGetLocalVal cenv cgbuf eenv m fv None @@ -3743,7 +3743,7 @@ and GenSequenceExpr cenv (cgbuf:CodeGenBuffer) eenvouter (nextEnumeratorValRef:V for fv in cloFreeVars do /// State variables always get zero-initialized - if stateVarsSet.Contains fv then + if stateVarsSet |> SetCustom.contains fv then GenDefaultValue cenv cgbuf eenvouter (fv.Type,m) else GenGetLocalVal cenv cgbuf eenvouter m fv None @@ -4638,20 +4638,20 @@ and GenLetRecBindings cenv cgbuf eenv (allBinds: Bindings,m) = let selfv = (match e with Expr.Obj _ -> None | _ when isLocalTypeFunc -> None | _ -> Option.map mkLocalValRef selfv) let clo,_,eenvclo = GetIlxClosureInfo cenv m isLocalTypeFunc selfv {eenv with letBoundVars=(mkLocalValRef boundv)::eenv.letBoundVars} e clo.cloFreeVars |> List.iter (fun fv -> - if Zset.contains fv forwardReferenceSet then + if SetCustom.contains fv forwardReferenceSet then match StorageForVal m fv eenvclo with | Env (_,_,ilField,_) -> fixups := (boundv, fv, (fun () -> GenLetRecFixup cenv cgbuf eenv (clo.cloSpec,access,ilField,exprForVal m fv,m))) :: !fixups | _ -> error (InternalError("GenLetRec: " + fv.LogicalName + " was not in the environment",m)) ) | Expr.Val (vref,_,_) -> let fv = vref.Deref - let needsFixup = Zset.contains fv forwardReferenceSet + let needsFixup = SetCustom.contains fv forwardReferenceSet if needsFixup then fixups := (boundv, fv,(fun () -> GenExpr cenv cgbuf eenv SPSuppress (set e) discard)) :: !fixups | _ -> failwith "compute real fixup vars" let fixups = ref [] - let recursiveVars = Zset.addList (bindsPossiblyRequiringFixup |> List.map (fun v -> v.Var)) (Zset.empty valOrder) + let recursiveVars = SetCustom.ofList (bindsPossiblyRequiringFixup |> List.map (fun v -> v.Var)) let _ = (recursiveVars, bindsPossiblyRequiringFixup) ||> List.fold (fun forwardReferenceSet (bind:Binding) -> // Compute fixups @@ -4660,7 +4660,7 @@ and GenLetRecBindings cenv cgbuf eenv (allBinds: Bindings,m) = (exprForVal m bind.Var, (fun _ -> failwith ("internal error: should never need to set non-delayed recursive val: " + bind.Var.LogicalName))) // Record the variable as defined - let forwardReferenceSet = Zset.remove bind.Var forwardReferenceSet + let forwardReferenceSet = SetCustom.remove bind.Var forwardReferenceSet forwardReferenceSet) // Generate the actual bindings @@ -4668,9 +4668,9 @@ and GenLetRecBindings cenv cgbuf eenv (allBinds: Bindings,m) = (recursiveVars, allBinds) ||> List.fold (fun forwardReferenceSet (bind:Binding) -> GenBinding cenv cgbuf eenv bind // Record the variable as defined - let forwardReferenceSet = Zset.remove bind.Var forwardReferenceSet + let forwardReferenceSet = SetCustom.remove bind.Var forwardReferenceSet // Execute and discard any fixups that can now be committed - fixups := !fixups |> List.filter (fun (boundv, fv, action) -> if (Zset.contains boundv forwardReferenceSet || Zset.contains fv forwardReferenceSet) then true else (action(); false)) + fixups := !fixups |> List.filter (fun (boundv, fv, action) -> if (SetCustom.contains boundv forwardReferenceSet || SetCustom.contains fv forwardReferenceSet) then true else (action(); false)) forwardReferenceSet) () diff --git a/src/fsharp/InnerLambdasToTopLevelFuncs.fs b/src/fsharp/InnerLambdasToTopLevelFuncs.fs index 30320abd2e3..eec7190c349 100644 --- a/src/fsharp/InnerLambdasToTopLevelFuncs.fs +++ b/src/fsharp/InnerLambdasToTopLevelFuncs.fs @@ -135,9 +135,9 @@ let mkLocalNameTypeArity compgen m name ty topValInfo = let GetValsBoundUnderMustInline xinfo = let accRejectFrom (v:Val) repr rejectS = if v.InlineInfo = ValInline.PseudoVal then - Zset.union (GetValsBoundInExpr repr) rejectS + Set.union (GetValsBoundInExpr repr) rejectS else rejectS - let rejectS = Zset.empty valOrder + let rejectS = SetCustom.empty () let rejectS = Zmap.fold accRejectFrom xinfo.Defns rejectS rejectS @@ -181,10 +181,10 @@ module Pass1_DetermineTLRAndArities = let SelectTLRVals g xinfo f e = if IsRefusedTLR g f then None // Exclude values bound in a decision tree - else if Zset.contains f xinfo.DecisionTreeBindings then None + else if SetCustom.contains f xinfo.DecisionTreeBindings then None else // Could the binding be TLR? with what arity? - let atTopLevel = Zset.contains f xinfo.TopLevelBindings + let atTopLevel = SetCustom.contains f xinfo.TopLevelBindings let tps,vss,_b,_rty = stripTopLambda (e,f.Type) let nFormals = vss.Length let nMaxApplied = GetMaxNumArgsAtUses xinfo f @@ -211,16 +211,16 @@ module Pass1_DetermineTLRAndArities = // Do not TLR v if it is bound under a mustinline defn // There is simply no point - the original value will be duplicated and TLR'd anyway let rejectS = GetValsBoundUnderMustInline xinfo - let fArities = List.filter (fun (v,_) -> not (Zset.contains v rejectS)) fArities + let fArities = List.filter (fun (v,_) -> not (SetCustom.contains v rejectS)) fArities (*-*) - let tlrS = Zset.ofList valOrder (List.map fst fArities) + let tlrS = SetCustom.ofList (List.map fst fArities) let topValS = xinfo.TopLevelBindings (* genuinely top level *) - let topValS = Zset.filter (IsMandatoryNonTopLevel g >> not) topValS (* restrict *) + let topValS = SetCustom.filter (IsMandatoryNonTopLevel g >> not) topValS (* restrict *) (* REPORT MISSED CASES *) #if DEBUG if verboseTLR then - let missed = Zset.diff xinfo.TopLevelBindings tlrS - missed |> Zset.iter (fun v -> dprintf "TopLevel but not TLR = %s\n" v.LogicalName) + let missed = SetCustom.diff xinfo.TopLevelBindings tlrS + missed |> SetCustom.iter (fun v -> dprintf "TopLevel but not TLR = %s\n" v.LogicalName) #endif (* REPORT OVER *) let arityM = Zmap.ofList fArities @@ -292,11 +292,11 @@ module Pass1_DetermineTLRAndArities = /// [Each fclass has an env, the fclass are the handles to envs.] type BindingGroupSharingSameReqdItems(bindings: Bindings) = let vals = valsOfBinds bindings - let vset = Zset.addList vals (Zset.empty valOrder) + let vset = SetCustom.ofList vals member fclass.Vals = vals - member fclass.Contains (v: Val) = vset.Contains v + member fclass.Contains (v: Val) = vset |> SetCustom.contains v member fclass.IsEmpty = isNil vals @@ -362,7 +362,7 @@ type ReqdItemsForDefn = // pass2: collector - state //------------------------------------------------------------------------- -type Generators = Zset +type Generators = zset /// check a named function value applied to sufficient arguments let IsArityMet (vref:ValRef) wf (tys: TypeInst) args = @@ -424,7 +424,7 @@ module Pass2_DetermineReqdItems = reqdItemsMap : zmap fclassM : zmap revDeclist : BindingGroupSharingSameReqdItems list - recShortCallS : Zset + recShortCallS : zset } let state0 = @@ -432,7 +432,7 @@ module Pass2_DetermineReqdItems = reqdItemsMap = Zmap.empty () fclassM = Zmap.empty () revDeclist = [] - recShortCallS = Zset.empty valOrder } + recShortCallS = SetCustom.empty () } /// PUSH = start collecting for fclass let PushFrame (fclass: BindingGroupSharingSameReqdItems) (reqdTypars0,reqdVals0,m) state = @@ -459,9 +459,9 @@ module Pass2_DetermineReqdItems = /// Log requirements for gv in the relevant stack frames let LogRequiredFrom gv items state = - let logIntoFrame (fclass, reqdVals0:Zset, env: ReqdItemsForDefn) = + let logIntoFrame (fclass, reqdVals0:zset, env: ReqdItemsForDefn) = let env = - if reqdVals0.Contains gv then + if reqdVals0 |> SetCustom.contains gv then env.Extend ([],items) else env @@ -474,7 +474,7 @@ module Pass2_DetermineReqdItems = if verboseTLR then dprintf "shortCall: rec: %s\n" gv.LogicalName // Have short call to gv within it's (mutual) definition(s) {state with - recShortCallS = Zset.add gv state.recShortCallS} + recShortCallS = SetCustom.add gv state.recShortCallS} else if verboseTLR then dprintf "shortCall: not-rec: %s\n" gv.LogicalName state @@ -509,7 +509,7 @@ module Pass2_DetermineReqdItems = LogRequiredFrom f [ReqdVal f] z let accBinds m z (binds: Bindings) = - let tlrBs,nonTlrBs = binds |> List.partition (fun b -> Zset.contains b.Var tlrS) + let tlrBs,nonTlrBs = binds |> List.partition (fun b -> SetCustom.contains b.Var tlrS) // For bindings marked TLR, collect implied env let fclass = BindingGroupSharingSameReqdItems tlrBs // what determines env? @@ -519,7 +519,7 @@ module Pass2_DetermineReqdItems = let reqdVals0 = frees.FreeLocals |> SetCustom.elements // tlrBs are not reqdVals0 for themselves let reqdVals0 = reqdVals0 |> List.filter (fun gv -> not (fclass.Contains gv)) - let reqdVals0 = reqdVals0 |> Zset.ofList valOrder + let reqdVals0 = reqdVals0 |> SetCustom.ofList // collect into env over bodies let z = PushFrame fclass (reqdTypars0,reqdVals0,m) z let z = (z,tlrBs) ||> List.fold (foldOn (fun b -> b.Expr) exprF) @@ -628,7 +628,7 @@ module Pass2_DetermineReqdItems = if verboseTLR then DumpReqdValMap reqdItemsMap declist |> List.iter (fun fc -> dprintf "Declist: %A\n" fc) - recShortCallS |> Zset.iter (fun f -> dprintf "RecShortCall: %s\n" f.LogicalName) + recShortCallS |> SetCustom.iter (fun f -> dprintf "RecShortCall: %s\n" f.LogicalName) #endif reqdItemsMap,fclassM,declist,recShortCallS @@ -734,7 +734,7 @@ let FlatEnvPacks g fclassM topValS declist (reqdItemsMap: zmap List.filter (fun v -> not (isByrefLikeTy g v.Range v.Type)) // Remove values which have been labelled TLR, no need to close over these - let vals = vals |> List.filter (Zset.memberOf topValS >> not) + let vals = vals |> List.filter (SetCustom.memberOf topValS >> not) // Carrier sets cannot include constrained polymorphic values. We can't just take such a value out, so for the moment // we'll just abandon TLR altogether and give a warning about this condition. @@ -845,7 +845,7 @@ let CreateNewValuesForTLR g tlrS arityM fclassM envPackM = let fHat = mkLocalNameTypeArity f.IsCompilerGenerated m fHatName fHatTy (Some fHatArity) fHat - let fs = Zset.elements tlrS + let fs = SetCustom.elements tlrS let ffHats = List.map (fun f -> f,createFHat f) fs let fHatM = Zmap.ofList ffHats fHatM @@ -860,11 +860,11 @@ module Pass4_RewriteAssembly = type RewriteContext = { ccu : CcuThunk g : TcGlobals - tlrS : Zset - topValS : Zset + tlrS : zset + topValS : zset arityM : zmap fclassM : zmap - recShortCallS : Zset + recShortCallS : zset envPackM : zmap /// The mapping from 'f' values to 'fHat' values fHatM : zmap @@ -1009,7 +1009,7 @@ module Pass4_RewriteAssembly = let fHatBind = mkMultiLambdaBind fHat letSeqPtOpt m fHat_tps fHat_args (fHat_body,rty) fHatBind let rebinds = binds |> List.map fRebinding - let shortRecBinds = rebinds |> List.filter (fun b -> penv.recShortCallS.Contains(b.Var)) + let shortRecBinds = rebinds |> List.filter (fun b -> penv.recShortCallS |> SetCustom.contains b.Var) let newBinds = binds |> List.map (fHatNewBinding shortRecBinds) newBinds,rebinds @@ -1019,7 +1019,7 @@ module Pass4_RewriteAssembly = | Some envp -> envp.ep_pack // environment pack bindings let TransBindings xisRec penv (binds:Bindings) = - let tlrBs,nonTlrBs = binds |> List.partition (fun b -> Zset.contains b.Var penv.tlrS) + let tlrBs,nonTlrBs = binds |> List.partition (fun b -> SetCustom.contains b.Var penv.tlrS) let fclass = BindingGroupSharingSameReqdItems tlrBs // Trans each TLR f binding into fHat and f rebind let newTlrBinds,tlrRebinds = TransTLRBindings penv tlrBs @@ -1029,7 +1029,7 @@ module Pass4_RewriteAssembly = // QUERY: yes and no - if we don't, we have an unrealizable term, and many decisions must // QUERY: correlate with LowerCallsAndSeqs. let forceTopBindToHaveArity (bind:Binding) = - if penv.topValS.Contains(bind.Var) then ConvertBind penv.g bind + if penv.topValS |> SetCustom.contains bind.Var then ConvertBind penv.g bind else bind let nonTlrBs = nonTlrBs |> List.map forceTopBindToHaveArity @@ -1051,7 +1051,7 @@ module Pass4_RewriteAssembly = // CLEANUP NOTE: should be using a mkApps to make all applications match fx with | Expr.Val (fvref:ValRef,_,m) when - (Zset.contains fvref.Deref penv.tlrS) && + (SetCustom.contains fvref.Deref penv.tlrS) && (let wf = Zmap.force fvref.Deref penv.arityM ("TransApp - wf",nameOfVal) IsArityMet fvref wf tys args) -> diff --git a/src/fsharp/Optimizer.fs b/src/fsharp/Optimizer.fs index 312ace8165a..bb61f97c4e3 100644 --- a/src/fsharp/Optimizer.fs +++ b/src/fsharp/Optimizer.fs @@ -3081,7 +3081,7 @@ and OptimizeModuleExpr cenv env x = // Check the thing is not compiled as a static field or property, since reflected definitions and other reflective stuff might need it not (IsCompiledAsStaticProperty cenv.g bind.Var)) - let deadSet = Zset.addList (dead |> List.map (fun (bind, _) -> bind.Var)) (Zset.empty valOrder) + let deadSet = SetCustom.ofList (dead |> List.map (fun (bind, _) -> bind.Var)) // Eliminate dead private bindings from a module type by mutation. Note that the optimizer doesn't // actually copy the entire term - it copies the expression portions of the term and leaves the @@ -3095,7 +3095,7 @@ and OptimizeModuleExpr cenv env x = let rec elimModTy (mtyp:ModuleOrNamespaceType) = let mty = new ModuleOrNamespaceType(kind=mtyp.ModuleOrNamespaceKind, - vals= (mtyp.AllValsAndMembers |> QueueList.filter (Zset.memberOf deadSet >> not)), + vals= (mtyp.AllValsAndMembers |> QueueList.filter (SetCustom.memberOf deadSet >> not)), entities= mtyp.AllEntities) mtyp.ModuleAndNamespaceDefinitions |> List.iter elimModSpec mty @@ -3109,14 +3109,14 @@ and OptimizeModuleExpr cenv env x = let mbinds = mbinds |> List.choose elimModuleBinding TMDefRec(isRec, tycons, mbinds, m) | TMDefLet(bind, m) -> - if Zset.contains bind.Var deadSet then TMDefRec(false, [], [], m) else x + if SetCustom.contains bind.Var deadSet then TMDefRec(false, [], [], m) else x | TMDefDo _ -> x | TMDefs(defs) -> TMDefs(List.map elimModDef defs) | TMAbstract _ -> x and elimModuleBinding x = match x with | ModuleOrNamespaceBinding.Binding bind -> - if bind.Var |> Zset.memberOf deadSet then None + if bind.Var |> SetCustom.memberOf deadSet then None else Some x | ModuleOrNamespaceBinding.Module(mspec, d) -> // Clean up the ModuleOrNamespaceType by mutation diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index 67f9ff60eaa..56413a3047d 100755 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -12422,13 +12422,13 @@ module IncrClassChecking = /// vals mapped to representations ValReprs : zmap /// vals represented as fields or members from this point on - ValsWithRepresentation : Zset } + ValsWithRepresentation : zset } static member Empty(g, names) = { TakenFieldNames=Set.ofList names RepInfoTcGlobals=g ValReprs = Zmap.empty () - ValsWithRepresentation = Zset.empty valOrder } + ValsWithRepresentation = SetCustom.empty () } /// Find the representation of a value member localRep.LookupRepr (v:Val) = @@ -12548,10 +12548,10 @@ module IncrClassChecking = ValReprs = Zmap.add v repr localRep.ValReprs} member localRep.ValNowWithRepresentation (v:Val) = - {localRep with ValsWithRepresentation = Zset.add v localRep.ValsWithRepresentation} + {localRep with ValsWithRepresentation = SetCustom.add v localRep.ValsWithRepresentation} member localRep.IsValWithRepresentation (v:Val) = - localRep.ValsWithRepresentation.Contains(v) + localRep.ValsWithRepresentation |> SetCustom.contains v member localRep.IsValRepresentedAsLocalVar (v:Val) = match localRep.LookupRepr v with diff --git a/src/utils/SortKey.fs b/src/utils/SortKey.fs index b65a8f7258c..1b3a2fedd3c 100644 --- a/src/utils/SortKey.fs +++ b/src/utils/SortKey.fs @@ -90,6 +90,11 @@ type SetCustom<'Key>() = static member empty<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct>() : zset<'Key,'Comparer> = Set.empty> + static member ofList<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> lst : zset<'Key,'Comparer> = + lst + |> List.map (fun k -> {CompareObj=k}) + |> Set.ofList + static member inline contains<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (k:'Key) (s:zset<'Key,'Comparer>) = Set.contains {CompareObj=k} s @@ -117,3 +122,15 @@ type SetCustom<'Key>() = static member inline union<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (set1:zset<'Key,'Comparer>) (set2:zset<'Key,'Comparer>) = Set.union set1 set2 + static member inline fold<'Comparer, 'State when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (folder:'Key->'State->'State) (s:zset<'Key,'Comparer>) (state:'State) : 'State = + Set.fold (fun acc {CompareObj=k} -> folder k acc) state s + + static member inline addList<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (xs:list<'Key>) (s:zset<'Key,'Comparer>) = + List.fold (fun acc x -> Set.add {CompareObj=x} acc) s xs + + static member inline diff<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (a:zset<'Key,'Comparer>) (b:zset<'Key,'Comparer>) = + Set.fold (fun a k -> Set.remove k a) a b + + static member inline iter<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (f:'Key->unit) (m:zset<'Key,'Comparer>) = + Set.iter (fun {CompareObj=k} -> f k) m + From f3523f27daaf5f7d41445d4fdd4f70e5adeafee6 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sat, 11 Aug 2018 17:17:59 +1000 Subject: [PATCH 79/92] Transferred Zset to SetCustom --- src/fsharp/FindUnsolved.fs | 3 +- src/fsharp/IlxGen.fs | 4 +-- src/fsharp/InnerLambdasToTopLevelFuncs.fs | 18 +++++------ src/fsharp/NameResolution.fs | 6 ++-- src/fsharp/NicePrint.fs | 4 +-- src/fsharp/Optimizer.fs | 6 ++-- src/fsharp/TastOps.fs | 38 +++++++++-------------- src/fsharp/TastOps.fsi | 6 ++-- src/fsharp/TypeChecker.fs | 34 ++++++++++---------- src/fsharp/TypeRelations.fs | 3 +- src/fsharp/tast.fs | 2 +- src/utils/SortKey.fs | 26 +++++++++++++++- 12 files changed, 84 insertions(+), 66 deletions(-) diff --git a/src/fsharp/FindUnsolved.fs b/src/fsharp/FindUnsolved.fs index e78e41212dd..0aeb9726956 100644 --- a/src/fsharp/FindUnsolved.fs +++ b/src/fsharp/FindUnsolved.fs @@ -13,6 +13,7 @@ open Microsoft.FSharp.Compiler.Tast open Microsoft.FSharp.Compiler.Tastops open Microsoft.FSharp.Compiler.TcGlobals open Microsoft.FSharp.Compiler.TypeRelations +open Internal.Utilities.Collections type env = Nix @@ -23,7 +24,7 @@ type cenv = mutable unsolved: Typars } let accTy cenv _env ty = - (freeInType CollectTyparsNoCaching (tryNormalizeMeasureInType cenv.g ty)).FreeTypars |> Zset.iter (fun tp -> + (freeInType CollectTyparsNoCaching (tryNormalizeMeasureInType cenv.g ty)).FreeTypars |> SetCustom.iter (fun tp -> if (tp.Rigidity <> TyparRigidity.Rigid) then cenv.unsolved <- tp :: cenv.unsolved) diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index ba17460d198..0643f1c5daf 100644 --- a/src/fsharp/IlxGen.fs +++ b/src/fsharp/IlxGen.fs @@ -3924,8 +3924,8 @@ and GetIlxClosureFreeVars cenv m selfv eenvouter takenNames expr = // -- "internal" ones, which get used internally in the implementation let cloContractFreeTyvarSet = (freeInType CollectTypars (tyOfExpr cenv.g expr)).FreeTypars - let cloInternalFreeTyvars = Zset.diff cloFreeVarResults.FreeTyvars.FreeTypars cloContractFreeTyvarSet |> Zset.elements - let cloContractFreeTyvars = cloContractFreeTyvarSet |> Zset.elements + let cloInternalFreeTyvars = SetCustom.diff cloFreeVarResults.FreeTyvars.FreeTypars cloContractFreeTyvarSet |> SetCustom.elements + let cloContractFreeTyvars = cloContractFreeTyvarSet |> SetCustom.elements let cloFreeTyvars = cloContractFreeTyvars @ cloInternalFreeTyvars diff --git a/src/fsharp/InnerLambdasToTopLevelFuncs.fs b/src/fsharp/InnerLambdasToTopLevelFuncs.fs index eec7190c349..3c4e09b2a19 100644 --- a/src/fsharp/InnerLambdasToTopLevelFuncs.fs +++ b/src/fsharp/InnerLambdasToTopLevelFuncs.fs @@ -69,7 +69,7 @@ let destApp (f,fty,tys,args,m) = | f -> (f,fty,tys,args,m) #if DEBUG -let showTyparSet tps = showL (commaListL (List.map typarL (Zset.elements tps))) +let showTyparSet tps = showL (commaListL (List.map typarL (SetCustom.elements tps))) #endif // CLEANUP NOTE: don't like the look of this function - this distinction @@ -335,7 +335,7 @@ let reqdItemOrder = /// The reqdTypars are the free reqdTypars of the defns, and those required by any direct TLR arity-met calls. /// The reqdItems are the ids/subEnvs required from calls to freeVars. type ReqdItemsForDefn = - { reqdTypars : Zset + { reqdTypars : zset reqdItems : Zset m : Range.range } member env.ReqdSubEnvs = [ for x in env.reqdItems do match x with | ReqdSubEnv f -> yield f | ReqdVal _ -> () ] @@ -343,16 +343,16 @@ type ReqdItemsForDefn = member env.Extend (typars,items) = {env with - reqdTypars = Zset.addList typars env.reqdTypars + reqdTypars = SetCustom.addList typars env.reqdTypars reqdItems = Zset.addList items env.reqdItems} static member Initial typars m = - {reqdTypars = Zset.addList typars (Zset.empty typarOrder) + {reqdTypars = SetCustom.ofList typars reqdItems = Zset.empty reqdItemOrder m = m } override env.ToString() = - (showL (commaListL (List.map typarL (Zset.elements env.reqdTypars)))) + "--" + + (showL (commaListL (List.map typarL (SetCustom.elements env.reqdTypars)))) + "--" + (String.concat "," (List.map string (Zset.elements env.reqdItems))) (*--debug-stuff--*) @@ -514,7 +514,7 @@ module Pass2_DetermineReqdItems = let fclass = BindingGroupSharingSameReqdItems tlrBs // what determines env? let frees = FreeInBindings tlrBs - let reqdTypars0 = frees.FreeTyvars.FreeTypars |> Zset.elements (* put in env *) + let reqdTypars0 = frees.FreeTyvars.FreeTypars |> SetCustom.elements (* put in env *) // occurrences contribute to env let reqdVals0 = frees.FreeLocals |> SetCustom.elements // tlrBs are not reqdVals0 for themselves @@ -572,8 +572,8 @@ module Pass2_DetermineReqdItems = env.reqdTypars) let reqdTypars0 = env.reqdTypars - let reqdTypars = List.fold Zset.union reqdTypars0 directCallReqdTypars - let changed = changed || (not (Zset.equal reqdTypars0 reqdTypars)) + let reqdTypars = List.fold Set.union reqdTypars0 directCallReqdTypars + let changed = changed || (not (SetCustom.equal reqdTypars0 reqdTypars)) let env = {env with reqdTypars = reqdTypars} #if DEBUG if verboseTLR then @@ -774,7 +774,7 @@ let FlatEnvPacks g fclassM topValS declist (reqdItemsMap: zmap @@ -1675,7 +1677,7 @@ let CheckAllTyparsInferrable amap m item = List.foldBack (accFreeInTypes CollectTyparsNoCaching) (minfo.GetParamTypes(amap, m, fminst)) (accFreeInTypes CollectTyparsNoCaching (minfo.GetObjArgTypes(amap, m, fminst)) (freeInType CollectTyparsNoCaching (minfo.GetFSharpReturnTy(amap, m, fminst)))) - let free = Zset.diff freeInDeclaringType.FreeTypars freeInArgsAndRetType.FreeTypars + let free = Internal.Utilities.Collections.SetCustom.diff freeInDeclaringType.FreeTypars freeInArgsAndRetType.FreeTypars free.IsEmpty) | Item.CtorGroup _ diff --git a/src/fsharp/NicePrint.fs b/src/fsharp/NicePrint.fs index e6c067fdc9d..914cb2e8007 100755 --- a/src/fsharp/NicePrint.fs +++ b/src/fsharp/NicePrint.fs @@ -764,7 +764,7 @@ module private PrintTypes = match Zmap.tryFind typar env.inplaceConstraints with | Some (typarConstraintTy) -> - if Zset.contains typar env.singletons then + if SetCustom.contains typar env.singletons then leftL (tagPunctuation "#") ^^ layoutTypeWithInfo denv env typarConstraintTy else (varL ^^ sepL (tagPunctuation ":>") ^^ layoutTypeWithInfo denv env typarConstraintTy) |> bracketL @@ -1193,7 +1193,7 @@ module private PrintTastMemberOrVals = else nameL - let isOverGeneric = List.length (Zset.elements (freeInType CollectTyparsNoCaching tau).FreeTypars) < List.length tps // Bug: 1143 + let isOverGeneric = List.length (SetCustom.elements (freeInType CollectTyparsNoCaching tau).FreeTypars) < List.length tps // Bug: 1143 let isTyFunction = v.IsTypeFunction // Bug: 1143, and innerpoly tests let typarBindingsL = if isTyFunction || isOverGeneric || denv.showTyparBinding then diff --git a/src/fsharp/Optimizer.fs b/src/fsharp/Optimizer.fs index bb61f97c4e3..bc0c034ed56 100644 --- a/src/fsharp/Optimizer.fs +++ b/src/fsharp/Optimizer.fs @@ -1071,7 +1071,7 @@ let AbstractExprInfoByVars (boundVars:Val list, boundTyVars) ivalue = (not (isNil boundVars) && List.exists (valEq v2) boundVars) || (not (isNil boundTyVars) && let ftyvs = freeInVal CollectTypars v2 - List.exists (Zset.memberOf ftyvs.FreeTypars) boundTyVars) -> + List.exists (SetCustom.memberOf ftyvs.FreeTypars) boundTyVars) -> // hiding value when used in expression abstractExprInfo detail @@ -1084,7 +1084,7 @@ let AbstractExprInfoByVars (boundVars:Val list, boundTyVars) ivalue = | CurriedLambdaValue (_, _, _, expr, _) | ConstExprValue(_, expr) when (let fvs = freeInExpr (if isNil boundTyVars then CollectLocals else CollectTyparsAndLocals) expr (not (isNil boundVars) && List.exists (SetCustom.memberOf fvs.FreeLocals) boundVars) || - (not (isNil boundTyVars) && List.exists (Zset.memberOf fvs.FreeTyvars.FreeTypars) boundTyVars) || + (not (isNil boundTyVars) && List.exists (SetCustom.memberOf fvs.FreeTyvars.FreeTypars) boundTyVars) || (fvs.UsesMethodLocalConstructs )) -> // Trimming lambda @@ -1094,7 +1094,7 @@ let AbstractExprInfoByVars (boundVars:Val list, boundTyVars) ivalue = | ConstValue(_, ty) when (not (isNil boundTyVars) && (let ftyvs = freeInType CollectTypars ty - List.exists (Zset.memberOf ftyvs.FreeTypars) boundTyVars)) -> + List.exists (SetCustom.memberOf ftyvs.FreeTypars) boundTyVars)) -> UnknownValue // Otherwise check all sub-values diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index ddddf5be661..2dbe8702c1c 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -1855,15 +1855,7 @@ let unionFreeTycons s1 s2 = elif s2 === emptyFreeTycons then s1 else Zset.union s1 s2 -let typarOrder = - { new System.Collections.Generic.IComparer with - member x.Compare (v1:Typar, v2:Typar) = compare v1.Stamp v2.Stamp } - -let emptyFreeTypars = Zset.empty typarOrder -let unionFreeTypars s1 s2 = - if s1 === emptyFreeTypars then s2 - elif s2 === emptyFreeTypars then s1 - else Zset.union s1 s2 +let emptyFreeTypars = SetCustom.empty () let emptyFreeTyvars = { FreeTycons = emptyFreeTycons @@ -1872,7 +1864,7 @@ let emptyFreeTyvars = FreeTypars = emptyFreeTypars} let isEmptyFreeTyvars ftyvs = - Zset.isEmpty ftyvs.FreeTypars && + SetCustom.isEmpty ftyvs.FreeTypars && Zset.isEmpty ftyvs.FreeTycons let unionFreeTyvars fvs1 fvs2 = @@ -1880,7 +1872,7 @@ let unionFreeTyvars fvs1 fvs2 = if fvs2 === emptyFreeTyvars then fvs1 else { FreeTycons = unionFreeTycons fvs1.FreeTycons fvs2.FreeTycons FreeTraitSolutions = Set.union fvs1.FreeTraitSolutions fvs2.FreeTraitSolutions - FreeTypars = unionFreeTypars fvs1.FreeTypars fvs2.FreeTypars } + FreeTypars = Set.union fvs1.FreeTypars fvs2.FreeTypars } type FreeVarOptions = { canCache: bool @@ -1972,7 +1964,7 @@ let rec boundTypars opts tps acc = // Bound type vars form a recursively-referential set due to constraints, e.g. A : I, B : I // So collect up free vars in all constraints first, then bind all variables let acc = List.foldBack (fun (tp:Typar) acc -> accFreeInTyparConstraints opts tp.Constraints acc) tps acc - List.foldBack (fun tp acc -> { acc with FreeTypars = Zset.remove tp acc.FreeTypars}) tps acc + List.foldBack (fun tp acc -> { acc with FreeTypars = SetCustom.remove tp acc.FreeTypars}) tps acc and accFreeInTyparConstraints opts cxs acc = List.foldBack (accFreeInTyparConstraint opts) cxs acc @@ -2026,10 +2018,10 @@ and accFreeValRefInTraitSln opts (vref:ValRef) fvs = and accFreeTyparRef opts (tp:Typar) acc = if not opts.includeTypars then acc else - if Zset.contains tp acc.FreeTypars then acc + if SetCustom.contains tp acc.FreeTypars then acc else accFreeInTyparConstraints opts tp.Constraints - { acc with FreeTypars = Zset.add tp acc.FreeTypars} + { acc with FreeTypars = SetCustom.add tp acc.FreeTypars} and accFreeInType opts ty acc = match stripTyparEqns ty with @@ -2536,30 +2528,30 @@ module SimplifyTypes = let accTyparCountsMulti acc l = List.fold accTyparCounts acc l type TypeSimplificationInfo = - { singletons : Typar Zset + { singletons : zset inplaceConstraints : zmap postfixConstraints : (Typar * TyparConstraint) list } let typeSimplificationInfo0 = - { singletons = Zset.empty typarOrder + { singletons = SetCustom.empty () inplaceConstraints = Zmap.empty () postfixConstraints = [] } let categorizeConstraints simplify m cxs = let singletons = if simplify then Zmap.chooseL (fun tp n -> if n = 1 then Some tp else None) m else [] - let singletons = Zset.addList singletons (Zset.empty typarOrder) + let singletons = SetCustom.ofList singletons // Here, singletons are typars that occur once in the type. // However, they may also occur in a type constraint. // If they do, they are really multiple occurrence - so we should remove them. let constraintTypars = (freeInTyparConstraints CollectTyparsNoCaching (List.map snd cxs)).FreeTypars - let usedInTypeConstraint typar = Zset.contains typar constraintTypars - let singletons = singletons |> Zset.filter (usedInTypeConstraint >> not) + let usedInTypeConstraint typar = SetCustom.contains typar constraintTypars + let singletons = singletons |> SetCustom.filter (usedInTypeConstraint >> not) // Here, singletons should really be used once let inplace, postfix = cxs |> List.partition (fun (tp, tpc) -> simplify && isTTyparCoercesToType tpc && - Zset.contains tp singletons && + SetCustom.contains tp singletons && tp.Constraints.Length = 1) let inplace = inplace |> List.map (function (tp, TyparConstraint.CoercesTo(ty, _)) -> tp, ty | _ -> failwith "not isTTyparCoercesToType") @@ -3246,7 +3238,7 @@ module DebugPrint = begin match Zmap.tryFind typar env.inplaceConstraints with | Some (typarConstraintTy) -> - if Zset.contains typar env.singletons then + if SetCustom.contains typar env.singletons then leftL (tagText "#") ^^ auxTyparConstraintTypL env typarConstraintTy else (varL ^^ sepL (tagText ":>") ^^ auxTyparConstraintTypL env typarConstraintTy) |> wrap @@ -7745,14 +7737,14 @@ type PrettyNaming.ActivePatternInfo with // not by their argument types. let doesActivePatternHaveFreeTypars g (v:ValRef) = let vty = v.TauType - let vtps = v.Typars |> Zset.ofList typarOrder + let vtps = v.Typars |> SetCustom.ofList if not (isFunTy g v.TauType) then errorR(Error(FSComp.SR.activePatternIdentIsNotFunctionTyped(v.LogicalName), v.Range)) let argtys, resty = stripFunTy g vty let argtps, restps= (freeInTypes CollectTypars argtys).FreeTypars, (freeInType CollectTypars resty).FreeTypars // Error if an active pattern is generic in type variables that only occur in the result Choice<_, ...>. // Note: The test restricts to v.Typars since typars from the closure are considered fixed. - not (Zset.isEmpty (Zset.inter (Zset.diff restps argtps) vtps)) + not (SetCustom.isEmpty (SetCustom.inter (SetCustom.diff restps argtps) vtps)) //--------------------------------------------------------------------------- // RewriteExpr: rewrite bottom up with interceptors diff --git a/src/fsharp/TastOps.fsi b/src/fsharp/TastOps.fsi index e783af25801..7ea511fc1ca 100755 --- a/src/fsharp/TastOps.fsi +++ b/src/fsharp/TastOps.fsi @@ -382,7 +382,6 @@ type TyconRefMultiMap<'T> = val valOrder : IComparer val tyconOrder : IComparer val recdFieldRefOrder : IComparer -val typarOrder : IComparer //------------------------------------------------------------------------- // Equality on Tycon and Val @@ -559,7 +558,6 @@ val applyTys : TcGlobals -> TType -> TType list * 'T list -> TType //------------------------------------------------------------------------- val emptyFreeTypars : FreeTypars -val unionFreeTypars : FreeTypars -> FreeTypars -> FreeTypars val emptyFreeTycons : FreeTycons val unionFreeTycons : FreeTycons -> FreeTycons -> FreeTycons @@ -752,8 +750,8 @@ val prefixOfRigidTypar : Typar -> string /// Utilities used in simplifying types for visual presentation module SimplifyTypes = type TypeSimplificationInfo = - { singletons : Typar Zset; - inplaceConstraints : Map, TType> + { singletons : zset + inplaceConstraints : zmap postfixConstraints : TyparConstraintsWithTypars; } val typeSimplificationInfo0 : TypeSimplificationInfo val CollectInfo : bool -> TType list -> TyparConstraintsWithTypars -> TypeSimplificationInfo diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index 56413a3047d..6bdf562be6b 100755 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -2063,7 +2063,7 @@ module GeneralizationHelpers = for ftp in ftps do acc.Add(ftp) - Zset.Create(typarOrder, acc) + acc |> Set.ofSeq let ComputeUnabstractableTycons env = @@ -2153,7 +2153,7 @@ module GeneralizationHelpers = // Do not generalize type variables which would escape their scope // because they are free in the environment let generalizedTypars, ungeneralizableTypars2 = - List.partition (fun x -> not (Zset.contains x freeInEnv)) generalizedTypars + List.partition (fun x -> not (SetCustom.contains x freeInEnv)) generalizedTypars // Some situations, e.g. implicit class constructions that represent functions as fields, // do not allow generalisation over constrained typars. (since they can not be represented as fields) @@ -2167,7 +2167,7 @@ module GeneralizationHelpers = generalizedTypars, freeInEnv else let freeInEnv = - unionFreeTypars + Set.union (accFreeInTypars CollectAllNoCaching ungeneralizableTypars1 (accFreeInTypars CollectAllNoCaching ungeneralizableTypars2 (accFreeInTypars CollectAllNoCaching ungeneralizableTypars3 emptyFreeTyvars))).FreeTypars @@ -2261,7 +2261,7 @@ module GeneralizationHelpers = allDeclaredTypars |> List.iter (fun tp -> - if Zset.memberOf freeInEnv tp then + if SetCustom.memberOf freeInEnv tp then let ty = mkTyparTy tp error(Error(FSComp.SR.tcNotSufficientlyGenericBecauseOfScope(NicePrint.prettyStringOfTy denv ty), m))) @@ -10977,7 +10977,7 @@ and ApplyTypesFromArgumentPatterns (cenv, env, optArgsOK, ty, m, tpenv, Normaliz /// Do the type annotations give the full and complete generic type? If so, enable generic recursion and ComputeIsComplete enclosingDeclaredTypars declaredTypars ty = - Zset.isEmpty (List.fold (fun acc v -> Zset.remove v acc) + SetCustom.isEmpty (List.fold (fun acc v -> SetCustom.remove v acc) (freeInType CollectAllNoCaching ty).FreeTypars (enclosingDeclaredTypars@declaredTypars)) @@ -11588,14 +11588,14 @@ and TcIncrementalLetRecGeneralization cenv scopem //printfn "(failed generalization test 1 for binding for %s)" pgrbind.RecBindingInfo.Val.DisplayName // Any declared type parameters in an type are always generalizable - let freeInBinding = Zset.diff freeInBinding (Zset.ofList typarOrder (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.ExtraGeneralizableTypars)) + let freeInBinding = SetCustom.diff freeInBinding (SetCustom.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.ExtraGeneralizableTypars)) if freeInBinding.IsEmpty then true else //printfn "(failed generalization test 2 for binding for %s)" pgrbind.RecBindingInfo.Val.DisplayName // Any declared method parameters can always be generalized - let freeInBinding = Zset.diff freeInBinding (Zset.ofList typarOrder (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.RecBindingInfo.DeclaredTypars)) + let freeInBinding = SetCustom.diff freeInBinding (SetCustom.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.RecBindingInfo.DeclaredTypars)) if freeInBinding.IsEmpty then true else @@ -11603,14 +11603,14 @@ and TcIncrementalLetRecGeneralization cenv scopem // Type variables free in the non-recursive environment do not stop us generalizing the binding, // since they can't be generalized anyway - let freeInBinding = Zset.diff freeInBinding freeInEnv + let freeInBinding = SetCustom.diff freeInBinding freeInEnv if freeInBinding.IsEmpty then true else //printfn "(failed generalization test 4 for binding for %s)" pgrbind.RecBindingInfo.Val.DisplayName // Type variables free in unchecked bindings do stop us generalizing - let freeInBinding = Zset.inter (freeInFrozenAndLaterBindings.Force().FreeTypars) freeInBinding + let freeInBinding = SetCustom.inter (freeInFrozenAndLaterBindings.Force().FreeTypars) freeInBinding if freeInBinding.IsEmpty then true else @@ -11651,9 +11651,9 @@ and TcIncrementalLetRecGeneralization cenv scopem freeInEnv else let freeInBinding = (freeInType CollectAllNoCaching pgrbind.RecBindingInfo.Val.TauType).FreeTypars - let freeInBinding = Zset.diff freeInBinding (Zset.ofList typarOrder (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.ExtraGeneralizableTypars)) - let freeInBinding = Zset.diff freeInBinding (Zset.ofList typarOrder (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.RecBindingInfo.DeclaredTypars)) - Zset.union freeInBinding freeInEnv) + let freeInBinding = SetCustom.diff freeInBinding (SetCustom.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.ExtraGeneralizableTypars)) + let freeInBinding = SetCustom.diff freeInBinding (SetCustom.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.RecBindingInfo.DeclaredTypars)) + Set.union freeInBinding freeInEnv) // Process the bindings marked for transition from PreGeneralization --> PostGeneralization let newGeneralizedRecBinds, tpenv = @@ -11686,7 +11686,7 @@ and TcIncrementalLetRecGeneralization cenv scopem /// Compute the type variables which may be generalized and perform the generalization and TcLetrecComputeAndGeneralizeGenericTyparsForBinding cenv denv freeInEnv (pgrbind : PreGeneralizationRecursiveBinding) = - let freeInEnv = Zset.diff freeInEnv (Zset.ofList typarOrder (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.ExtraGeneralizableTypars)) + let freeInEnv = SetCustom.diff freeInEnv (SetCustom.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.ExtraGeneralizableTypars)) let rbinfo = pgrbind.RecBindingInfo let vspec = rbinfo.Val @@ -13843,7 +13843,7 @@ module MutRecBindingChecking = if not (isNil allExtraGeneralizableTypars) then let freeInInitialEnv = GeneralizationHelpers.ComputeUngeneralizableTypars envInitial for extraTypar in allExtraGeneralizableTypars do - if Zset.memberOf freeInInitialEnv extraTypar then + if SetCustom.memberOf freeInInitialEnv extraTypar then let ty = mkTyparTy extraTypar error(Error(FSComp.SR.tcNotSufficientlyGenericBecauseOfScope(NicePrint.prettyStringOfTy denv ty), extraTypar.Range)) @@ -13875,9 +13875,9 @@ module MutRecBindingChecking = unsolvedTypars |> List.filter (fun tp -> let freeInTypar = (freeInType CollectAllNoCaching (mkTyparTy tp)).FreeTypars // Check it is not one of the generalized variables... - not (genSet.Contains tp) && + not (genSet |> SetCustom.contains tp) && // Check it involves a generalized variable in one of its constraints... - freeInTypar.Exists(fun otherTypar -> genSet.Contains otherTypar)) + freeInTypar |> SetCustom.exists (fun otherTypar -> genSet |> SetCustom.contains otherTypar)) //printfn "unsolvedTyparsInvolvingGeneralizedVariables.Length = %d" unsolvedTyparsInvolvingGeneralizedVariables.Length //for x in unsolvedTypars do // printfn "unsolvedTyparsInvolvingGeneralizedVariable : %s #%d" x.DisplayName x.Stamp @@ -17148,7 +17148,7 @@ let CheckValueRestriction denvAtEnd rootSigOpt implFileTypePriorToSig m = if Option.isNone rootSigOpt then let rec check (mty:ModuleOrNamespaceType) = for v in mty.AllValsAndMembers do - let ftyvs = (freeInVal CollectTyparsNoCaching v).FreeTypars |> Zset.elements + let ftyvs = (freeInVal CollectTyparsNoCaching v).FreeTypars |> SetCustom.elements if (not v.IsCompilerGenerated && not (ftyvs |> List.exists (fun tp -> tp.IsFromError)) && // Do not apply the value restriction to methods and functions diff --git a/src/fsharp/TypeRelations.fs b/src/fsharp/TypeRelations.fs index 43944d7a92f..711435a6723 100755 --- a/src/fsharp/TypeRelations.fs +++ b/src/fsharp/TypeRelations.fs @@ -12,6 +12,7 @@ open Microsoft.FSharp.Compiler.Tastops open Microsoft.FSharp.Compiler.TcGlobals open Microsoft.FSharp.Compiler.Infos open Microsoft.FSharp.Compiler.PrettyNaming +open Internal.Utilities.Collections //------------------------------------------------------------------------- // a :> b without coercion based on finalized (no type variable) types @@ -209,7 +210,7 @@ let ChooseTyparSolutionsForFreeChoiceTypars g amap e = /// Only make choices for variables that are actually used in the expression let ftvs = (freeInExpr CollectTyparsNoCaching e1).FreeTyvars.FreeTypars - let tps = tps |> List.filter (Zset.memberOf ftvs) + let tps = tps |> List.filter (SetCustom.memberOf ftvs) let solutions = tps |> List.map (ChooseTyparSolution g amap) |> IterativelySubstituteTyparSolutions g tps diff --git a/src/fsharp/tast.fs b/src/fsharp/tast.fs index e266f9dee17..35182915c4c 100644 --- a/src/fsharp/tast.fs +++ b/src/fsharp/tast.fs @@ -4973,7 +4973,7 @@ and and FreeLocals = Internal.Utilities.Collections.zset /// Represents a set of free type parameters -and FreeTypars = Zset +and FreeTypars = Internal.Utilities.Collections.zset /// Represents a set of 'free' named type definitions. Used to collect the named type definitions referred to /// from a type or expression. diff --git a/src/utils/SortKey.fs b/src/utils/SortKey.fs index 1b3a2fedd3c..b5f4c1f86a7 100644 --- a/src/utils/SortKey.fs +++ b/src/utils/SortKey.fs @@ -90,11 +90,19 @@ type SetCustom<'Key>() = static member empty<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct>() : zset<'Key,'Comparer> = Set.empty> + static member inline isEmpty<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (s:zset<'Key,'Comparer>) = + Set.isEmpty s + static member ofList<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> lst : zset<'Key,'Comparer> = lst |> List.map (fun k -> {CompareObj=k}) |> Set.ofList + static member ofSeq<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> lst : zset<'Key,'Comparer> = + lst + |> Seq.map (fun k -> {CompareObj=k}) + |> Set.ofSeq + static member inline contains<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (k:'Key) (s:zset<'Key,'Comparer>) = Set.contains {CompareObj=k} s @@ -129,7 +137,23 @@ type SetCustom<'Key>() = List.fold (fun acc x -> Set.add {CompareObj=x} acc) s xs static member inline diff<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (a:zset<'Key,'Comparer>) (b:zset<'Key,'Comparer>) = - Set.fold (fun a k -> Set.remove k a) a b + if Set.isEmpty a || Set.isEmpty b then a + else Set.fold (fun a k -> Set.remove k a) a b + + static member inline inter<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (a:zset<'Key,'Comparer>) (b:zset<'Key,'Comparer>) = + Set.intersect a b + + static member inline equal<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (a:zset<'Key,'Comparer>) (b:zset<'Key,'Comparer>) = + if obj.ReferenceEquals (a,b) then true + else + let lhs = (a:>seq<_>).GetEnumerator () + let rhs = (b:>seq<_>).GetEnumerator () + let rec loop () = + match lhs.MoveNext (), rhs.MoveNext () with + | true, true when Unchecked.defaultof<'Comparer>.Compare (lhs.Current.CompareObj, rhs.Current.CompareObj) = 0 -> loop () + | false, false -> true + | _ -> false + loop () static member inline iter<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (f:'Key->unit) (m:zset<'Key,'Comparer>) = Set.iter (fun {CompareObj=k} -> f k) m From c6579fb423ad5416427f9f94dc1807d33cb2024f Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sat, 11 Aug 2018 23:30:44 +1000 Subject: [PATCH 80/92] Tycon set conversion --- src/fsharp/Optimizer.fs | 12 +++++----- src/fsharp/TastOps.fs | 46 ++++++++++++++++++--------------------- src/fsharp/TastOps.fsi | 5 ++--- src/fsharp/TypeChecker.fs | 4 ++-- src/fsharp/tast.fs | 6 ++++- 5 files changed, 36 insertions(+), 37 deletions(-) diff --git a/src/fsharp/Optimizer.fs b/src/fsharp/Optimizer.fs index bc0c034ed56..4435906918d 100644 --- a/src/fsharp/Optimizer.fs +++ b/src/fsharp/Optimizer.fs @@ -974,8 +974,8 @@ let AbstractLazyModulInfoByHiding isAssemblyBoundary mhi = // Under those checks, the further hidden* checks may be subsumed (meaning, not required anymore). let hiddenTycon, hiddenTyconRepr, hiddenVal, hiddenRecdField, hiddenUnionCase = - Zset.memberOf mhi.mhiTycons, - Zset.memberOf mhi.mhiTyconReprs, + SetCustom.memberOf mhi.mhiTycons, + SetCustom.memberOf mhi.mhiTyconReprs, SetCustom.memberOf mhi.mhiVals, Zset.memberOf mhi.mhiRecdFields, Zset.memberOf mhi.mhiUnionCases @@ -989,7 +989,7 @@ let AbstractLazyModulInfoByHiding isAssemblyBoundary mhi = let tyvars = freeInVal CollectAll v2 if (isAssemblyBoundary && not (freeTyvarsAllPublic tyvars)) || - Zset.exists hiddenTycon tyvars.FreeTycons || + SetCustom.exists hiddenTycon tyvars.FreeTycons || hiddenVal v2 then detail' else ValValue (vref2, detail') @@ -998,8 +998,8 @@ let AbstractLazyModulInfoByHiding isAssemblyBoundary mhi = (let fvs = freeInExpr CollectAll expr (isAssemblyBoundary && not (freeVarsAllPublic fvs)) || SetCustom.exists hiddenVal fvs.FreeLocals || - Zset.exists hiddenTycon fvs.FreeTyvars.FreeTycons || - Zset.exists hiddenTyconRepr fvs.FreeLocalTyconReprs || + SetCustom.exists hiddenTycon fvs.FreeTyvars.FreeTycons || + SetCustom.exists hiddenTyconRepr fvs.FreeLocalTyconReprs || Zset.exists hiddenRecdField fvs.FreeRecdFields || Zset.exists hiddenUnionCase fvs.FreeUnionCases ) -> UnknownValue @@ -1007,7 +1007,7 @@ let AbstractLazyModulInfoByHiding isAssemblyBoundary mhi = | ConstValue(_, ty) when (let ftyvs = freeInType CollectAll ty (isAssemblyBoundary && not (freeTyvarsAllPublic ftyvs)) || - Zset.exists hiddenTycon ftyvs.FreeTycons) -> + SetCustom.exists hiddenTycon ftyvs.FreeTycons) -> UnknownValue | TupleValue vinfos -> TupleValue (Array.map abstractExprInfo vinfos) diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index 2dbe8702c1c..1aef1ad9b44 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -1849,11 +1849,7 @@ let unionFreeUnionCases s1 s2 = elif s2 === emptyFreeUnionCases then s1 else Zset.union s1 s2 -let emptyFreeTycons = Zset.empty tyconOrder -let unionFreeTycons s1 s2 = - if s1 === emptyFreeTycons then s2 - elif s2 === emptyFreeTycons then s1 - else Zset.union s1 s2 +let emptyFreeTycons = SetCustom.empty () let emptyFreeTypars = SetCustom.empty () @@ -1865,12 +1861,12 @@ let emptyFreeTyvars = let isEmptyFreeTyvars ftyvs = SetCustom.isEmpty ftyvs.FreeTypars && - Zset.isEmpty ftyvs.FreeTycons + SetCustom.isEmpty ftyvs.FreeTycons let unionFreeTyvars fvs1 fvs2 = if fvs1 === emptyFreeTyvars then fvs2 else if fvs2 === emptyFreeTyvars then fvs1 else - { FreeTycons = unionFreeTycons fvs1.FreeTycons fvs2.FreeTycons + { FreeTycons = Set.union fvs1.FreeTycons fvs2.FreeTycons FreeTraitSolutions = Set.union fvs1.FreeTraitSolutions fvs2.FreeTraitSolutions FreeTypars = Set.union fvs1.FreeTypars fvs2.FreeTypars } @@ -1952,8 +1948,8 @@ let CollectLocals = CollectTyparsAndLocals let accFreeLocalTycon opts x acc = if not opts.includeLocalTycons then acc else - if Zset.contains x acc.FreeTycons then acc else - { acc with FreeTycons = Zset.add x acc.FreeTycons } + if SetCustom.contains x acc.FreeTycons then acc else + { acc with FreeTycons = SetCustom.add x acc.FreeTycons } let accFreeTycon opts (tcr:TyconRef) acc = if not opts.includeLocalTycons then acc @@ -3805,15 +3801,15 @@ type SignatureRepackageInfo = static member Empty = { mrpiVals = []; mrpiEntities= [] } type SignatureHidingInfo = - { mhiTycons : Zset; - mhiTyconReprs : Zset; + { mhiTycons : zset; + mhiTyconReprs : zset; mhiVals : zset mhiRecdFields : Zset; mhiUnionCases : Zset } static member Empty = - { mhiTycons = Zset.empty tyconOrder; - mhiTyconReprs = Zset.empty tyconOrder; + { mhiTycons = SetCustom.empty () + mhiTyconReprs = SetCustom.empty () mhiVals = SetCustom.empty () mhiRecdFields = Zset.empty recdFieldRefOrder; mhiUnionCases = Zset.empty unionCaseRefOrder } @@ -3836,7 +3832,7 @@ let accEntityRemap (msigty:ModuleOrNamespaceType) (entity:Entity) (mrpi, mhi) = match sigtyconOpt with | None -> // The type constructor is not present in the signature. Hence it is hidden. - let mhi = { mhi with mhiTycons = Zset.add entity mhi.mhiTycons } + let mhi = { mhi with mhiTycons = SetCustom.add entity mhi.mhiTycons } (mrpi, mhi) | Some sigtycon -> // The type constructor is in the signature. Hence record the repackage entry @@ -3847,7 +3843,7 @@ let accEntityRemap (msigty:ModuleOrNamespaceType) (entity:Entity) (mrpi, mhi) = let mhi = if (match entity.TypeReprInfo with TNoRepr -> false | _ -> true) && (match sigtycon.TypeReprInfo with TNoRepr -> true | _ -> false) then // The type representation is absent in the signature, hence it is hidden - { mhi with mhiTyconReprs = Zset.add entity mhi.mhiTyconReprs } + { mhi with mhiTyconReprs = SetCustom.add entity mhi.mhiTyconReprs } else // The type representation is present in the signature. // Find the fields that have been hidden or which were non-public anyway. @@ -3879,7 +3875,7 @@ let accSubEntityRemap (msigty:ModuleOrNamespaceType) (entity:Entity) (mrpi, mhi) match sigtyconOpt with | None -> // The type constructor is not present in the signature. Hence it is hidden. - let mhi = { mhi with mhiTycons = Zset.add entity mhi.mhiTycons } + let mhi = { mhi with mhiTycons = SetCustom.add entity mhi.mhiTycons } (mrpi, mhi) | Some sigtycon -> // The type constructor is in the signature. Hence record the repackage entry @@ -4001,9 +3997,9 @@ let ComputeRemappingFromImplementationToSignature g mdef msigty = let accTyconHidingInfoAtAssemblyBoundary (tycon:Tycon) mhi = if not (canAccessFromEverywhere tycon.Accessibility) then // The type constructor is not public, hence hidden at the assembly boundary. - { mhi with mhiTycons = Zset.add tycon mhi.mhiTycons } + { mhi with mhiTycons = SetCustom.add tycon mhi.mhiTycons } elif not (canAccessFromEverywhere tycon.TypeReprAccessibility) then - { mhi with mhiTyconReprs = Zset.add tycon mhi.mhiTyconReprs } + { mhi with mhiTyconReprs = SetCustom.add tycon mhi.mhiTyconReprs } else mhi |> Array.foldBack @@ -4086,8 +4082,8 @@ let IsHidden' setF accessF remapF debugF = if verbose then dprintf "IsHidden, #mrmi = %d, %s = %b\n" mrmi.Length (showL (debugF x)) res; res -let IsHiddenTycon mrmi x = IsHidden (fun mhi -> mhi.mhiTycons) (fun tc -> tc.Accessibility) (fun rpi x -> (remapTyconRef rpi.tyconRefRemap (mkLocalTyconRef x)).Deref) DebugPrint.tyconL mrmi x -let IsHiddenTyconRepr mrmi x = IsHidden (fun mhi -> mhi.mhiTyconReprs) (fun v -> v.TypeReprAccessibility) (fun rpi x -> (remapTyconRef rpi.tyconRefRemap (mkLocalTyconRef x)).Deref) DebugPrint.tyconL mrmi x +let IsHiddenTycon mrmi x = IsHidden' (fun mhi -> mhi.mhiTycons) (fun tc -> tc.Accessibility) (fun rpi x -> (remapTyconRef rpi.tyconRefRemap (mkLocalTyconRef x)).Deref) DebugPrint.tyconL mrmi x +let IsHiddenTyconRepr mrmi x = IsHidden' (fun mhi -> mhi.mhiTyconReprs) (fun v -> v.TypeReprAccessibility) (fun rpi x -> (remapTyconRef rpi.tyconRefRemap (mkLocalTyconRef x)).Deref) DebugPrint.tyconL mrmi x let IsHiddenVal mrmi x = IsHidden' (fun mhi -> mhi.mhiVals) (fun v -> v.Accessibility) (fun rpi x -> (remapValRef rpi (mkLocalValRef x)).Deref) DebugPrint.valL mrmi x let IsHiddenRecdField mrmi x = IsHidden (fun mhi -> mhi.mhiRecdFields) (fun rfref -> rfref.RecdField.Accessibility) (fun rpi x -> remapRecdFieldRef rpi.tyconRefRemap x) DebugPrint.recdFieldRefL mrmi x @@ -4131,10 +4127,10 @@ let freeVarsAllPublic fvs = SetCustom.forall isPublicVal fvs.FreeLocals && Zset.forall isPublicUnionCase fvs.FreeUnionCases && Zset.forall isPublicRecdField fvs.FreeRecdFields && - Zset.forall isPublicTycon fvs.FreeTyvars.FreeTycons + SetCustom.forall isPublicTycon fvs.FreeTyvars.FreeTycons let freeTyvarsAllPublic tyvars = - Zset.forall isPublicTycon tyvars.FreeTycons + SetCustom.forall isPublicTycon tyvars.FreeTycons // Detect the subset of match expressions we treat in a linear way @@ -4170,7 +4166,7 @@ let unionFreeVars fvs1 fvs2 = FreeTyvars = unionFreeTyvars fvs1.FreeTyvars fvs2.FreeTyvars; UsesMethodLocalConstructs = fvs1.UsesMethodLocalConstructs || fvs2.UsesMethodLocalConstructs; UsesUnboundRethrow = fvs1.UsesUnboundRethrow || fvs2.UsesUnboundRethrow; - FreeLocalTyconReprs = unionFreeTycons fvs1.FreeLocalTyconReprs fvs2.FreeLocalTyconReprs; + FreeLocalTyconReprs = Set.union fvs1.FreeLocalTyconReprs fvs2.FreeLocalTyconReprs; FreeRecdFields = unionFreeRecdFields fvs1.FreeRecdFields fvs2.FreeRecdFields; FreeUnionCases = unionFreeUnionCases fvs1.FreeUnionCases fvs2.FreeUnionCases; } @@ -4262,8 +4258,8 @@ and accFreeLocalVal opts v fvs = and accLocalTyconRepr opts b fvs = if not opts.includeLocalTyconReprs then fvs else - if Zset.contains b fvs.FreeLocalTyconReprs then fvs - else { fvs with FreeLocalTyconReprs = Zset.add b fvs.FreeLocalTyconReprs } + if SetCustom.contains b fvs.FreeLocalTyconReprs then fvs + else { fvs with FreeLocalTyconReprs = SetCustom.add b fvs.FreeLocalTyconReprs } and accUsedRecdOrUnionTyconRepr opts (tc:Tycon) fvs = if match tc.TypeReprInfo with TFSharpObjectRepr _ | TRecdRepr _ | TUnionRepr _ -> true | _ -> false diff --git a/src/fsharp/TastOps.fsi b/src/fsharp/TastOps.fsi index 7ea511fc1ca..2f049f500f1 100755 --- a/src/fsharp/TastOps.fsi +++ b/src/fsharp/TastOps.fsi @@ -560,7 +560,6 @@ val applyTys : TcGlobals -> TType -> TType list * 'T list -> TType val emptyFreeTypars : FreeTypars val emptyFreeTycons : FreeTycons -val unionFreeTycons : FreeTycons -> FreeTycons -> FreeTycons val emptyFreeTyvars : FreeTyvars val isEmptyFreeTyvars : FreeTyvars -> bool @@ -855,8 +854,8 @@ type SignatureRepackageInfo = static member Empty : SignatureRepackageInfo type SignatureHidingInfo = - { mhiTycons : Zset; - mhiTyconReprs : Zset; + { mhiTycons : zset + mhiTyconReprs : zset mhiVals : zset mhiRecdFields : Zset; mhiUnionCases : Zset } diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index 6bdf562be6b..e4c9bb0c3c6 100755 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -2072,7 +2072,7 @@ module GeneralizationHelpers = if item.WillNeverHaveFreeTypars then item.CachedFreeLocalTycons else let ftyvs = item.GetFreeTyvars() ftyvs.FreeTycons - if ftycs.IsEmpty then acc else unionFreeTycons ftycs acc + if ftycs.IsEmpty then acc else Set.union ftycs acc List.fold acc_in_free_item emptyFreeTycons env.eUngeneralizableItems @@ -16688,7 +16688,7 @@ let ElimModuleDoBinding bind = let TcMutRecDefnsEscapeCheck (binds: MutRecShapes<_, _, _, _, _>) env = let freeInEnv = GeneralizationHelpers.ComputeUnabstractableTycons env let checkTycon (tycon: Tycon) = - if not tycon.IsTypeAbbrev && Zset.contains tycon freeInEnv then + if not tycon.IsTypeAbbrev && SetCustom.contains tycon freeInEnv then let nm = tycon.DisplayName errorR(Error(FSComp.SR.tcTypeUsedInInvalidWay(nm, nm, nm), tycon.Range)) diff --git a/src/fsharp/tast.fs b/src/fsharp/tast.fs index 35182915c4c..bf21e9cb43b 100644 --- a/src/fsharp/tast.fs +++ b/src/fsharp/tast.fs @@ -1933,6 +1933,10 @@ and [] and ModuleOrNamespace = Entity and Tycon = Entity +and [] TyconByStamp = + interface IComparer with + member __.Compare(v1, v2) = + compare v1.Stamp v2.Stamp /// A set of static methods for constructing types. and Construct = @@ -4977,7 +4981,7 @@ and FreeTypars = Internal.Utilities.Collections.zset /// Represents a set of 'free' named type definitions. Used to collect the named type definitions referred to /// from a type or expression. -and FreeTycons = Zset +and FreeTycons = Internal.Utilities.Collections.zset /// Represents a set of 'free' record field definitions. Used to collect the record field definitions referred to /// from an expression. From 204f2b3cacdabe623316e04d56ec9c40f7acd1bd Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sun, 12 Aug 2018 06:09:09 +1000 Subject: [PATCH 81/92] Final two Zset orderers converted --- src/fsharp/InnerLambdasToTopLevelFuncs.fs | 6 +- src/fsharp/Optimizer.fs | 8 +- src/fsharp/TastOps.fs | 94 ++++++----------------- src/fsharp/TastOps.fsi | 12 +-- src/fsharp/TypeChecker.fs | 2 +- src/fsharp/symbols/Symbols.fs | 2 +- src/fsharp/tast.fs | 40 ++++++++-- 7 files changed, 65 insertions(+), 99 deletions(-) diff --git a/src/fsharp/InnerLambdasToTopLevelFuncs.fs b/src/fsharp/InnerLambdasToTopLevelFuncs.fs index 3c4e09b2a19..21365b3c704 100644 --- a/src/fsharp/InnerLambdasToTopLevelFuncs.fs +++ b/src/fsharp/InnerLambdasToTopLevelFuncs.fs @@ -304,7 +304,7 @@ type BindingGroupSharingSameReqdItems(bindings: Bindings) = override fclass.ToString() = "+" + String.concat "+" (List.map nameOfVal vals) -let fclassOrder = Order.orderOn (fun (b: BindingGroupSharingSameReqdItems) -> b.Vals) (List.order valOrder) +let fclassOrder = Order.orderOn (fun (b: BindingGroupSharingSameReqdItems) -> b.Vals) (List.order (ValByStamp ())) [] type BindingGroupSharingSameReqdItemsByVals = @@ -329,7 +329,7 @@ let reqdItemOrder = | ReqdSubEnv v -> true ,v | ReqdVal v -> false,v - Order.orderOn rep (Pair.order (Bool.order,valOrder)) + Order.orderOn rep (Pair.order (Bool.order, (ValByStamp ()))) /// An env says what is needed to close the corresponding defn(s). /// The reqdTypars are the free reqdTypars of the defns, and those required by any direct TLR arity-met calls. @@ -698,7 +698,7 @@ let FlatEnvPacks g fclassM topValS declist (reqdItemsMap: zmap List.filter (IsMandatoryTopLevel >> not) diff --git a/src/fsharp/Optimizer.fs b/src/fsharp/Optimizer.fs index 4435906918d..7f189636529 100644 --- a/src/fsharp/Optimizer.fs +++ b/src/fsharp/Optimizer.fs @@ -977,8 +977,8 @@ let AbstractLazyModulInfoByHiding isAssemblyBoundary mhi = SetCustom.memberOf mhi.mhiTycons, SetCustom.memberOf mhi.mhiTyconReprs, SetCustom.memberOf mhi.mhiVals, - Zset.memberOf mhi.mhiRecdFields, - Zset.memberOf mhi.mhiUnionCases + SetCustom.memberOf mhi.mhiRecdFields, + SetCustom.memberOf mhi.mhiUnionCases let rec abstractExprInfo ivalue = match ivalue with @@ -1000,8 +1000,8 @@ let AbstractLazyModulInfoByHiding isAssemblyBoundary mhi = SetCustom.exists hiddenVal fvs.FreeLocals || SetCustom.exists hiddenTycon fvs.FreeTyvars.FreeTycons || SetCustom.exists hiddenTyconRepr fvs.FreeLocalTyconReprs || - Zset.exists hiddenRecdField fvs.FreeRecdFields || - Zset.exists hiddenUnionCase fvs.FreeUnionCases ) -> + SetCustom.exists hiddenRecdField fvs.FreeRecdFields || + SetCustom.exists hiddenUnionCase fvs.FreeUnionCases ) -> UnknownValue // Check for escape in constant | ConstValue(_, ty) when diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index 1aef1ad9b44..09b8077ab5e 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -1019,27 +1019,6 @@ let rec getErasedTypes g ty = | TType_measure _ -> [ty] - -//--------------------------------------------------------------------------- -// Standard orderings, e.g. for order set/map keys -//--------------------------------------------------------------------------- - -let valOrder = { new IComparer with member __.Compare(v1, v2) = compare v1.Stamp v2.Stamp } -let tyconOrder = { new IComparer with member __.Compare(tc1, tc2) = compare tc1.Stamp tc2.Stamp } -let recdFieldRefOrder = - { new IComparer with - member __.Compare(RFRef(tcref1, nm1), RFRef(tcref2, nm2)) = - let c = tyconOrder.Compare (tcref1.Deref, tcref2.Deref) - if c <> 0 then c else - compare nm1 nm2 } - -let unionCaseRefOrder = - { new IComparer with - member __.Compare(UCRef(tcref1, nm1), UCRef(tcref2, nm2)) = - let c = tyconOrder.Compare (tcref1.Deref, tcref2.Deref) - if c <> 0 then c else - compare nm1 nm2 } - //--------------------------------------------------------------------------- // Make some common types //--------------------------------------------------------------------------- @@ -1836,21 +1815,9 @@ let ValRefIsExplicitImpl g (vref:ValRef) = ValIsExplicitImpl g vref.Deref //--------------------------------------------------------------------------- let emptyFreeLocals = SetCustom.empty () - -let emptyFreeRecdFields = Zset.empty recdFieldRefOrder -let unionFreeRecdFields s1 s2 = - if s1 === emptyFreeRecdFields then s2 - elif s2 === emptyFreeRecdFields then s1 - else Zset.union s1 s2 - -let emptyFreeUnionCases = Zset.empty unionCaseRefOrder -let unionFreeUnionCases s1 s2 = - if s1 === emptyFreeUnionCases then s2 - elif s2 === emptyFreeUnionCases then s1 - else Zset.union s1 s2 - +let emptyFreeRecdFields = SetCustom.empty () +let emptyFreeUnionCases = SetCustom.empty () let emptyFreeTycons = SetCustom.empty () - let emptyFreeTypars = SetCustom.empty () let emptyFreeTyvars = @@ -3804,15 +3771,15 @@ type SignatureHidingInfo = { mhiTycons : zset; mhiTyconReprs : zset; mhiVals : zset - mhiRecdFields : Zset; - mhiUnionCases : Zset } + mhiRecdFields : zset; + mhiUnionCases : zset } static member Empty = { mhiTycons = SetCustom.empty () mhiTyconReprs = SetCustom.empty () mhiVals = SetCustom.empty () - mhiRecdFields = Zset.empty recdFieldRefOrder; - mhiUnionCases = Zset.empty unionCaseRefOrder } + mhiRecdFields = SetCustom.empty () + mhiUnionCases = SetCustom.empty () } let addValRemap v v' tmenv = { tmenv with valRemap= tmenv.valRemap.Add v (mkLocalValRef v') } @@ -3856,7 +3823,7 @@ let accEntityRemap (msigty:ModuleOrNamespaceType) (entity:Entity) (mrpi, mhi) = | _ -> // The field is not in the signature. Hence it is regarded as hidden. let rfref = tcref.MakeNestedRecdFieldRef rfield - { mhi with mhiRecdFields = Zset.add rfref mhi.mhiRecdFields }) + { mhi with mhiRecdFields = SetCustom.add rfref mhi.mhiRecdFields }) entity.AllFieldsArray |> List.foldBack (fun (ucase:UnionCase) mhi -> match sigtycon.GetUnionCaseByName ucase.DisplayName with @@ -3866,7 +3833,7 @@ let accEntityRemap (msigty:ModuleOrNamespaceType) (entity:Entity) (mrpi, mhi) = | _ -> // The constructor is not in the signature. Hence it is regarded as hidden. let ucref = tcref.MakeNestedUnionCaseRef ucase - { mhi with mhiUnionCases = Zset.add ucref mhi.mhiUnionCases }) + { mhi with mhiUnionCases = SetCustom.add ucref mhi.mhiUnionCases }) (entity.UnionCasesAsList) (mrpi, mhi) @@ -4007,7 +3974,7 @@ let accTyconHidingInfoAtAssemblyBoundary (tycon:Tycon) mhi = if not (canAccessFromEverywhere rfield.Accessibility) then let tcref = mkLocalTyconRef tycon let rfref = tcref.MakeNestedRecdFieldRef rfield - { mhi with mhiRecdFields = Zset.add rfref mhi.mhiRecdFields } + { mhi with mhiRecdFields = SetCustom.add rfref mhi.mhiRecdFields } else mhi) tycon.AllFieldsArray |> List.foldBack @@ -4015,7 +3982,7 @@ let accTyconHidingInfoAtAssemblyBoundary (tycon:Tycon) mhi = if not (canAccessFromEverywhere ucase.Accessibility) then let tcref = mkLocalTyconRef tycon let ucref = tcref.MakeNestedUnionCaseRef ucase - { mhi with mhiUnionCases = Zset.add ucref mhi.mhiUnionCases } + { mhi with mhiUnionCases = SetCustom.add ucref mhi.mhiUnionCases } else mhi) (tycon.UnionCasesAsList) @@ -4047,25 +4014,8 @@ let ComputeHidingInfoAtAssemblyBoundary mty acc = //-------------------------------------------------------------------------- // Compute instances of the above for mexpr -> mty //-------------------------------------------------------------------------- - -let IsHidden setF accessF remapF debugF = - let rec check mrmi x = - if verbose then dprintf "IsHidden %s ??\n" (showL (debugF x)); - // Internal/private? - not (canAccessFromEverywhere (accessF x)) || - (match mrmi with - | [] -> false // Ah! we escaped to freedom! - | (rpi, mhi) :: rest -> - // Explicitly hidden? - Zset.contains x (setF mhi) || - // Recurse... - check rest (remapF rpi x)) - fun mrmi x -> - let res = check mrmi x - if verbose then dprintf "IsHidden, #mrmi = %d, %s = %b\n" mrmi.Length (showL (debugF x)) res; - res -let IsHidden' setF accessF remapF debugF = +let IsHidden setF accessF remapF debugF = let rec check mrmi x = if verbose then dprintf "IsHidden %s ??\n" (showL (debugF x)); // Internal/private? @@ -4082,9 +4032,9 @@ let IsHidden' setF accessF remapF debugF = if verbose then dprintf "IsHidden, #mrmi = %d, %s = %b\n" mrmi.Length (showL (debugF x)) res; res -let IsHiddenTycon mrmi x = IsHidden' (fun mhi -> mhi.mhiTycons) (fun tc -> tc.Accessibility) (fun rpi x -> (remapTyconRef rpi.tyconRefRemap (mkLocalTyconRef x)).Deref) DebugPrint.tyconL mrmi x -let IsHiddenTyconRepr mrmi x = IsHidden' (fun mhi -> mhi.mhiTyconReprs) (fun v -> v.TypeReprAccessibility) (fun rpi x -> (remapTyconRef rpi.tyconRefRemap (mkLocalTyconRef x)).Deref) DebugPrint.tyconL mrmi x -let IsHiddenVal mrmi x = IsHidden' (fun mhi -> mhi.mhiVals) (fun v -> v.Accessibility) (fun rpi x -> (remapValRef rpi (mkLocalValRef x)).Deref) DebugPrint.valL mrmi x +let IsHiddenTycon mrmi x = IsHidden (fun mhi -> mhi.mhiTycons) (fun tc -> tc.Accessibility) (fun rpi x -> (remapTyconRef rpi.tyconRefRemap (mkLocalTyconRef x)).Deref) DebugPrint.tyconL mrmi x +let IsHiddenTyconRepr mrmi x = IsHidden (fun mhi -> mhi.mhiTyconReprs) (fun v -> v.TypeReprAccessibility) (fun rpi x -> (remapTyconRef rpi.tyconRefRemap (mkLocalTyconRef x)).Deref) DebugPrint.tyconL mrmi x +let IsHiddenVal mrmi x = IsHidden (fun mhi -> mhi.mhiVals) (fun v -> v.Accessibility) (fun rpi x -> (remapValRef rpi (mkLocalValRef x)).Deref) DebugPrint.valL mrmi x let IsHiddenRecdField mrmi x = IsHidden (fun mhi -> mhi.mhiRecdFields) (fun rfref -> rfref.RecdField.Accessibility) (fun rpi x -> remapRecdFieldRef rpi.tyconRefRemap x) DebugPrint.recdFieldRefL mrmi x @@ -4125,8 +4075,8 @@ let freeVarsAllPublic fvs = // CODEREVIEW: // What about non-local vals. This fix assumes non-local vals must be public. OK? SetCustom.forall isPublicVal fvs.FreeLocals && - Zset.forall isPublicUnionCase fvs.FreeUnionCases && - Zset.forall isPublicRecdField fvs.FreeRecdFields && + SetCustom.forall isPublicUnionCase fvs.FreeUnionCases && + SetCustom.forall isPublicRecdField fvs.FreeRecdFields && SetCustom.forall isPublicTycon fvs.FreeTyvars.FreeTycons let freeTyvarsAllPublic tyvars = @@ -4167,8 +4117,8 @@ let unionFreeVars fvs1 fvs2 = UsesMethodLocalConstructs = fvs1.UsesMethodLocalConstructs || fvs2.UsesMethodLocalConstructs; UsesUnboundRethrow = fvs1.UsesUnboundRethrow || fvs2.UsesUnboundRethrow; FreeLocalTyconReprs = Set.union fvs1.FreeLocalTyconReprs fvs2.FreeLocalTyconReprs; - FreeRecdFields = unionFreeRecdFields fvs1.FreeRecdFields fvs2.FreeRecdFields; - FreeUnionCases = unionFreeUnionCases fvs1.FreeUnionCases fvs2.FreeUnionCases; } + FreeRecdFields = Set.union fvs1.FreeRecdFields fvs2.FreeRecdFields; + FreeUnionCases = Set.union fvs1.FreeUnionCases fvs2.FreeUnionCases; } let inline accFreeTyvars (opts:FreeVarOptions) f v acc = if not opts.collectInTypes then acc else @@ -4268,19 +4218,19 @@ and accUsedRecdOrUnionTyconRepr opts (tc:Tycon) fvs = and accFreeUnionCaseRef opts cr fvs = if not opts.includeUnionCases then fvs else - if Zset.contains cr fvs.FreeUnionCases then fvs + if SetCustom.contains cr fvs.FreeUnionCases then fvs else let fvs = fvs |> accUsedRecdOrUnionTyconRepr opts cr.Tycon let fvs = fvs |> accFreevarsInTycon opts cr.TyconRef - { fvs with FreeUnionCases = Zset.add cr fvs.FreeUnionCases } + { fvs with FreeUnionCases = SetCustom.add cr fvs.FreeUnionCases } and accFreeRecdFieldRef opts rfref fvs = if not opts.includeRecdFields then fvs else - if Zset.contains rfref fvs.FreeRecdFields then fvs + if SetCustom.contains rfref fvs.FreeRecdFields then fvs else let fvs = fvs |> accUsedRecdOrUnionTyconRepr opts rfref.Tycon let fvs = fvs |> accFreevarsInTycon opts rfref.TyconRef - { fvs with FreeRecdFields = Zset.add rfref fvs.FreeRecdFields } + { fvs with FreeRecdFields = SetCustom.add rfref fvs.FreeRecdFields } and accFreeExnRef _exnc fvs = fvs // Note: this exnc (TyconRef) should be collected the surround types, e.g. tinst of Expr.Op and accFreeValRef opts (vref:ValRef) fvs = diff --git a/src/fsharp/TastOps.fsi b/src/fsharp/TastOps.fsi index 2f049f500f1..e228cec2cec 100755 --- a/src/fsharp/TastOps.fsi +++ b/src/fsharp/TastOps.fsi @@ -375,14 +375,6 @@ type TyconRefMultiMap<'T> = static member OfList : (TyconRef * 'T) list -> TyconRefMultiMap<'T> -//------------------------------------------------------------------------- -// Orderings on Tycon, Val, RecdFieldRef, Typar -//------------------------------------------------------------------------- - -val valOrder : IComparer -val tyconOrder : IComparer -val recdFieldRefOrder : IComparer - //------------------------------------------------------------------------- // Equality on Tycon and Val //------------------------------------------------------------------------- @@ -857,8 +849,8 @@ type SignatureHidingInfo = { mhiTycons : zset mhiTyconReprs : zset mhiVals : zset - mhiRecdFields : Zset; - mhiUnionCases : Zset } + mhiRecdFields : zset + mhiUnionCases : zset } static member Empty : SignatureHidingInfo val ComputeRemappingFromInferredSignatureToExplicitSignature : TcGlobals -> ModuleOrNamespaceType -> ModuleOrNamespaceType -> SignatureRepackageInfo * SignatureHidingInfo diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index e4c9bb0c3c6..3c8d9cc2a3c 100755 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -15979,7 +15979,7 @@ module TcDeclarations = else let isInSameModuleOrNamespace = match envForDecls.eModuleOrNamespaceTypeAccumulator.Value.TypesByMangledName.TryFind(tcref.LogicalName) with - | Some tycon -> (tyconOrder.Compare(tcref.Deref, tycon) = 0) + | Some tycon -> (TyconByStamp.Compare tcref.Deref tycon) = 0 | None -> //false // There is a special case we allow when compiling FSharp.Core.dll which permits interface implementations across namespace fragments diff --git a/src/fsharp/symbols/Symbols.fs b/src/fsharp/symbols/Symbols.fs index 68bdcae2f53..ce3017c7b01 100644 --- a/src/fsharp/symbols/Symbols.fs +++ b/src/fsharp/symbols/Symbols.fs @@ -999,7 +999,7 @@ and FSharpField(cenv: SymbolEnv, d: FSharpFieldData) = match other with | :? FSharpField as uc -> match d, uc.V with - | RecdOrClass r1, RecdOrClass r2 -> recdFieldRefOrder.Compare(r1, r2) = 0 + | RecdOrClass r1, RecdOrClass r2 -> (RecdFieldRefOrder.Compare r1 r2) = 0 | Union (u1, n1), Union (u2, n2) -> cenv.g.unionCaseRefEq u1 u2 && n1 = n2 | _ -> false | _ -> false diff --git a/src/fsharp/tast.fs b/src/fsharp/tast.fs index bf21e9cb43b..62c7ce765d6 100644 --- a/src/fsharp/tast.fs +++ b/src/fsharp/tast.fs @@ -1933,10 +1933,31 @@ and [] and ModuleOrNamespace = Entity and Tycon = Entity -and [] TyconByStamp = + +and [] TyconByStamp = + static member inline Compare (v1:Tycon) (v2:Tycon) = + v1.Stamp.CompareTo v2.Stamp + interface IComparer with member __.Compare(v1, v2) = - compare v1.Stamp v2.Stamp + TyconByStamp.Compare v1 v2 + +and [] RecdFieldRefOrder = + static member Compare (RFRef(tcref1, nm1)) (RFRef(tcref2, nm2)) = + let c = TyconByStamp.Compare tcref1.Deref tcref2.Deref + if c <> 0 then c else + compare nm1 nm2 + + interface IComparer with + member __.Compare (lhs, rhs) = RecdFieldRefOrder.Compare lhs rhs + +and [] UnionCaseRefOrder = + interface IComparer with + member __.Compare(UCRef(tcref1, nm1), UCRef(tcref2, nm2)) = + let c = TyconByStamp.Compare tcref1.Deref tcref2.Deref + if c <> 0 then c else + compare nm1 nm2 + /// A set of static methods for constructing types. and Construct = @@ -2283,10 +2304,10 @@ and override x.ToString() = x.Name -and [] TyparByStamp = +and [] TyparByStamp = interface IComparer with member __.Compare(v1: Typar, v2: Typar): int = - compare v1.Stamp v2.Stamp + v1.Stamp.CompareTo v2.Stamp and [] @@ -2972,10 +2993,13 @@ and [] override x.ToString() = x.LogicalName -and [] ValByStamp = +and [] ValByStamp = + static member inline Compare (v1:Val) (v2:Val) = + v1.Stamp.CompareTo v2.Stamp + interface IComparer with member __.Compare(v1, v2) = - compare v1.Stamp v2.Stamp + ValByStamp.Compare v1 v2 and /// Represents the extra information stored for a member @@ -4985,10 +5009,10 @@ and FreeTycons = Internal.Utilities.Collections.zset /// Represents a set of 'free' record field definitions. Used to collect the record field definitions referred to /// from an expression. -and FreeRecdFields = Zset +and FreeRecdFields = Internal.Utilities.Collections.zset /// Represents a set of 'free' union cases. Used to collect the union cases referred to from an expression. -and FreeUnionCases = Zset +and FreeUnionCases = Internal.Utilities.Collections.zset /// Represents a set of 'free' type-related elements, including named types, trait solutions, union cases and /// record fields. From eb0d57682603f7617f929757e117b514d73644bb Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sun, 12 Aug 2018 06:17:47 +1000 Subject: [PATCH 82/92] Added NoComparison/NoEquality to ordering objects --- src/fsharp/CompileOps.fs | 2 +- src/fsharp/InnerLambdasToTopLevelFuncs.fs | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/src/fsharp/CompileOps.fs b/src/fsharp/CompileOps.fs index 933d1b83520..2f9eeb7880b 100644 --- a/src/fsharp/CompileOps.fs +++ b/src/fsharp/CompileOps.fs @@ -5331,7 +5331,7 @@ let CheckSimulateException(tcConfig:TcConfig) = let qnameOrder = Order.orderBy (fun (q:QualifiedNameOfFile) -> q.Text) -[] +[] type QualifiedNameOfFileByText = interface System.Collections.Generic.IComparer with member __.Compare(v1, v2) = qnameOrder.Compare (v1,v2) diff --git a/src/fsharp/InnerLambdasToTopLevelFuncs.fs b/src/fsharp/InnerLambdasToTopLevelFuncs.fs index 21365b3c704..e6d0e6b75c5 100644 --- a/src/fsharp/InnerLambdasToTopLevelFuncs.fs +++ b/src/fsharp/InnerLambdasToTopLevelFuncs.fs @@ -306,7 +306,7 @@ type BindingGroupSharingSameReqdItems(bindings: Bindings) = let fclassOrder = Order.orderOn (fun (b: BindingGroupSharingSameReqdItems) -> b.Vals) (List.order (ValByStamp ())) -[] +[] type BindingGroupSharingSameReqdItemsByVals = interface System.Collections.Generic.IComparer with member __.Compare(v1, v2) = fclassOrder.Compare (v1,v2) @@ -331,6 +331,7 @@ let reqdItemOrder = Order.orderOn rep (Pair.order (Bool.order, (ValByStamp ()))) + /// An env says what is needed to close the corresponding defn(s). /// The reqdTypars are the free reqdTypars of the defns, and those required by any direct TLR arity-met calls. /// The reqdItems are the ids/subEnvs required from calls to freeVars. From b2060ed63856c505af1ebc157364e0d84f8daab3 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sun, 12 Aug 2018 06:18:09 +1000 Subject: [PATCH 83/92] Changed dontInline to normal set --- src/fsharp/Optimizer.fs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/fsharp/Optimizer.fs b/src/fsharp/Optimizer.fs index 7f189636529..ee80eff844d 100644 --- a/src/fsharp/Optimizer.fs +++ b/src/fsharp/Optimizer.fs @@ -331,7 +331,7 @@ type IncrementalOptimizationEnv = { // An identifier to help with name generation latestBoundId: Ident option // The set of lambda IDs we've inlined to reach this point. Helps to prevent recursive inlining - dontInline: Zset + dontInline: Set // Recursively bound vars. If an sub-expression that is a candidate for method splitting // contains any of these variables then don't split it, for fear of mucking up tailcalls. // See FSharp 1.0 bug 2892 @@ -346,7 +346,7 @@ type IncrementalOptimizationEnv = static member Empty = { latestBoundId = None - dontInline = Zset.empty Int64.order + dontInline = Set.empty typarInfos = [] functionVal = None dontSplitVars = ValMap.Empty @@ -2529,7 +2529,7 @@ and TryInlineApplication cenv env finfo (tyargs: TType list, args: Expr list, m) cenv.settings.InlineLambdas () && not finfo.HasEffect && // Don't inline recursively! - not (Zset.contains lambdaId env.dontInline) && + not (Set.contains lambdaId env.dontInline) && (// Check the number of argument groups is enough to saturate the lambdas of the target. (if tyargs |> List.exists (fun t -> match t with TType_measure _ -> false | _ -> true) then 1 else 0) + args.Length = arities && (// Enough args @@ -2591,7 +2591,7 @@ and TryInlineApplication cenv env finfo (tyargs: TType list, args: Expr list, m) // Inlining: beta reducing let expr' = MakeApplicationAndBetaReduce cenv.g (f2', f2ty, [tyargs], args', m) // Inlining: reoptimizing - Some (OptimizeExpr cenv {env with dontInline= Zset.add lambdaId env.dontInline} expr') + Some (OptimizeExpr cenv {env with dontInline= Set.add lambdaId env.dontInline} expr') | _ -> None From e69e4d0b59f008f3fe5ff9791cea76d49904f376 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sun, 12 Aug 2018 08:04:50 +1000 Subject: [PATCH 84/92] Replacing Zset usage where plain Set could be used --- src/fsharp/IlxGen.fs | 8 ++++---- src/fsharp/InnerLambdasToTopLevelFuncs.fs | 2 +- src/fsharp/MethodCalls.fs | 2 +- src/fsharp/NameResolution.fs | 9 +++++---- src/fsharp/SignatureConformance.fs | 9 +++++---- src/fsharp/TastOps.fs | 2 +- src/fsharp/TypeChecker.fs | 22 +++++++++++----------- src/fsharp/lib.fs | 5 ----- src/utils/SortKey.fs | 9 +++++---- 9 files changed, 33 insertions(+), 35 deletions(-) diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index 0643f1c5daf..601cd541ba1 100644 --- a/src/fsharp/IlxGen.fs +++ b/src/fsharp/IlxGen.fs @@ -86,13 +86,13 @@ let ChooseFreeVarNames takenNames ts = let tns = List.map (fun t -> (t,None)) ts let rec chooseName names (t,nOpt) = let tn = match nOpt with None -> t | Some n -> t + string n - if Zset.contains tn names then + if Set.contains tn names then chooseName names (t,Some(match nOpt with None -> 0 | Some n -> (n+1))) else - let names = Zset.add tn names + let names = Set.add tn names tn,names - let names = Zset.empty String.order |> Zset.addList takenNames + let names = Set.ofList takenNames let ts,_names = List.mapFold chooseName names tns ts @@ -3924,7 +3924,7 @@ and GetIlxClosureFreeVars cenv m selfv eenvouter takenNames expr = // -- "internal" ones, which get used internally in the implementation let cloContractFreeTyvarSet = (freeInType CollectTypars (tyOfExpr cenv.g expr)).FreeTypars - let cloInternalFreeTyvars = SetCustom.diff cloFreeVarResults.FreeTyvars.FreeTypars cloContractFreeTyvarSet |> SetCustom.elements + let cloInternalFreeTyvars = Set.diff cloFreeVarResults.FreeTyvars.FreeTypars cloContractFreeTyvarSet |> SetCustom.elements let cloContractFreeTyvars = cloContractFreeTyvarSet |> SetCustom.elements let cloFreeTyvars = cloContractFreeTyvars @ cloInternalFreeTyvars diff --git a/src/fsharp/InnerLambdasToTopLevelFuncs.fs b/src/fsharp/InnerLambdasToTopLevelFuncs.fs index e6d0e6b75c5..7ba59b3d816 100644 --- a/src/fsharp/InnerLambdasToTopLevelFuncs.fs +++ b/src/fsharp/InnerLambdasToTopLevelFuncs.fs @@ -219,7 +219,7 @@ module Pass1_DetermineTLRAndArities = (* REPORT MISSED CASES *) #if DEBUG if verboseTLR then - let missed = SetCustom.diff xinfo.TopLevelBindings tlrS + let missed = Set.diff xinfo.TopLevelBindings tlrS missed |> SetCustom.iter (fun v -> dprintf "TopLevel but not TLR = %s\n" v.LogicalName) #endif (* REPORT OVER *) diff --git a/src/fsharp/MethodCalls.fs b/src/fsharp/MethodCalls.fs index d51bbe953c0..0b41199b8a5 100644 --- a/src/fsharp/MethodCalls.fs +++ b/src/fsharp/MethodCalls.fs @@ -353,7 +353,7 @@ type CalledMeth<'T> let names = namedCallerArgs |> List.map (fun (CallerNamedArg(nm, _)) -> nm.idText) - if (List.noRepeats String.order names).Length <> namedCallerArgs.Length then + if (names |> Set.ofList |> Set.count) <> namedCallerArgs.Length then errorR(Error(FSComp.SR.typrelNamedArgumentHasBeenAssignedMoreThenOnce(), m)) let argSet = { UnnamedCalledArgs=unnamedCalledArgs; UnnamedCallerArgs=unnamedCallerArgs; ParamArrayCalledArgOpt=paramArrayCalledArgOpt; ParamArrayCallerArgs=paramArrayCallerArgs; AssignedNamedArgs=assignedNamedArgs } diff --git a/src/fsharp/NameResolution.fs b/src/fsharp/NameResolution.fs index ed3909eb55a..a68263bea39 100644 --- a/src/fsharp/NameResolution.fs +++ b/src/fsharp/NameResolution.fs @@ -5,6 +5,7 @@ module internal Microsoft.FSharp.Compiler.NameResolution open Internal.Utilities +open Internal.Utilities.Collections open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.Compiler.Ast @@ -1665,7 +1666,7 @@ let CheckAllTyparsInferrable amap m item = let freeInArgsAndRetType = accFreeInTypes CollectTyparsNoCaching (pinfo.GetParamTypes(amap,m)) (freeInType CollectTyparsNoCaching (pinfo.GetPropertyType(amap,m))) - let free = Internal.Utilities.Collections.SetCustom.diff freeInDeclaringType.FreeTypars freeInArgsAndRetType.FreeTypars + let free = Set.diff freeInDeclaringType.FreeTypars freeInArgsAndRetType.FreeTypars free.IsEmpty) | Item.MethodGroup(_,minfos,_) -> @@ -1677,7 +1678,7 @@ let CheckAllTyparsInferrable amap m item = List.foldBack (accFreeInTypes CollectTyparsNoCaching) (minfo.GetParamTypes(amap, m, fminst)) (accFreeInTypes CollectTyparsNoCaching (minfo.GetObjArgTypes(amap, m, fminst)) (freeInType CollectTyparsNoCaching (minfo.GetFSharpReturnTy(amap, m, fminst)))) - let free = Internal.Utilities.Collections.SetCustom.diff freeInDeclaringType.FreeTypars freeInArgsAndRetType.FreeTypars + let free = Set.diff freeInDeclaringType.FreeTypars freeInArgsAndRetType.FreeTypars free.IsEmpty) | Item.CtorGroup _ @@ -3511,7 +3512,7 @@ let ResolveCompletionsInType (ncenv: NameResolver) nenv (completionTargets: Reso yield einfo.RemoveMethod.DisplayName ] else [] - let suppressedMethNames = Zset.ofList String.order (pinfoMethNames @ einfoMethNames) + let suppressedMethNames = Set.ofList (pinfoMethNames @ einfoMethNames) let pinfos = pinfosIncludingUnseen @@ -4150,7 +4151,7 @@ let ResolveCompletionsInTypeForItem (ncenv: NameResolver) nenv m ad statics ty ( yield einfo.AddMethod.DisplayName yield einfo.RemoveMethod.DisplayName ] - let suppressedMethNames = Zset.ofList String.order (pinfoMethNames @ einfoMethNames) + let suppressedMethNames = Set.ofList (pinfoMethNames @ einfoMethNames) let pinfos = pinfosIncludingUnseen diff --git a/src/fsharp/SignatureConformance.fs b/src/fsharp/SignatureConformance.fs index 8b0981451ef..a998b5d0132 100644 --- a/src/fsharp/SignatureConformance.fs +++ b/src/fsharp/SignatureConformance.fs @@ -16,6 +16,7 @@ open Microsoft.FSharp.Compiler.Tast open Microsoft.FSharp.Compiler.Tastops open Microsoft.FSharp.Compiler.Lib open Microsoft.FSharp.Compiler.Infos +open Internal.Utilities.Collections #if !NO_EXTENSIONTYPING open Microsoft.FSharp.Compiler.ExtensionTyping @@ -435,11 +436,11 @@ type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) = and checkTypeRepr m aenv (implTycon:Tycon) sigTypeRepr = let reportNiceError k s1 s2 = - let aset = NameSet.ofList s1 - let fset = NameSet.ofList s2 - match Zset.elements (Zset.diff aset fset) with + let aset = Set.ofList s1 + let fset = Set.ofList s2 + match Set.toList (Set.diff aset fset) with | [] -> - match Zset.elements (Zset.diff fset aset) with + match Set.toList (Set.diff fset aset) with | [] -> (errorR (Error (FSComp.SR.DefinitionsInSigAndImplNotCompatibleNumbersDiffer(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName, k),m)); false) | l -> (errorR (Error (FSComp.SR.DefinitionsInSigAndImplNotCompatibleSignatureDefinesButImplDoesNot(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName, k, String.concat ";" l),m)); false) | l -> (errorR (Error (FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplDefinesButSignatureDoesNot(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName, k, String.concat ";" l),m)); false) diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index 09b8077ab5e..1f3536cf731 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -7690,7 +7690,7 @@ let doesActivePatternHaveFreeTypars g (v:ValRef) = let argtps, restps= (freeInTypes CollectTypars argtys).FreeTypars, (freeInType CollectTypars resty).FreeTypars // Error if an active pattern is generic in type variables that only occur in the result Choice<_, ...>. // Note: The test restricts to v.Typars since typars from the closure are considered fixed. - not (SetCustom.isEmpty (SetCustom.inter (SetCustom.diff restps argtps) vtps)) + not (SetCustom.isEmpty (SetCustom.inter (Set.diff restps argtps) vtps)) //--------------------------------------------------------------------------- // RewriteExpr: rewrite bottom up with interceptors diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index 3c8d9cc2a3c..4042a647b7a 100755 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -6366,13 +6366,13 @@ and TcRecordConstruction cenv overallTy env tpenv optOrigExpr objTy fldsList m = error(Error(FSComp.SR.tcFieldRequiresAssignment(fspec.rfield_id.idText, fullDisplayTextOfTyconRef tcref), m))) // Other checks (overlap with above check now clear) - let ns1 = NameSet.ofList (List.map fst fldsList) - let ns2 = NameSet.ofList (List.map (fun x -> x.rfield_id.idText) fspecs) + let ns1 = Set.ofList (List.map fst fldsList) + let ns2 = Set.ofList (List.map (fun x -> x.rfield_id.idText) fspecs) - if Option.isNone optOrigExpr && not (Zset.subset ns2 ns1) then - error (MissingFields(Zset.elements (Zset.diff ns2 ns1), m)) + if Option.isNone optOrigExpr && not (Set.isSubset ns2 ns1) then + error (MissingFields(Set.toList (Set.diff ns2 ns1), m)) - if not (Zset.subset ns1 ns2) then + if not (Set.isSubset ns1 ns2) then error (Error(FSComp.SR.tcExtraneousFieldsGivenValues(), m)) // Build record @@ -11588,14 +11588,14 @@ and TcIncrementalLetRecGeneralization cenv scopem //printfn "(failed generalization test 1 for binding for %s)" pgrbind.RecBindingInfo.Val.DisplayName // Any declared type parameters in an type are always generalizable - let freeInBinding = SetCustom.diff freeInBinding (SetCustom.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.ExtraGeneralizableTypars)) + let freeInBinding = Set.diff freeInBinding (SetCustom.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.ExtraGeneralizableTypars)) if freeInBinding.IsEmpty then true else //printfn "(failed generalization test 2 for binding for %s)" pgrbind.RecBindingInfo.Val.DisplayName // Any declared method parameters can always be generalized - let freeInBinding = SetCustom.diff freeInBinding (SetCustom.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.RecBindingInfo.DeclaredTypars)) + let freeInBinding = Set.diff freeInBinding (SetCustom.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.RecBindingInfo.DeclaredTypars)) if freeInBinding.IsEmpty then true else @@ -11603,7 +11603,7 @@ and TcIncrementalLetRecGeneralization cenv scopem // Type variables free in the non-recursive environment do not stop us generalizing the binding, // since they can't be generalized anyway - let freeInBinding = SetCustom.diff freeInBinding freeInEnv + let freeInBinding = Set.diff freeInBinding freeInEnv if freeInBinding.IsEmpty then true else @@ -11651,8 +11651,8 @@ and TcIncrementalLetRecGeneralization cenv scopem freeInEnv else let freeInBinding = (freeInType CollectAllNoCaching pgrbind.RecBindingInfo.Val.TauType).FreeTypars - let freeInBinding = SetCustom.diff freeInBinding (SetCustom.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.ExtraGeneralizableTypars)) - let freeInBinding = SetCustom.diff freeInBinding (SetCustom.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.RecBindingInfo.DeclaredTypars)) + let freeInBinding = Set.diff freeInBinding (SetCustom.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.ExtraGeneralizableTypars)) + let freeInBinding = Set.diff freeInBinding (SetCustom.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.RecBindingInfo.DeclaredTypars)) Set.union freeInBinding freeInEnv) // Process the bindings marked for transition from PreGeneralization --> PostGeneralization @@ -11686,7 +11686,7 @@ and TcIncrementalLetRecGeneralization cenv scopem /// Compute the type variables which may be generalized and perform the generalization and TcLetrecComputeAndGeneralizeGenericTyparsForBinding cenv denv freeInEnv (pgrbind : PreGeneralizationRecursiveBinding) = - let freeInEnv = SetCustom.diff freeInEnv (SetCustom.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.ExtraGeneralizableTypars)) + let freeInEnv = Set.diff freeInEnv (SetCustom.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.ExtraGeneralizableTypars)) let rbinfo = pgrbind.RecBindingInfo let vspec = rbinfo.Val diff --git a/src/fsharp/lib.fs b/src/fsharp/lib.fs index 96c53d79d0e..864e40343d8 100755 --- a/src/fsharp/lib.fs +++ b/src/fsharp/lib.fs @@ -85,11 +85,6 @@ module Pair = if res1 <> 0 then res1 else compare2.Compare (a2, aa2) } -type NameSet = Zset -[] -module NameSet = - let ofList l : NameSet = List.foldBack Zset.add l (Zset.empty String.order) - [] module NameMap = let domain m = Map.foldBack (fun x _ acc -> Zset.add x acc) m (Zset.empty String.order) diff --git a/src/utils/SortKey.fs b/src/utils/SortKey.fs index b5f4c1f86a7..902bb32b58c 100644 --- a/src/utils/SortKey.fs +++ b/src/utils/SortKey.fs @@ -83,6 +83,11 @@ type Zmap<'Key,'Value>() = struct (acc', m')) finalState, finalMap +module Set = + let diff a b = + if Set.isEmpty a || Set.isEmpty b then a + else Set.fold (fun a k -> Set.remove k a) a b + type zset<'Key,'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> = Set> [] @@ -136,10 +141,6 @@ type SetCustom<'Key>() = static member inline addList<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (xs:list<'Key>) (s:zset<'Key,'Comparer>) = List.fold (fun acc x -> Set.add {CompareObj=x} acc) s xs - static member inline diff<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (a:zset<'Key,'Comparer>) (b:zset<'Key,'Comparer>) = - if Set.isEmpty a || Set.isEmpty b then a - else Set.fold (fun a k -> Set.remove k a) a b - static member inline inter<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (a:zset<'Key,'Comparer>) (b:zset<'Key,'Comparer>) = Set.intersect a b From 406d7eaa1b3abdd6230f7827b3c8cbb46a60cdd1 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sun, 12 Aug 2018 08:29:06 +1000 Subject: [PATCH 85/92] Removed few remaining usages of Zset --- src/fsharp/CompileOps.fs | 12 +++++----- src/fsharp/InnerLambdasToTopLevelFuncs.fs | 18 +++++++++------ src/fsharp/lib.fs | 27 ++++++++++------------- 3 files changed, 29 insertions(+), 28 deletions(-) diff --git a/src/fsharp/CompileOps.fs b/src/fsharp/CompileOps.fs index 2f9eeb7880b..5a041c8a063 100644 --- a/src/fsharp/CompileOps.fs +++ b/src/fsharp/CompileOps.fs @@ -5337,7 +5337,7 @@ type QualifiedNameOfFileByText = member __.Compare(v1, v2) = qnameOrder.Compare (v1,v2) type RootSigs = zmap -type RootImpls = Zset +type RootImpls = zset type TcState = { tcsCcu: CcuThunk @@ -5409,7 +5409,7 @@ let GetInitialTcState(m, ccuName, tcConfig:TcConfig, tcGlobals, tcImports:TcImpo tcsTcImplEnv=tcEnv0 tcsCreatesGeneratedProvidedTypes=false tcsRootSigs = Zmap.empty () - tcsRootImpls = Zset.empty qnameOrder + tcsRootImpls = SetCustom.empty () tcsCcuSig = NewEmptyModuleOrNamespaceType Namespace } @@ -5434,7 +5434,7 @@ let TypeCheckOneInputEventually (checkForErrors, tcConfig:TcConfig, tcImports:Tc errorR(Error(FSComp.SR.buildSignatureAlreadySpecified(qualNameOfFile.Text), m.StartRange)) // Check if the implementation came first in compilation order - if Zset.contains qualNameOfFile tcState.tcsRootImpls then + if SetCustom.contains qualNameOfFile tcState.tcsRootImpls then errorR(Error(FSComp.SR.buildImplementationAlreadyGivenDetail(qualNameOfFile.Text), m)) // Typecheck the signature file @@ -5469,7 +5469,7 @@ let TypeCheckOneInputEventually (checkForErrors, tcConfig:TcConfig, tcImports:Tc let rootSigOpt = tcState.tcsRootSigs.TryFind {CompareObj=qualNameOfFile} // Check if we've already seen an implementation for this fragment - if Zset.contains qualNameOfFile tcState.tcsRootImpls then + if SetCustom.contains qualNameOfFile tcState.tcsRootImpls then errorR(Error(FSComp.SR.buildImplementationAlreadyGiven(qualNameOfFile.Text), m)) let tcImplEnv = tcState.tcsTcImplEnv @@ -5481,7 +5481,7 @@ let TypeCheckOneInputEventually (checkForErrors, tcConfig:TcConfig, tcImports:Tc let hadSig = rootSigOpt.IsSome let implFileSigType = SigTypeOfImplFile implFile - let rootImpls = Zset.add qualNameOfFile tcState.tcsRootImpls + let rootImpls = SetCustom.add qualNameOfFile tcState.tcsRootImpls // Only add it to the environment if it didn't have a signature let m = qualNameOfFile.Range @@ -5556,7 +5556,7 @@ let TypeCheckClosedInputSetFinish (declaredImpls: TypedImplFile list, tcState) = // Check all interfaces have implementations tcState.tcsRootSigs |> Zmap.iter (fun qualNameOfFile _ -> - if not (Zset.contains qualNameOfFile tcState.tcsRootImpls) then + if not (SetCustom.contains qualNameOfFile tcState.tcsRootImpls) then errorR(Error(FSComp.SR.buildSignatureWithoutImplementation(qualNameOfFile.Text), qualNameOfFile.Range))) tcState, declaredImpls diff --git a/src/fsharp/InnerLambdasToTopLevelFuncs.fs b/src/fsharp/InnerLambdasToTopLevelFuncs.fs index 7ba59b3d816..b0cfd316c41 100644 --- a/src/fsharp/InnerLambdasToTopLevelFuncs.fs +++ b/src/fsharp/InnerLambdasToTopLevelFuncs.fs @@ -331,30 +331,34 @@ let reqdItemOrder = Order.orderOn rep (Pair.order (Bool.order, (ValByStamp ()))) +[] +type ReqdItemOrder = + interface System.Collections.Generic.IComparer with + member __.Compare(v1, v2) = reqdItemOrder.Compare (v1,v2) /// An env says what is needed to close the corresponding defn(s). /// The reqdTypars are the free reqdTypars of the defns, and those required by any direct TLR arity-met calls. /// The reqdItems are the ids/subEnvs required from calls to freeVars. type ReqdItemsForDefn = { reqdTypars : zset - reqdItems : Zset + reqdItems : zset m : Range.range } - member env.ReqdSubEnvs = [ for x in env.reqdItems do match x with | ReqdSubEnv f -> yield f | ReqdVal _ -> () ] - member env.ReqdVals = [ for x in env.reqdItems do match x with | ReqdSubEnv _ -> () | ReqdVal v -> yield v ] + member env.ReqdSubEnvs = [ for x in env.reqdItems do match x.CompareObj with | ReqdSubEnv f -> yield f | ReqdVal _ -> () ] + member env.ReqdVals = [ for x in env.reqdItems do match x.CompareObj with | ReqdSubEnv _ -> () | ReqdVal v -> yield v ] member env.Extend (typars,items) = {env with reqdTypars = SetCustom.addList typars env.reqdTypars - reqdItems = Zset.addList items env.reqdItems} + reqdItems = SetCustom.addList items env.reqdItems} static member Initial typars m = {reqdTypars = SetCustom.ofList typars - reqdItems = Zset.empty reqdItemOrder + reqdItems = SetCustom.empty () m = m } override env.ToString() = (showL (commaListL (List.map typarL (SetCustom.elements env.reqdTypars)))) + "--" + - (String.concat "," (List.map string (Zset.elements env.reqdItems))) + (String.concat "," (List.map string (SetCustom.elements env.reqdItems))) (*--debug-stuff--*) @@ -699,7 +703,7 @@ let FlatEnvPacks g fclassM topValS declist (reqdItemsMap: zmap SetCustom.ofList |> SetCustom.elements // noRepeats // Remove genuinely toplevel, no need to close over these let vals = vals |> List.filter (IsMandatoryTopLevel >> not) diff --git a/src/fsharp/lib.fs b/src/fsharp/lib.fs index 864e40343d8..5a84551bec1 100755 --- a/src/fsharp/lib.fs +++ b/src/fsharp/lib.fs @@ -87,10 +87,7 @@ module Pair = [] module NameMap = - let domain m = Map.foldBack (fun x _ acc -> Zset.add x acc) m (Zset.empty String.order) - let domainL m = Zset.elements (domain m) - - + let domainL (m:Map<_,_>) = (m, []) ||> Map.foldBack (fun k _ acc -> k :: acc) //--------------------------------------------------------------------------- // Library: Pre\Post checks @@ -251,23 +248,23 @@ let mapTriple (f1,f2,f3) (a1,a2,a3) = (f1 a1, f2 a2, f3 a3) let mapQuadruple (f1,f2,f3,f4) (a1,a2,a3,a4) = (f1 a1, f2 a2, f3 a3, f4 a4) let fmap2Of2 f z (a1,a2) = let z,a2 = f z a2 in z,(a1,a2) -module List = - let noRepeats xOrder xs = - let s = Zset.addList xs (Zset.empty xOrder) // build set - Zset.elements s // get elements... no repeats +//module List = +// let noRepeats xOrder xs = +// let s = Zset.addList xs (Zset.empty xOrder) // build set +// Zset.elements s // get elements... no repeats //--------------------------------------------------------------------------- // Zset //------------------------------------------------------------------------- -module Zset = - let ofList order xs = Zset.addList xs (Zset.empty order) +//module Zset = +// //let ofList order xs = Zset.addList xs (Zset.empty order) - // CLEANUP NOTE: move to Zset? - let rec fixpoint f (s as s0) = - let s = f s - if Zset.equal s s0 then s0 (* fixed *) - else fixpoint f s (* iterate *) +// // CLEANUP NOTE: move to Zset? +// let rec fixpoint f (s as s0) = +// let s = f s +// if Zset.equal s s0 then s0 (* fixed *) +// else fixpoint f s (* iterate *) //--------------------------------------------------------------------------- // Misc From e525f298691740a0b47bcffb43e10f91388b033e Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sun, 12 Aug 2018 08:36:03 +1000 Subject: [PATCH 86/92] Deleted zset and TaggedCollections --- .../FSharp.Compiler.Service.fsproj | 12 - src/absil/zset.fs | 43 -- src/absil/zset.fsi | 42 -- .../FSharp.Compiler.Private.fsproj | 12 - .../FSharp.Compiler.Private.fsproj | 39 +- src/fsharp/Fsc-proto/Fsc-proto.fsproj | 12 - src/fsharp/lib.fs | 18 - src/utils/TaggedCollections.fs | 703 ------------------ src/utils/TaggedCollections.fsi | 119 --- 9 files changed, 5 insertions(+), 995 deletions(-) delete mode 100644 src/absil/zset.fs delete mode 100644 src/absil/zset.fsi delete mode 100644 src/utils/TaggedCollections.fs delete mode 100644 src/utils/TaggedCollections.fsi diff --git a/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj b/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj index 3d5c4dedfbf..972578c7f3e 100644 --- a/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj +++ b/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj @@ -111,12 +111,6 @@ Utilities/EditDistance.fs - - Utilities/TaggedCollections.fsi - - - Utilities/TaggedCollections.fs - Utilities/SortKey.fs @@ -138,12 +132,6 @@ Utilities/filename.fs - - Utilities/zset.fsi - - - Utilities/zset.fs - Utilities/bytes.fsi diff --git a/src/absil/zset.fs b/src/absil/zset.fs deleted file mode 100644 index 960caa06e36..00000000000 --- a/src/absil/zset.fs +++ /dev/null @@ -1,43 +0,0 @@ -// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. - -namespace Microsoft.FSharp.Compiler.AbstractIL.Internal - -open Microsoft.FSharp.Compiler.AbstractIL -open Microsoft.FSharp.Compiler.AbstractIL.Internal -open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library -open Internal.Utilities -open Internal.Utilities.Collections.Tagged -open System.Collections.Generic - -/// Sets with a specific comparison function -type internal Zset<'T> = Internal.Utilities.Collections.Tagged.Set<'T> - -[] -module internal Zset = - - let empty (ord : IComparer<'T>) = Internal.Utilities.Collections.Tagged.Set<_,_>.Empty(ord) - - let isEmpty (s:Zset<_>) = s.IsEmpty - - let contains x (s:Zset<_>) = s.Contains(x) - let add x (s:Zset<_>) = s.Add(x) - let addList xs a = List.fold (fun a x -> add x a) a xs - - let singleton ord x = add x (empty ord) - let remove x (s:Zset<_>) = s.Remove(x) - - let fold (f : 'T -> 'b -> 'b) (s:Zset<_>) b = s.Fold f b - let iter f (s:Zset<_>) = s.Iterate f - let forall p (s:Zset<_>) = s.ForAll p - let count (s:Zset<_>) = s.Count - let exists p (s:Zset<_>) = s.Exists p - let subset (s1:Zset<_>) (s2:Zset<_>) = s1.IsSubsetOf s2 - let equal (s1:Zset<_>) (s2:Zset<_>) = Internal.Utilities.Collections.Tagged.Set<_,_>.Equality(s1,s2) - let elements (s:Zset<_>) = s.ToList() - let filter p (s:Zset<_>) = s.Filter p - - let union (s1:Zset<_>) (s2:Zset<_>) = Internal.Utilities.Collections.Tagged.Set<_,_>.Union(s1,s2) - let inter (s1:Zset<_>) (s2:Zset<_>) = Internal.Utilities.Collections.Tagged.Set<_,_>.Intersection(s1,s2) - let diff (s1:Zset<_>) (s2:Zset<_>) = Internal.Utilities.Collections.Tagged.Set<_,_>.Difference(s1,s2) - - let memberOf m k = contains k m diff --git a/src/absil/zset.fsi b/src/absil/zset.fsi deleted file mode 100644 index 094e0288128..00000000000 --- a/src/absil/zset.fsi +++ /dev/null @@ -1,42 +0,0 @@ -// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. - -namespace Microsoft.FSharp.Compiler.AbstractIL.Internal - -open Internal.Utilities -open Microsoft.FSharp.Compiler.AbstractIL -open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library -open System.Collections.Generic - -/// Sets with a specific comparison function -type internal Zset<'T> = Internal.Utilities.Collections.Tagged.Set<'T> - - -[] -module internal Zset = - - val empty : IComparer<'T> -> Zset<'T> - val isEmpty : Zset<'T> -> bool - val contains : 'T -> Zset<'T> -> bool - val memberOf : Zset<'T> -> 'T -> bool - val add : 'T -> Zset<'T> -> Zset<'T> - val addList : 'T list -> Zset<'T> -> Zset<'T> - val singleton : IComparer<'T> -> 'T -> Zset<'T> - val remove : 'T -> Zset<'T> -> Zset<'T> - - val count : Zset<'T> -> int - val union : Zset<'T> -> Zset<'T> -> Zset<'T> - val inter : Zset<'T> -> Zset<'T> -> Zset<'T> - val diff : Zset<'T> -> Zset<'T> -> Zset<'T> - val equal : Zset<'T> -> Zset<'T> -> bool - val subset : Zset<'T> -> Zset<'T> -> bool - val forall : predicate:('T -> bool) -> Zset<'T> -> bool - val exists : predicate:('T -> bool) -> Zset<'T> -> bool - val filter : predicate:('T -> bool) -> Zset<'T> -> Zset<'T> - - val fold : ('T -> 'State -> 'State) -> Zset<'T> -> 'State -> 'State - val iter : ('T -> unit) -> Zset<'T> -> unit - - val elements : Zset<'T> -> 'T list - - - diff --git a/src/buildfromsource/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj b/src/buildfromsource/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj index 16883847faa..23836872cba 100644 --- a/src/buildfromsource/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj +++ b/src/buildfromsource/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj @@ -75,12 +75,6 @@ Utilities\EditDistance.fs - - Utilities\TaggedCollections.fsi - - - Utilities\TaggedCollections.fs - Utilities\SortKey.fs @@ -99,12 +93,6 @@ Utilities\filename.fs - - Utilities\zset.fsi - - - Utilities\zset.fs - Utilities\bytes.fsi diff --git a/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj b/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj index afd20bf59ac..b511a84cad3 100644 --- a/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj +++ b/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj @@ -54,8 +54,6 @@ - - FSComp.txt @@ -113,12 +111,6 @@ Utilities\EditDistance.fs - - Utilities\TaggedCollections.fsi - - - Utilities\TaggedCollections.fs - Utilities\SortKey.fs @@ -137,12 +129,6 @@ Utilities\filename.fs - - Utilities\zset.fsi - - - Utilities\zset.fs - Utilities\bytes.fsi @@ -455,8 +441,6 @@ Logic\TypeChecker.fs - - Optimize\Optimizer.fsi @@ -487,8 +471,6 @@ CodeGen\IlxGen.fs - - Driver\CompileOps.fsi @@ -507,8 +489,6 @@ Driver\fsc.fs - - Symbols/SymbolHelpers.fsi @@ -533,8 +513,6 @@ Symbols/SymbolPatterns.fs - - Service/IncrementalBuild.fsi @@ -637,8 +615,6 @@ Service/ServiceAnalysis.fs - - FSIstrings.txt @@ -648,22 +624,16 @@ InteractiveSession/fsi.fs - - + Misc/MSBuildReferenceResolver.fs - Misc/LegacyHostedCompilerForTesting.fs - - - - - + @@ -679,8 +649,6 @@ ..\..\..\packages\System.ValueTuple.$(SystemValueTuplePackageVersion)\lib\netstandard1.0\System.ValueTuple.dll true - - $(FSharpSourcesRoot)\..\packages\Microsoft.Build.Framework.$(MicrosoftBuildFrameworkPackageVersion)\lib\net46\Microsoft.Build.Framework.dll @@ -701,6 +669,9 @@ + + $(FSharpSourcesRoot)\..\packages\Microsoft.VisualFSharp.Type.Providers.Redist.$(MicrosoftVisualFSharpTypeProvidersRedistPackageVersion)\content\4.3.0.0\FSharp.Data.TypeProviders.dll + {DED3BBD7-53F4-428A-8C9F-27968E768605} FSharp.Core diff --git a/src/fsharp/Fsc-proto/Fsc-proto.fsproj b/src/fsharp/Fsc-proto/Fsc-proto.fsproj index a0d7bbe60fa..d18c720f5fa 100644 --- a/src/fsharp/Fsc-proto/Fsc-proto.fsproj +++ b/src/fsharp/Fsc-proto/Fsc-proto.fsproj @@ -97,12 +97,6 @@ Utilities\EditDistance.fs - - TaggedCollections.fsi - - - TaggedCollections.fs - SortKey.fs @@ -121,12 +115,6 @@ filename.fs - - zset.fsi - - - zset.fs - bytes.fsi diff --git a/src/fsharp/lib.fs b/src/fsharp/lib.fs index 5a84551bec1..16f48f195ed 100755 --- a/src/fsharp/lib.fs +++ b/src/fsharp/lib.fs @@ -248,24 +248,6 @@ let mapTriple (f1,f2,f3) (a1,a2,a3) = (f1 a1, f2 a2, f3 a3) let mapQuadruple (f1,f2,f3,f4) (a1,a2,a3,a4) = (f1 a1, f2 a2, f3 a3, f4 a4) let fmap2Of2 f z (a1,a2) = let z,a2 = f z a2 in z,(a1,a2) -//module List = -// let noRepeats xOrder xs = -// let s = Zset.addList xs (Zset.empty xOrder) // build set -// Zset.elements s // get elements... no repeats - -//--------------------------------------------------------------------------- -// Zset -//------------------------------------------------------------------------- - -//module Zset = -// //let ofList order xs = Zset.addList xs (Zset.empty order) - -// // CLEANUP NOTE: move to Zset? -// let rec fixpoint f (s as s0) = -// let s = f s -// if Zset.equal s s0 then s0 (* fixed *) -// else fixpoint f s (* iterate *) - //--------------------------------------------------------------------------- // Misc //------------------------------------------------------------------------- diff --git a/src/utils/TaggedCollections.fs b/src/utils/TaggedCollections.fs deleted file mode 100644 index 13c39890c69..00000000000 --- a/src/utils/TaggedCollections.fs +++ /dev/null @@ -1,703 +0,0 @@ -// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. - -namespace Internal.Utilities.Collections.Tagged - - #nowarn "51" - #nowarn "69" // interface implementations in augmentations - #nowarn "60" // override implementations in augmentations - - open Microsoft.FSharp.Core - open Microsoft.FSharp.Core.Operators - open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators - open System - open System.Collections.Generic - open Internal.Utilities - open Internal.Utilities.Collections - - - [] - [] - type SetTree<'T> = - | SetEmpty // height = 0 - | SetNode of 'T * SetTree<'T> * SetTree<'T> * int // height = int -#if ONE - | SetOne of 'T // height = 1 -#endif - // OPTIMIZATION: store SetNode(k,SetEmpty,SetEmpty,1) ---> SetOne(k) - - - // CONSIDER: SetTree<'T> = SetEmpty | SetNode of 'T * SetTree<'T> * SetTree<'T> * int - // with SetOne = SetNode of (x,null,null,1) - - [] - module SetTree = - let empty = SetEmpty - - let height t = - match t with - | SetEmpty -> 0 -#if ONE - | SetOne _ -> 1 -#endif - | SetNode (_,_,_,h) -> h - -#if CHECKED - let rec checkInvariant t = - // A good sanity check, loss of balance can hit perf - match t with - | SetEmpty -> true - | SetOne _ -> true - | SetNode (k,t1,t2,h) -> - let h1 = height t1 in - let h2 = height t2 in - (-2 <= (h1 - h2) && (h1 - h2) <= 2) && checkInvariant t1 && checkInvariant t2 -#else - let inline SetOne(x) = SetNode(x,SetEmpty,SetEmpty,1) -#endif - - let tolerance = 2 - - let mk l hl k r hr = -#if ONE - if hl = 0 && hr = 0 then SetOne (k) - else -#endif - let m = if hl < hr then hr else hl - SetNode(k,l,r,m+1) - - let rebalance t1 k t2 = - let t1h = height t1 - let t2h = height t2 - if t2h > t1h + tolerance then // right is heavier than left - match t2 with - | SetNode(t2k,t2l,t2r,_) -> - // one of the nodes must have height > height t1 + 1 - let t2lh = height t2l - if t2lh > t1h + 1 then // balance left: combination - match t2l with - | SetNode(t2lk,t2ll,t2lr,_) -> - let l = mk t1 t1h k t2ll (height t2ll) - let r = mk t2lr (height t2lr) t2k t2r (height t2r) - mk l (height l) t2lk r (height r) - | _ -> failwith "rebalance" - else // rotate left - let l = mk t1 t1h k t2l t2lh - mk l (height l) t2k t2r (height t2r) - | _ -> failwith "rebalance" - else - if t1h > t2h + tolerance then // left is heavier than right - match t1 with - | SetNode(t1k,t1l,t1r,_) -> - // one of the nodes must have height > height t2 + 1 - let t1rh = height t1r - if t1rh > t2h + 1 then - // balance right: combination - match t1r with - | SetNode(t1rk,t1rl,t1rr,_) -> - let l = mk t1l (height t1l) t1k t1rl (height t1rl) - let r = mk t1rr (height t1rr) k t2 t2h - mk l (height l) t1rk r (height r) - | _ -> failwith "rebalance" - else - let r = mk t1r t1rh k t2 t2h - mk t1l (height t1l) t1k r (height r) - | _ -> failwith "rebalance" - else mk t1 t1h k t2 t2h - - let rec add (comparer: IComparer<'T>) k t = - match t with - | SetNode (k2,l,r,_) -> - let c = comparer.Compare(k,k2) - if c < 0 then rebalance (add comparer k l) k2 r - elif c = 0 then t - else rebalance l k2 (add comparer k r) -#if ONE - | SetOne(k2) -> - // nb. no check for rebalance needed for small trees, also be sure to reuse node already allocated - let c = comparer.Compare(k,k2) - if c < 0 then SetNode (k,SetEmpty,t,2) - elif c = 0 then t - else SetNode (k,t,SetEmpty,2) -#endif - | SetEmpty -> SetOne(k) - - let rec balance comparer t1 k t2 = - // Given t1 < k < t2 where t1 and t2 are "balanced", - // return a balanced tree for . - // Recall: balance means subtrees heights differ by at most "tolerance" - match t1,t2 with - | SetEmpty,t2 -> add comparer k t2 // drop t1 = empty - | t1,SetEmpty -> add comparer k t1 // drop t2 = empty -#if ONE - | SetOne k1,t2 -> add comparer k (add comparer k1 t2) - | t1,SetOne k2 -> add comparer k (add comparer k2 t1) -#endif - | SetNode(k1,t11,t12,t1h),SetNode(k2,t21,t22,t2h) -> - // Have: (t11 < k1 < t12) < k < (t21 < k2 < t22) - // Either (a) h1,h2 differ by at most 2 - no rebalance needed. - // (b) h1 too small, i.e. h1+2 < h2 - // (c) h2 too small, i.e. h2+2 < h1 - if t1h+tolerance < t2h then - // case: b, h1 too small - // push t1 into low side of t2, may increase height by 1 so rebalance - rebalance (balance comparer t1 k t21) k2 t22 - elif t2h+tolerance < t1h then - // case: c, h2 too small - // push t2 into high side of t1, may increase height by 1 so rebalance - rebalance t11 k1 (balance comparer t12 k t2) - else - // case: a, h1 and h2 meet balance requirement - mk t1 t1h k t2 t2h - - let rec split (comparer : IComparer<'T>) pivot t = - // Given a pivot and a set t - // Return { x in t s.t. x < pivot }, pivot in t? , { x in t s.t. x > pivot } - match t with - | SetNode(k1,t11,t12,_) -> - let c = comparer.Compare(pivot,k1) - if c < 0 then // pivot t1 - let t11_lo,havePivot,t11_hi = split comparer pivot t11 - t11_lo,havePivot,balance comparer t11_hi k1 t12 - elif c = 0 then // pivot is k1 - t11,true,t12 - else // pivot t2 - let t12_lo,havePivot,t12_hi = split comparer pivot t12 - balance comparer t11 k1 t12_lo,havePivot,t12_hi -#if ONE - | SetOne k1 -> - let c = comparer.Compare(k1,pivot) - if c < 0 then t ,false,SetEmpty // singleton under pivot - elif c = 0 then SetEmpty,true ,SetEmpty // singleton is pivot - else SetEmpty,false,t // singleton over pivot -#endif - | SetEmpty -> - SetEmpty,false,SetEmpty - - let rec spliceOutSuccessor t = - match t with - | SetEmpty -> failwith "internal error: Map.splice_out_succ_or_pred" -#if ONE - | SetOne (k2) -> k2,empty -#endif - | SetNode (k2,l,r,_) -> - match l with - | SetEmpty -> k2,r - | _ -> let k3,l' = spliceOutSuccessor l in k3,mk l' (height l') k2 r (height r) - - let rec remove (comparer: IComparer<'T>) k t = - match t with - | SetEmpty -> t -#if ONE - | SetOne (k2) -> - let c = comparer.Compare(k,k2) - if c = 0 then empty - else t -#endif - | SetNode (k2,l,r,_) -> - let c = comparer.Compare(k,k2) - if c < 0 then rebalance (remove comparer k l) k2 r - elif c = 0 then - match l,r with - | SetEmpty,_ -> r - | _,SetEmpty -> l - | _ -> - let sk,r' = spliceOutSuccessor r - mk l (height l) sk r' (height r') - else rebalance l k2 (remove comparer k r) - - let rec contains (comparer: IComparer<'T>) k t = - match t with - | SetNode(k2,l,r,_) -> - let c = comparer.Compare(k,k2) - if c < 0 then contains comparer k l - elif c = 0 then true - else contains comparer k r -#if ONE - | SetOne(k2) -> (comparer.Compare(k,k2) = 0) -#endif - | SetEmpty -> false - - let rec iter f t = - match t with - | SetNode(k2,l,r,_) -> iter f l; f k2; iter f r -#if ONE - | SetOne(k2) -> f k2 -#endif - | SetEmpty -> () - - // Fold, left-to-right. - // - // NOTE: This differs from the behaviour of Map.fold which folds right-to-left. - let rec fold f m x = - match m with - | SetNode(k,l,r,_) -> fold f r (f k (fold f l x)) -#if ONE - | SetOne(k) -> f k x -#endif - | SetEmpty -> x - - let rec forAll f m = - match m with - | SetNode(k2,l,r,_) -> f k2 && forAll f l && forAll f r -#if ONE - | SetOne(k2) -> f k2 -#endif - | SetEmpty -> true - - let rec exists f m = - match m with - | SetNode(k2,l,r,_) -> f k2 || exists f l || exists f r -#if ONE - | SetOne(k2) -> f k2 -#endif - | SetEmpty -> false - - let isEmpty m = match m with | SetEmpty -> true | _ -> false - - let subset comparer a b = forAll (fun x -> contains comparer x b) a - - let rec elementsAux m acc = - match m with - | SetNode(k2,l,r,_) -> k2 :: (elementsAux l (elementsAux r acc)) -#if ONE - | SetOne(k2) -> k2 :: acc -#endif - | SetEmpty -> acc - - let elements a = elementsAux a [] - - let rec filterAux comparer f s acc = - match s with - | SetNode(k,l,r,_) -> - let acc = if f k then add comparer k acc else acc - filterAux comparer f l (filterAux comparer f r acc) -#if ONE - | SetOne(k) -> if f k then add comparer k acc else acc -#endif - | SetEmpty -> acc - - let filter comparer f s = filterAux comparer f s empty - - let rec diffAux comparer m acc = - match m with - | SetNode(k,l,r,_) -> diffAux comparer l (diffAux comparer r (remove comparer k acc)) -#if ONE - | SetOne(k) -> remove comparer k acc -#endif - | SetEmpty -> acc - - let diff comparer a b = diffAux comparer b a - - let rec countAux s acc = - match s with - | SetNode(_,l,r,_) -> countAux l (countAux r (acc+1)) -#if ONE - | SetOne(k) -> acc+1 -#endif - | SetEmpty -> acc - - let count s = countAux s 0 - - let rec union comparer t1 t2 = - // Perf: tried bruteForce for low heights, but nothing significant - match t1,t2 with - | SetNode(k1,t11,t12,h1),SetNode(k2,t21,t22,h2) -> // (t11 < k < t12) AND (t21 < k2 < t22) - // Divide and Conquer: - // Suppose t1 is largest. - // Split t2 using pivot k1 into lo and hi. - // Union disjoint subproblems and then combine. - if h1 > h2 then - let lo,_,hi = split comparer k1 t2 in - balance comparer (union comparer t11 lo) k1 (union comparer t12 hi) - else - let lo,_,hi = split comparer k2 t1 in - balance comparer (union comparer t21 lo) k2 (union comparer t22 hi) - | SetEmpty,t -> t - | t,SetEmpty -> t -#if ONE - | SetOne k1,t2 -> add comparer k1 t2 - | t1,SetOne k2 -> add comparer k2 t1 -#endif - - let rec intersectionAux comparer b m acc = - match m with - | SetNode(k,l,r,_) -> - let acc = intersectionAux comparer b r acc - let acc = if contains comparer k b then add comparer k acc else acc - intersectionAux comparer b l acc -#if ONE - | SetOne(k) -> - if contains comparer k b then add comparer k acc else acc -#endif - | SetEmpty -> acc - - let intersection comparer a b = intersectionAux comparer b a empty - - let partition1 comparer f k (acc1,acc2) = - if f k then (add comparer k acc1,acc2) - else (acc1,add comparer k acc2) - - let rec partitionAux comparer f s acc = - match s with - | SetNode(k,l,r,_) -> - let acc = partitionAux comparer f r acc - let acc = partition1 comparer f k acc - partitionAux comparer f l acc -#if ONE - | SetOne(k) -> partition1 comparer f k acc -#endif - | SetEmpty -> acc - - let partition comparer f s = partitionAux comparer f s (empty,empty) - - // It's easier to get many less-important algorithms right using this active pattern - let (|MatchSetNode|MatchSetEmpty|) s = - match s with - | SetNode(k2,l,r,_) -> MatchSetNode(k2,l,r) -#if ONE - | SetOne(k2) -> MatchSetNode(k2,SetEmpty,SetEmpty) -#endif - | SetEmpty -> MatchSetEmpty - - let rec nextElemCont (comparer: IComparer<'T>) k s cont = - match s with - | MatchSetNode(k2,l,r) -> - let c = comparer.Compare(k,k2) - if c < 0 then nextElemCont comparer k l (function None -> cont(Some(k2)) | res -> res) - elif c = 0 then cont(minimumElementOpt r) - else nextElemCont comparer k r cont - | MatchSetEmpty -> cont(None) - - and nextElem comparer k s = nextElemCont comparer k s (fun res -> res) - - and prevElemCont (comparer: IComparer<'T>) k s cont = - match s with - | MatchSetNode(k2,l,r) -> - let c = comparer.Compare(k,k2) - if c > 0 then prevElemCont comparer k r (function None -> cont(Some(k2)) | res -> res) - elif c = 0 then cont(maximumElementOpt r) - else prevElemCont comparer k l cont - | MatchSetEmpty -> cont(None) - - and prevElem comparer k s = prevElemCont comparer k s (fun res -> res) - - and minimumElementAux s n = - match s with - | SetNode(k,l,_,_) -> minimumElementAux l k -#if ONE - | SetOne(k) -> k -#endif - | SetEmpty -> n - - and minimumElementOpt s = - match s with - | SetNode(k,l,_,_) -> Some(minimumElementAux l k) -#if ONE - | SetOne(k) -> Some k -#endif - | SetEmpty -> None - - and maximumElementAux s n = - match s with - | SetNode(k,_,r,_) -> maximumElementAux r k -#if ONE - | SetOne(k) -> k -#endif - | SetEmpty -> n - - and maximumElementOpt s = - match s with - | SetNode(k,_,r,_) -> Some(maximumElementAux r k) -#if ONE - | SetOne(k) -> Some(k) -#endif - | SetEmpty -> None - - let minimumElement s = - match minimumElementOpt s with - | Some(k) -> k - | None -> failwith "minimumElement" - - let maximumElement s = - match maximumElementOpt s with - | Some(k) -> k - | None -> failwith "maximumElement" - - - //-------------------------------------------------------------------------- - // Imperative left-to-right iterators. - //-------------------------------------------------------------------------- - - type SetIterator<'T>(s:SetTree<'T>) = - - // collapseLHS: - // a) Always returns either [] or a list starting with SetOne. - // b) The "fringe" of the set stack is unchanged. - let rec collapseLHS stack = - match stack with - | [] -> [] - | SetEmpty :: rest -> collapseLHS rest -#if ONE - | SetOne k :: rest -> stack -#else - | SetNode(_,SetEmpty,SetEmpty,_) :: _ -> stack -#endif - | SetNode(k,l,r,_) :: rest -> collapseLHS (l :: SetOne k :: r :: rest) - - // invariant: always collapseLHS result - let mutable stack = collapseLHS [s] - // true when MoveNext has been called - let mutable started = false - - let notStarted() = raise (new System.InvalidOperationException("Enumeration has not started. Call MoveNext.")) - let alreadyFinished() = raise (new System.InvalidOperationException("Enumeration already finished.")) - - member i.Current = - if started then - match stack with -#if ONE - | SetOne k :: _ -> k -#else - | SetNode( k,_,_,_) :: _ -> k -#endif - | [] -> alreadyFinished() - | _ -> failwith "Please report error: Set iterator, unexpected stack for current" - else - notStarted() - - member i.MoveNext() = - if started then - match stack with -#if ONE - | SetOne _ :: rest -> -#else - | SetNode _ :: rest -> -#endif - stack <- collapseLHS rest; - not stack.IsEmpty - | [] -> false - | _ -> failwith "Please report error: Set iterator, unexpected stack for moveNext" - else - started <- true; // The first call to MoveNext "starts" the enumeration. - not stack.IsEmpty - - let toSeq s = - let i = ref (SetIterator s) - { new IEnumerator<_> with - member __.Current = (!i).Current - interface System.Collections.IEnumerator with - member __.Current = box (!i).Current - member __.MoveNext() = (!i).MoveNext() - member __.Reset() = i := SetIterator s - interface System.IDisposable with - member __.Dispose() = () } - - //-------------------------------------------------------------------------- - // Set comparison. This can be expensive. - //-------------------------------------------------------------------------- - - let rec compareStacks (comparer: IComparer<'T>) l1 l2 = - match l1,l2 with - | [],[] -> 0 - | [],_ -> -1 - | _ ,[] -> 1 - | (SetEmpty _ :: t1),(SetEmpty :: t2) -> compareStacks comparer t1 t2 -#if ONE - | (SetOne(n1k) :: t1),(SetOne(n2k) :: t2) -> - let c = comparer.Compare(n1k,n2k) - if c <> 0 then c else compareStacks comparer t1 t2 - | (SetOne(n1k) :: t1),(SetNode(n2k,SetEmpty,n2r,_) :: t2) -> - let c = comparer.Compare(n1k,n2k) - if c <> 0 then c else compareStacks comparer (empty :: t1) (n2r :: t2) - | (SetNode(n1k,(SetEmpty as emp),n1r,_) :: t1),(SetOne(n2k) :: t2) -> - let c = comparer.Compare(n1k,n2k) - if c <> 0 then c else compareStacks comparer (n1r :: t1) (emp :: t2) -#endif - | (SetNode(n1k,SetEmpty,n1r,_) :: t1),(SetNode(n2k,SetEmpty,n2r,_) :: t2) -> - let c = comparer.Compare(n1k,n2k) - if c <> 0 then c else compareStacks comparer (n1r :: t1) (n2r :: t2) -#if ONE - | (SetOne(n1k) :: t1),_ -> - compareStacks comparer (empty :: SetOne(n1k) :: t1) l2 -#endif - | (SetNode(n1k,n1l,n1r,_) :: t1),_ -> - compareStacks comparer (n1l :: SetNode(n1k,empty,n1r,0) :: t1) l2 -#if ONE - | _,(SetOne(n2k) :: t2) -> - compareStacks comparer l1 (empty :: SetOne(n2k) :: t2) -#endif - | _,(SetNode(n2k,n2l,n2r,_) :: t2) -> - compareStacks comparer l1 (n2l :: SetNode(n2k,empty,n2r,0) :: t2) - - let compare comparer s1 s2 = - match s1,s2 with - | SetEmpty,SetEmpty -> 0 - | SetEmpty,_ -> -1 - | _,SetEmpty -> 1 - | _ -> compareStacks comparer [s1] [s2] - - let choose s = minimumElement s - - let toList s = - let rec loop m x = - match m with - | SetNode(k,l,r,_) -> loop l (k :: (loop r x)) -#if ONE - | SetOne(k) -> k :: x -#endif - | SetEmpty -> x - loop s [] - - let copyToArray s (arr: _[]) i = - let j = ref i - iter (fun x -> arr.[!j] <- x; j := !j + 1) s - - let toArray s = - let n = (count s) - let res = Array.zeroCreate n - copyToArray s res 0; - res - - let rec mkFromEnumerator comparer acc (e : IEnumerator<_>) = - if e.MoveNext() then - mkFromEnumerator comparer (add comparer e.Current acc) e - else acc - - let ofSeq comparer (c : IEnumerable<_>) = - use ie = c.GetEnumerator() - mkFromEnumerator comparer empty ie - - let ofArray comparer l = Array.fold (fun acc k -> add comparer k acc) empty l - - - [] - [] - type internal Set<'T,'ComparerTag> when 'ComparerTag :> IComparer<'T>(comparer: IComparer<'T>, tree: SetTree<'T>) = - - static let refresh (s:Set<_,_>) t = Set<_,_>(comparer=s.Comparer, tree=t) - - member s.Tree = tree - member s.Comparer : IComparer<'T> = comparer - - static member Empty(comparer: 'ComparerTag) : Set<'T,'ComparerTag> = - Set<_,_>(comparer=comparer, tree=SetTree.empty) - - - member s.Add(x) : Set<'T,'ComparerTag> = refresh s (SetTree.add comparer x tree) - member s.Remove(x) : Set<'T,'ComparerTag> = refresh s (SetTree.remove comparer x tree) - member s.Count = SetTree.count tree - member s.Contains(x) = SetTree.contains comparer x tree - member s.Iterate(x) = SetTree.iter x tree - member s.Fold f x = SetTree.fold f tree x - -#if CHECKED - member s.CheckBalanceInvariant = checkInvariant tree // diagnostics... -#endif - member s.IsEmpty = SetTree.isEmpty tree - - member s.Partition f : Set<'T,'ComparerTag> * Set<'T,'ComparerTag> = - match tree with - | SetEmpty -> s,s - | _ -> - let t1,t2 = SetTree.partition comparer f tree - refresh s t1, refresh s t2 - - member s.Filter f : Set<'T,'ComparerTag> = - match tree with - | SetEmpty -> s - | _ -> SetTree.filter comparer f tree |> refresh s - - member s.Exists f = SetTree.exists f tree - - member s.ForAll f = SetTree.forAll f tree - - static member (-) ((a: Set<'T,'ComparerTag>),(b: Set<'T,'ComparerTag>)) = Set<_,_>.Difference(a,b) - - static member (+) ((a: Set<'T,'ComparerTag>),(b: Set<'T,'ComparerTag>)) = Set<_,_>.Union(a,b) - - static member Intersection((a: Set<'T,'ComparerTag>),(b: Set<'T,'ComparerTag>)) : Set<'T,'ComparerTag> = - match b.Tree with - | SetEmpty -> b // A INTER 0 = 0 - | _ -> - match a.Tree with - | SetEmpty -> a // 0 INTER B = 0 - | _ -> SetTree.intersection a.Comparer a.Tree b.Tree |> refresh a - - static member Union(a: Set<'T,'ComparerTag>,b: Set<'T,'ComparerTag>) : Set<'T,'ComparerTag> = - match b.Tree with - | SetEmpty -> a // A U 0 = A - | _ -> - match a.Tree with - | SetEmpty -> b // 0 U B = B - | _ -> SetTree.union a.Comparer a.Tree b.Tree |> refresh a - - static member Difference(a: Set<'T,'ComparerTag>,b: Set<'T,'ComparerTag>) : Set<'T,'ComparerTag> = - match a.Tree with - | SetEmpty -> a // 0 - B = 0 - | _ -> - match b.Tree with - | SetEmpty -> a // A - 0 = A - | _ -> SetTree.diff a.Comparer a.Tree b.Tree |> refresh a - - static member Equality(a: Set<'T,'ComparerTag>,b: Set<'T,'ComparerTag>) = - (SetTree.compare a.Comparer a.Tree b.Tree = 0) - - static member Compare(a: Set<'T,'ComparerTag>,b: Set<'T,'ComparerTag>) = - SetTree.compare a.Comparer a.Tree b.Tree - - member s.Choose = SetTree.choose tree - - member s.MinimumElement = SetTree.minimumElement tree - - member s.MaximumElement = SetTree.maximumElement tree - - member s.IsSubsetOf((y: Set<'T,'ComparerTag>)) = SetTree.subset comparer tree y.Tree - - member s.IsSupersetOf((y: Set<'T,'ComparerTag>)) = SetTree.subset comparer y.Tree tree - - member s.ToList () = SetTree.toList tree - - member s.ToArray () = SetTree.toArray tree - - override this.Equals(that) = - match that with - // Cast to the exact same type as this, otherwise not equal. - | :? Set<'T,'ComparerTag> as that -> ((this :> System.IComparable).CompareTo(that) = 0) - | _ -> false - - interface System.IComparable with - // Cast s2 to the exact same type as s1, see 4884. - // It is not OK to cast s2 to seq<'T>, since different compares could permute the elements. - member s1.CompareTo(s2: obj) = SetTree.compare s1.Comparer s1.Tree ((s2 :?> Set<'T,'ComparerTag>).Tree) - - member this.ComputeHashCode() = - let combineHash x y = (x <<< 1) + y + 631 - let mutable res = 0 - for x in this do - res <- combineHash res (Unchecked.hash x) - abs res - - override this.GetHashCode() = this.ComputeHashCode() - - interface ICollection<'T> with - member s.Add(_) = raise (new System.NotSupportedException("ReadOnlyCollection")) - member s.Clear() = raise (new System.NotSupportedException("ReadOnlyCollection")) - member s.Remove(_) = raise (new System.NotSupportedException("ReadOnlyCollection")) - member s.Contains(x) = SetTree.contains comparer x tree - member s.CopyTo(arr,i) = SetTree.copyToArray tree arr i - member s.IsReadOnly = true - member s.Count = SetTree.count tree - - interface IEnumerable<'T> with - member s.GetEnumerator() = SetTree.toSeq tree - - interface System.Collections.IEnumerable with - override s.GetEnumerator() = (SetTree.toSeq tree :> System.Collections.IEnumerator) - - static member Singleton(comparer,x) : Set<'T,'ComparerTag> = - Set<_,_>.Empty(comparer).Add(x) - - static member Create(comparer : 'ComparerTag,l : seq<'T>) : Set<'T,'ComparerTag> = - Set<_,_>(comparer=comparer, tree=SetTree.ofSeq comparer l) - - type internal Set<'T> = Set<'T, IComparer<'T>> diff --git a/src/utils/TaggedCollections.fsi b/src/utils/TaggedCollections.fsi deleted file mode 100644 index 24d029668d7..00000000000 --- a/src/utils/TaggedCollections.fsi +++ /dev/null @@ -1,119 +0,0 @@ -// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. - -/// This namespace contains FSharp.PowerPack extensions for the F# collection types -namespace Internal.Utilities.Collections.Tagged - - open System - open System.Collections.Generic - - /// Immutable sets based on binary trees, default tag - - /// Immutable sets where a constraint tag carries information about the class of key-comparer being used. - [] - type internal Set<'T,'ComparerTag> when 'ComparerTag :> IComparer<'T> = - - /// A useful shortcut for Set.add. Note this operation produces a new set - /// and does not mutate the original set. The new set will share many storage - /// nodes with the original. See the Set module for further operations on sets. - member Add : 'T -> Set<'T,'ComparerTag> - - /// A useful shortcut for Set.remove. Note this operation produces a new set - /// and does not mutate the original set. The new set will share many storage - /// nodes with the original. See the Set module for further operations on sets. - member Remove : 'T -> Set<'T,'ComparerTag> - - /// Return the number of elements in the set. - member Count : int - - /// A useful shortcut for Set.contains. See the Set module for further operations on sets. - member Contains : 'T -> bool - - /// A useful shortcut for Set.isEmpty. See the Set module for further operations on sets. - member IsEmpty : bool - - /// Apply the given function to each binding in the collection. - member Iterate : ('T -> unit) -> unit - - /// Apply the given accumulating function to all the elements of the set. - member Fold : ('T -> 'State -> 'State) -> 'State -> 'State - - /// Build two new sets, one containing the elements for which the given predicate returns True, - /// and another with the remaining elements. - member Partition: predicate:('T -> bool) -> Set<'T,'ComparerTag> * Set<'T,'ComparerTag> - - /// Return a new collection containing only the elements of the collection - /// for which the given predicate returns True. - member Filter: predicate:('T -> bool) -> Set<'T,'ComparerTag> - - /// Test if any element of the collection satisfies the given predicate. - /// If the input function is f and the elements are i0...iN then computes - /// p i0 or ... or p iN. - member Exists: predicate:('T -> bool) -> bool - - /// Test if all elements of the collection satisfy the given predicate. - /// If the input function is f and the elements are i0...iN and j0...jN then - /// computes p i0 && ... && p iN. - member ForAll: predicate:('T -> bool) -> bool - - /// A set based on the given comparer containing the given initial elements. - static member Create: 'ComparerTag * seq<'T> -> Set<'T,'ComparerTag> - - /// The empty set based on the given comparer. - static member Empty: 'ComparerTag -> Set<'T,'ComparerTag> - - /// A singleton set based on the given comparison operator. - static member Singleton: 'ComparerTag * 'T -> Set<'T,'ComparerTag> - - /// Compares two sets and returns True if they are equal or False otherwise. - static member Equality : Set<'T,'ComparerTag> * Set<'T,'ComparerTag> -> bool - - /// Compares a and b and returns 1 if a > b, -1 if b < a and 0 if a = b. - static member Compare : a:Set<'T,'ComparerTag> * b:Set<'T,'ComparerTag> -> int - - /// Return a new set with the elements of the second set removed from the first. - static member (-) : Set<'T,'ComparerTag> * Set<'T,'ComparerTag> -> Set<'T,'ComparerTag> - - /// Compute the union of the two sets. - static member (+) : Set<'T,'ComparerTag> * Set<'T,'ComparerTag> -> Set<'T,'ComparerTag> - - /// Compute the intersection of the two sets. - static member Intersection : Set<'T,'ComparerTag> * Set<'T,'ComparerTag> -> Set<'T,'ComparerTag> - - /// Compute the union of the two sets. - static member Union : Set<'T,'ComparerTag> * Set<'T,'ComparerTag> -> Set<'T,'ComparerTag> - - /// Return a new set with the elements of the second set removed from the first. - static member Difference: Set<'T,'ComparerTag> * Set<'T,'ComparerTag> -> Set<'T,'ComparerTag> - - /// The number of elements in the set. - member Choose : 'T - - /// Returns the lowest element in the set according to the ordering being used for the set. - member MinimumElement: 'T - - /// Returns the highest element in the set according to the ordering being used for the set. - member MaximumElement: 'T - - /// Evaluates to True if all elements of the second set are in the first. - member IsSubsetOf: Set<'T,'ComparerTag> -> bool - - /// Evaluates to True if all elements of the first set are in the second. - member IsSupersetOf: Set<'T,'ComparerTag> -> bool - - /// The elements of the set as a list. - member ToList : unit -> 'T list - - /// The elements of the set as an array. - member ToArray: unit -> 'T array - - interface ICollection<'T> - - interface IEnumerable<'T> - - interface System.Collections.IEnumerable - - interface System.IComparable - - override Equals : obj -> bool - - type internal Set<'T> = Set<'T, IComparer<'T>> \ No newline at end of file From c0dd6dddaa0db274473b8caea2eedb38e41b414e Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sun, 12 Aug 2018 08:42:22 +1000 Subject: [PATCH 87/92] Renamed comparers to be based off original names --- src/fsharp/CompileOps.fs | 10 ++-- src/fsharp/DetupleArgs.fs | 26 +++++----- src/fsharp/DetupleArgs.fsi | 12 ++--- src/fsharp/IlxGen.fs | 4 +- src/fsharp/InnerLambdasToTopLevelFuncs.fs | 62 +++++++++++------------ src/fsharp/Optimizer.fs | 2 +- src/fsharp/TastOps.fs | 32 ++++++------ src/fsharp/TastOps.fsi | 10 ++-- src/fsharp/TypeChecker.fs | 20 ++++---- src/fsharp/tast.fs | 20 ++++---- 10 files changed, 99 insertions(+), 99 deletions(-) diff --git a/src/fsharp/CompileOps.fs b/src/fsharp/CompileOps.fs index 5a041c8a063..e284b69ec43 100644 --- a/src/fsharp/CompileOps.fs +++ b/src/fsharp/CompileOps.fs @@ -5332,12 +5332,12 @@ let CheckSimulateException(tcConfig:TcConfig) = let qnameOrder = Order.orderBy (fun (q:QualifiedNameOfFile) -> q.Text) [] -type QualifiedNameOfFileByText = +type QNameOrder = interface System.Collections.Generic.IComparer with member __.Compare(v1, v2) = qnameOrder.Compare (v1,v2) -type RootSigs = zmap -type RootImpls = zset +type RootSigs = zmap +type RootImpls = zset type TcState = { tcsCcu: CcuThunk @@ -5408,8 +5408,8 @@ let GetInitialTcState(m, ccuName, tcConfig:TcConfig, tcGlobals, tcImports:TcImpo tcsTcSigEnv=tcEnv0 tcsTcImplEnv=tcEnv0 tcsCreatesGeneratedProvidedTypes=false - tcsRootSigs = Zmap.empty () - tcsRootImpls = SetCustom.empty () + tcsRootSigs = Zmap.empty () + tcsRootImpls = SetCustom.empty () tcsCcuSig = NewEmptyModuleOrNamespaceType Namespace } diff --git a/src/fsharp/DetupleArgs.fs b/src/fsharp/DetupleArgs.fs index 35bdae056e7..83f0b44ba47 100644 --- a/src/fsharp/DetupleArgs.fs +++ b/src/fsharp/DetupleArgs.fs @@ -165,7 +165,7 @@ module GlobalUsageAnalysis = let GetValsBoundInExpr expr = let folder = {ExprFolder0 with valBindingSiteIntercept = bindAccBounds} - let z0 = SetCustom.empty () + let z0 = SetCustom.empty () let z = FoldExpr folder z0 expr z @@ -183,22 +183,22 @@ module GlobalUsageAnalysis = /// (b) log it's binding site representation. type Results = { /// v -> context / APP inst args - Uses : zmap + Uses : zmap /// v -> binding repr - Defns : zmap + Defns : zmap /// bound in a decision tree? - DecisionTreeBindings : zset + DecisionTreeBindings : zset /// v -> v list * recursive? -- the others in the mutual binding - RecursiveBindings : zmap - TopLevelBindings : zset + RecursiveBindings : zmap + TopLevelBindings : zset IterationIsAtTopLevel : bool } let z0 = - { Uses = Zmap.empty () - Defns = Zmap.empty () - RecursiveBindings = Zmap.empty () - DecisionTreeBindings = SetCustom.empty () - TopLevelBindings = SetCustom.empty () + { Uses = Zmap.empty () + Defns = Zmap.empty () + RecursiveBindings = Zmap.empty () + DecisionTreeBindings = SetCustom.empty () + TopLevelBindings = SetCustom.empty () IterationIsAtTopLevel = true } /// Log the use of a value with a particular tuple chape at a callsite @@ -613,7 +613,7 @@ let determineTransforms g (z : GlobalUsageAnalysis.Results) = decideTransform g z f callPatterns (m, tps, vss, rty) // make transform (if required) let vtransforms = Zmap.chooseL selectTransform z.Uses - let vtransforms = Zmap.ofList vtransforms + let vtransforms = Zmap.ofList vtransforms vtransforms @@ -624,7 +624,7 @@ let determineTransforms g (z : GlobalUsageAnalysis.Results) = type penv = { // The planned transforms - transforms : zmap + transforms : zmap ccu : CcuThunk g : TcGlobals } diff --git a/src/fsharp/DetupleArgs.fsi b/src/fsharp/DetupleArgs.fsi index 8dc18d71096..babe5e20ba1 100644 --- a/src/fsharp/DetupleArgs.fsi +++ b/src/fsharp/DetupleArgs.fsi @@ -10,7 +10,7 @@ open Microsoft.FSharp.Compiler.TcGlobals val DetupleImplFile : CcuThunk -> TcGlobals -> TypedImplFile -> TypedImplFile module GlobalUsageAnalysis = - val GetValsBoundInExpr : Expr -> zset + val GetValsBoundInExpr : Expr -> zset type accessor @@ -19,15 +19,15 @@ module GlobalUsageAnalysis = /// Later could support "safe" change operations, and optimisations could be in terms of those. type Results = { /// v -> context / APP inst args - Uses : zmap + Uses : zmap /// v -> binding repr - Defns : zmap + Defns : zmap /// bound in a decision tree? - DecisionTreeBindings : zset + DecisionTreeBindings : zset /// v -> recursive? * v list -- the others in the mutual binding - RecursiveBindings : zmap + RecursiveBindings : zmap /// val not defined under lambdas - TopLevelBindings : zset + TopLevelBindings : zset /// top of expr toplevel? (true) IterationIsAtTopLevel : bool; } diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index 601cd541ba1..f9d917b6c1c 100644 --- a/src/fsharp/IlxGen.fs +++ b/src/fsharp/IlxGen.fs @@ -3663,7 +3663,7 @@ and GenObjectExpr cenv cgbuf eenvouter expr (baseType,baseValOpt,basecall,overri and GenSequenceExpr cenv (cgbuf:CodeGenBuffer) eenvouter (nextEnumeratorValRef:ValRef,pcvref:ValRef,currvref:ValRef,stateVars,generateNextExpr,closeExpr,checkCloseExpr:Expr,seqElemTy, m) sequel = let stateVars = [ pcvref; currvref ] @ stateVars - let stateVarsSet = stateVars |> List.map (fun vref -> vref.Deref) |> SetCustom.ofList + let stateVarsSet = stateVars |> List.map (fun vref -> vref.Deref) |> SetCustom.ofList // pretend that the state variables are bound let eenvouter = @@ -4651,7 +4651,7 @@ and GenLetRecBindings cenv cgbuf eenv (allBinds: Bindings,m) = let fixups = ref [] - let recursiveVars = SetCustom.ofList (bindsPossiblyRequiringFixup |> List.map (fun v -> v.Var)) + let recursiveVars = SetCustom.ofList (bindsPossiblyRequiringFixup |> List.map (fun v -> v.Var)) let _ = (recursiveVars, bindsPossiblyRequiringFixup) ||> List.fold (fun forwardReferenceSet (bind:Binding) -> // Compute fixups diff --git a/src/fsharp/InnerLambdasToTopLevelFuncs.fs b/src/fsharp/InnerLambdasToTopLevelFuncs.fs index b0cfd316c41..1b88d2fc849 100644 --- a/src/fsharp/InnerLambdasToTopLevelFuncs.fs +++ b/src/fsharp/InnerLambdasToTopLevelFuncs.fs @@ -137,7 +137,7 @@ let GetValsBoundUnderMustInline xinfo = if v.InlineInfo = ValInline.PseudoVal then Set.union (GetValsBoundInExpr repr) rejectS else rejectS - let rejectS = SetCustom.empty () + let rejectS = SetCustom.empty () let rejectS = Zmap.fold accRejectFrom xinfo.Defns rejectS rejectS @@ -213,7 +213,7 @@ module Pass1_DetermineTLRAndArities = let rejectS = GetValsBoundUnderMustInline xinfo let fArities = List.filter (fun (v,_) -> not (SetCustom.contains v rejectS)) fArities (*-*) - let tlrS = SetCustom.ofList (List.map fst fArities) + let tlrS = SetCustom.ofList (List.map fst fArities) let topValS = xinfo.TopLevelBindings (* genuinely top level *) let topValS = SetCustom.filter (IsMandatoryNonTopLevel g >> not) topValS (* restrict *) (* REPORT MISSED CASES *) @@ -223,7 +223,7 @@ module Pass1_DetermineTLRAndArities = missed |> SetCustom.iter (fun v -> dprintf "TopLevel but not TLR = %s\n" v.LogicalName) #endif (* REPORT OVER *) - let arityM = Zmap.ofList fArities + let arityM = Zmap.ofList fArities #if DEBUG if verboseTLR then DumpArity arityM #endif @@ -292,7 +292,7 @@ module Pass1_DetermineTLRAndArities = /// [Each fclass has an env, the fclass are the handles to envs.] type BindingGroupSharingSameReqdItems(bindings: Bindings) = let vals = valsOfBinds bindings - let vset = SetCustom.ofList vals + let vset = SetCustom.ofList vals member fclass.Vals = vals @@ -304,10 +304,10 @@ type BindingGroupSharingSameReqdItems(bindings: Bindings) = override fclass.ToString() = "+" + String.concat "+" (List.map nameOfVal vals) -let fclassOrder = Order.orderOn (fun (b: BindingGroupSharingSameReqdItems) -> b.Vals) (List.order (ValByStamp ())) +let fclassOrder = Order.orderOn (fun (b: BindingGroupSharingSameReqdItems) -> b.Vals) (List.order (ValOrder ())) [] -type BindingGroupSharingSameReqdItemsByVals = +type FclassOrder = interface System.Collections.Generic.IComparer with member __.Compare(v1, v2) = fclassOrder.Compare (v1,v2) @@ -329,7 +329,7 @@ let reqdItemOrder = | ReqdSubEnv v -> true ,v | ReqdVal v -> false,v - Order.orderOn rep (Pair.order (Bool.order, (ValByStamp ()))) + Order.orderOn rep (Pair.order (Bool.order, (ValOrder ()))) [] type ReqdItemOrder = @@ -340,7 +340,7 @@ type ReqdItemOrder = /// The reqdTypars are the free reqdTypars of the defns, and those required by any direct TLR arity-met calls. /// The reqdItems are the ids/subEnvs required from calls to freeVars. type ReqdItemsForDefn = - { reqdTypars : zset + { reqdTypars : zset reqdItems : zset m : Range.range } member env.ReqdSubEnvs = [ for x in env.reqdItems do match x.CompareObj with | ReqdSubEnv f -> yield f | ReqdVal _ -> () ] @@ -352,7 +352,7 @@ type ReqdItemsForDefn = reqdItems = SetCustom.addList items env.reqdItems} static member Initial typars m = - {reqdTypars = SetCustom.ofList typars + {reqdTypars = SetCustom.ofList typars reqdItems = SetCustom.empty () m = m } @@ -367,7 +367,7 @@ type ReqdItemsForDefn = // pass2: collector - state //------------------------------------------------------------------------- -type Generators = zset +type Generators = zset /// check a named function value applied to sufficient arguments let IsArityMet (vref:ValRef) wf (tys: TypeInst) args = @@ -426,18 +426,18 @@ module Pass2_DetermineReqdItems = /// recShortCalls to f will require a binding for f in terms of fHat within the fHatBody. type state = { stack : (BindingGroupSharingSameReqdItems * Generators * ReqdItemsForDefn) list - reqdItemsMap : zmap - fclassM : zmap + reqdItemsMap : zmap + fclassM : zmap revDeclist : BindingGroupSharingSameReqdItems list - recShortCallS : zset + recShortCallS : zset } let state0 = { stack = [] - reqdItemsMap = Zmap.empty () - fclassM = Zmap.empty () + reqdItemsMap = Zmap.empty () + fclassM = Zmap.empty () revDeclist = [] - recShortCallS = SetCustom.empty () } + recShortCallS = SetCustom.empty () } /// PUSH = start collecting for fclass let PushFrame (fclass: BindingGroupSharingSameReqdItems) (reqdTypars0,reqdVals0,m) state = @@ -464,7 +464,7 @@ module Pass2_DetermineReqdItems = /// Log requirements for gv in the relevant stack frames let LogRequiredFrom gv items state = - let logIntoFrame (fclass, reqdVals0:zset, env: ReqdItemsForDefn) = + let logIntoFrame (fclass, reqdVals0:zset, env: ReqdItemsForDefn) = let env = if reqdVals0 |> SetCustom.contains gv then env.Extend ([],items) @@ -524,7 +524,7 @@ module Pass2_DetermineReqdItems = let reqdVals0 = frees.FreeLocals |> SetCustom.elements // tlrBs are not reqdVals0 for themselves let reqdVals0 = reqdVals0 |> List.filter (fun gv -> not (fclass.Contains gv)) - let reqdVals0 = reqdVals0 |> SetCustom.ofList + let reqdVals0 = reqdVals0 |> SetCustom.ofList // collect into env over bodies let z = PushFrame fclass (reqdTypars0,reqdVals0,m) z let z = (z,tlrBs) ||> List.fold (foldOn (fun b -> b.Expr) exprF) @@ -691,7 +691,7 @@ exception AbortTLR of Range.range /// and TBIND(asubEnvi = aenvFor(v)) for each (asubEnvi,v) in cmap(subEnvk) ranging over required subEnvk. /// where /// aenvFor(v) = aenvi where (v,aenvi) in cmap. -let FlatEnvPacks g fclassM topValS declist (reqdItemsMap: zmap) = +let FlatEnvPacks g fclassM topValS declist (reqdItemsMap: zmap) = let fclassOf f = Zmap.force f fclassM ("fclassM",nameOfVal) let packEnv carrierMaps (fc:BindingGroupSharingSameReqdItems) = if verboseTLR then dprintf "\ntlr: packEnv fc=%A\n" fc @@ -703,7 +703,7 @@ let FlatEnvPacks g fclassM topValS declist (reqdItemsMap: zmap SetCustom.ofList |> SetCustom.elements // noRepeats + let vals = vals |> SetCustom.ofList |> SetCustom.elements // noRepeats // Remove genuinely toplevel, no need to close over these let vals = vals |> List.filter (IsMandatoryTopLevel >> not) @@ -749,7 +749,7 @@ let FlatEnvPacks g fclassM topValS declist (reqdItemsMap: zmap List.map (fun v -> (v,(mkCompGenLocal env.m v.LogicalName v.Type |> fst))) - let cmap = Zmap.ofList cmapPairs + let cmap = Zmap.ofList cmapPairs let aenvFor v = Zmap.force v cmap ("aenvFor",nameOfVal) let aenvExprFor v = exprForVal env.m (aenvFor v) @@ -784,9 +784,9 @@ let FlatEnvPacks g fclassM topValS declist (reqdItemsMap: zmap () + let carriedMaps = Zmap.empty () let envPacks,_carriedMaps = List.mapFold packEnv carriedMaps declist (* List.mapFold in dec order *) - let envPacks = Zmap.ofList envPacks + let envPacks = Zmap.ofList envPacks envPacks @@ -852,7 +852,7 @@ let CreateNewValuesForTLR g tlrS arityM fclassM envPackM = let fs = SetCustom.elements tlrS let ffHats = List.map (fun f -> f,createFHat f) fs - let fHatM = Zmap.ofList ffHats + let fHatM = Zmap.ofList ffHats fHatM @@ -865,14 +865,14 @@ module Pass4_RewriteAssembly = type RewriteContext = { ccu : CcuThunk g : TcGlobals - tlrS : zset - topValS : zset - arityM : zmap - fclassM : zmap - recShortCallS : zset - envPackM : zmap + tlrS : zset + topValS : zset + arityM : zmap + fclassM : zmap + recShortCallS : zset + envPackM : zmap /// The mapping from 'f' values to 'fHat' values - fHatM : zmap + fHatM : zmap } diff --git a/src/fsharp/Optimizer.fs b/src/fsharp/Optimizer.fs index ee80eff844d..50168719fcd 100644 --- a/src/fsharp/Optimizer.fs +++ b/src/fsharp/Optimizer.fs @@ -3081,7 +3081,7 @@ and OptimizeModuleExpr cenv env x = // Check the thing is not compiled as a static field or property, since reflected definitions and other reflective stuff might need it not (IsCompiledAsStaticProperty cenv.g bind.Var)) - let deadSet = SetCustom.ofList (dead |> List.map (fun (bind, _) -> bind.Var)) + let deadSet = SetCustom.ofList (dead |> List.map (fun (bind, _) -> bind.Var)) // Eliminate dead private bindings from a module type by mutation. Note that the optimizer doesn't // actually copy the entire term - it copies the expression portions of the term and leaves the diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index 1f3536cf731..13508208d07 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -1814,11 +1814,11 @@ let ValRefIsExplicitImpl g (vref:ValRef) = ValIsExplicitImpl g vref.Deref // an equation assigned by type inference. //--------------------------------------------------------------------------- -let emptyFreeLocals = SetCustom.empty () +let emptyFreeLocals = SetCustom.empty () let emptyFreeRecdFields = SetCustom.empty () let emptyFreeUnionCases = SetCustom.empty () -let emptyFreeTycons = SetCustom.empty () -let emptyFreeTypars = SetCustom.empty () +let emptyFreeTycons = SetCustom.empty () +let emptyFreeTypars = SetCustom.empty () let emptyFreeTyvars = { FreeTycons = emptyFreeTycons @@ -2485,24 +2485,24 @@ module SimplifyTypes = // Walk type to determine typars and their counts (for pprinting decisions) foldTypeButNotConstraints (fun z ty -> match ty with | TType_var tp when tp.Rigidity = TyparRigidity.Rigid -> incM tp z | _ -> z) z ty - let emptyTyparCounts = Zmap.empty () + let emptyTyparCounts = Zmap.empty () // print multiple fragments of the same type using consistent naming and formatting let accTyparCountsMulti acc l = List.fold accTyparCounts acc l type TypeSimplificationInfo = - { singletons : zset - inplaceConstraints : zmap + { singletons : zset + inplaceConstraints : zmap postfixConstraints : (Typar * TyparConstraint) list } let typeSimplificationInfo0 = - { singletons = SetCustom.empty () - inplaceConstraints = Zmap.empty () + { singletons = SetCustom.empty () + inplaceConstraints = Zmap.empty () postfixConstraints = [] } let categorizeConstraints simplify m cxs = let singletons = if simplify then Zmap.chooseL (fun tp n -> if n = 1 then Some tp else None) m else [] - let singletons = SetCustom.ofList singletons + let singletons = SetCustom.ofList singletons // Here, singletons are typars that occur once in the type. // However, they may also occur in a type constraint. // If they do, they are really multiple occurrence - so we should remove them. @@ -3768,16 +3768,16 @@ type SignatureRepackageInfo = static member Empty = { mrpiVals = []; mrpiEntities= [] } type SignatureHidingInfo = - { mhiTycons : zset; - mhiTyconReprs : zset; - mhiVals : zset + { mhiTycons : zset; + mhiTyconReprs : zset; + mhiVals : zset mhiRecdFields : zset; mhiUnionCases : zset } static member Empty = - { mhiTycons = SetCustom.empty () - mhiTyconReprs = SetCustom.empty () - mhiVals = SetCustom.empty () + { mhiTycons = SetCustom.empty () + mhiTyconReprs = SetCustom.empty () + mhiVals = SetCustom.empty () mhiRecdFields = SetCustom.empty () mhiUnionCases = SetCustom.empty () } @@ -7683,7 +7683,7 @@ type PrettyNaming.ActivePatternInfo with // not by their argument types. let doesActivePatternHaveFreeTypars g (v:ValRef) = let vty = v.TauType - let vtps = v.Typars |> SetCustom.ofList + let vtps = v.Typars |> SetCustom.ofList if not (isFunTy g v.TauType) then errorR(Error(FSComp.SR.activePatternIdentIsNotFunctionTyped(v.LogicalName), v.Range)) let argtys, resty = stripFunTy g vty diff --git a/src/fsharp/TastOps.fsi b/src/fsharp/TastOps.fsi index e228cec2cec..140342e2fad 100755 --- a/src/fsharp/TastOps.fsi +++ b/src/fsharp/TastOps.fsi @@ -741,8 +741,8 @@ val prefixOfRigidTypar : Typar -> string /// Utilities used in simplifying types for visual presentation module SimplifyTypes = type TypeSimplificationInfo = - { singletons : zset - inplaceConstraints : zmap + { singletons : zset + inplaceConstraints : zmap postfixConstraints : TyparConstraintsWithTypars; } val typeSimplificationInfo0 : TypeSimplificationInfo val CollectInfo : bool -> TType list -> TyparConstraintsWithTypars -> TypeSimplificationInfo @@ -846,9 +846,9 @@ type SignatureRepackageInfo = static member Empty : SignatureRepackageInfo type SignatureHidingInfo = - { mhiTycons : zset - mhiTyconReprs : zset - mhiVals : zset + { mhiTycons : zset + mhiTyconReprs : zset + mhiVals : zset mhiRecdFields : zset mhiUnionCases : zset } static member Empty : SignatureHidingInfo diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index 4042a647b7a..0f9b926e4cf 100755 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -11588,14 +11588,14 @@ and TcIncrementalLetRecGeneralization cenv scopem //printfn "(failed generalization test 1 for binding for %s)" pgrbind.RecBindingInfo.Val.DisplayName // Any declared type parameters in an type are always generalizable - let freeInBinding = Set.diff freeInBinding (SetCustom.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.ExtraGeneralizableTypars)) + let freeInBinding = Set.diff freeInBinding (SetCustom.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.ExtraGeneralizableTypars)) if freeInBinding.IsEmpty then true else //printfn "(failed generalization test 2 for binding for %s)" pgrbind.RecBindingInfo.Val.DisplayName // Any declared method parameters can always be generalized - let freeInBinding = Set.diff freeInBinding (SetCustom.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.RecBindingInfo.DeclaredTypars)) + let freeInBinding = Set.diff freeInBinding (SetCustom.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.RecBindingInfo.DeclaredTypars)) if freeInBinding.IsEmpty then true else @@ -11651,8 +11651,8 @@ and TcIncrementalLetRecGeneralization cenv scopem freeInEnv else let freeInBinding = (freeInType CollectAllNoCaching pgrbind.RecBindingInfo.Val.TauType).FreeTypars - let freeInBinding = Set.diff freeInBinding (SetCustom.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.ExtraGeneralizableTypars)) - let freeInBinding = Set.diff freeInBinding (SetCustom.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.RecBindingInfo.DeclaredTypars)) + let freeInBinding = Set.diff freeInBinding (SetCustom.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.ExtraGeneralizableTypars)) + let freeInBinding = Set.diff freeInBinding (SetCustom.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.RecBindingInfo.DeclaredTypars)) Set.union freeInBinding freeInEnv) // Process the bindings marked for transition from PreGeneralization --> PostGeneralization @@ -11686,7 +11686,7 @@ and TcIncrementalLetRecGeneralization cenv scopem /// Compute the type variables which may be generalized and perform the generalization and TcLetrecComputeAndGeneralizeGenericTyparsForBinding cenv denv freeInEnv (pgrbind : PreGeneralizationRecursiveBinding) = - let freeInEnv = Set.diff freeInEnv (SetCustom.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.ExtraGeneralizableTypars)) + let freeInEnv = Set.diff freeInEnv (SetCustom.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.ExtraGeneralizableTypars)) let rbinfo = pgrbind.RecBindingInfo let vspec = rbinfo.Val @@ -12420,15 +12420,15 @@ module IncrClassChecking = TakenFieldNames:Set RepInfoTcGlobals:TcGlobals /// vals mapped to representations - ValReprs : zmap + ValReprs : zmap /// vals represented as fields or members from this point on - ValsWithRepresentation : zset } + ValsWithRepresentation : zset } static member Empty(g, names) = { TakenFieldNames=Set.ofList names RepInfoTcGlobals=g - ValReprs = Zmap.empty () - ValsWithRepresentation = SetCustom.empty () } + ValReprs = Zmap.empty () + ValsWithRepresentation = SetCustom.empty () } /// Find the representation of a value member localRep.LookupRepr (v:Val) = @@ -15979,7 +15979,7 @@ module TcDeclarations = else let isInSameModuleOrNamespace = match envForDecls.eModuleOrNamespaceTypeAccumulator.Value.TypesByMangledName.TryFind(tcref.LogicalName) with - | Some tycon -> (TyconByStamp.Compare tcref.Deref tycon) = 0 + | Some tycon -> (TyconOrder.Compare tcref.Deref tycon) = 0 | None -> //false // There is a special case we allow when compiling FSharp.Core.dll which permits interface implementations across namespace fragments diff --git a/src/fsharp/tast.fs b/src/fsharp/tast.fs index 62c7ce765d6..740194c8568 100644 --- a/src/fsharp/tast.fs +++ b/src/fsharp/tast.fs @@ -1934,17 +1934,17 @@ and [] and ModuleOrNamespace = Entity and Tycon = Entity -and [] TyconByStamp = +and [] TyconOrder = static member inline Compare (v1:Tycon) (v2:Tycon) = v1.Stamp.CompareTo v2.Stamp interface IComparer with member __.Compare(v1, v2) = - TyconByStamp.Compare v1 v2 + TyconOrder.Compare v1 v2 and [] RecdFieldRefOrder = static member Compare (RFRef(tcref1, nm1)) (RFRef(tcref2, nm2)) = - let c = TyconByStamp.Compare tcref1.Deref tcref2.Deref + let c = TyconOrder.Compare tcref1.Deref tcref2.Deref if c <> 0 then c else compare nm1 nm2 @@ -1954,7 +1954,7 @@ and [] RecdFieldRefOrder = and [] UnionCaseRefOrder = interface IComparer with member __.Compare(UCRef(tcref1, nm1), UCRef(tcref2, nm2)) = - let c = TyconByStamp.Compare tcref1.Deref tcref2.Deref + let c = TyconOrder.Compare tcref1.Deref tcref2.Deref if c <> 0 then c else compare nm1 nm2 @@ -2304,7 +2304,7 @@ and override x.ToString() = x.Name -and [] TyparByStamp = +and [] TyparOrder = interface IComparer with member __.Compare(v1: Typar, v2: Typar): int = v1.Stamp.CompareTo v2.Stamp @@ -2993,13 +2993,13 @@ and [] override x.ToString() = x.LogicalName -and [] ValByStamp = +and [] ValOrder = static member inline Compare (v1:Val) (v2:Val) = v1.Stamp.CompareTo v2.Stamp interface IComparer with member __.Compare(v1, v2) = - ValByStamp.Compare v1 v2 + ValOrder.Compare v1 v2 and /// Represents the extra information stored for a member @@ -4998,14 +4998,14 @@ and //--------------------------------------------------------------------------- /// Represents a set of free local values. -and FreeLocals = Internal.Utilities.Collections.zset +and FreeLocals = Internal.Utilities.Collections.zset /// Represents a set of free type parameters -and FreeTypars = Internal.Utilities.Collections.zset +and FreeTypars = Internal.Utilities.Collections.zset /// Represents a set of 'free' named type definitions. Used to collect the named type definitions referred to /// from a type or expression. -and FreeTycons = Internal.Utilities.Collections.zset +and FreeTycons = Internal.Utilities.Collections.zset /// Represents a set of 'free' record field definitions. Used to collect the record field definitions referred to /// from an expression. From a21cb4d393cefab133714603fff1c269abc81f5b Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sun, 12 Aug 2018 08:45:35 +1000 Subject: [PATCH 88/92] Renamed SetCustom to Zset --- src/fsharp/CompileOps.fs | 10 +- src/fsharp/DetupleArgs.fs | 12 +-- src/fsharp/FindUnsolved.fs | 2 +- src/fsharp/IlxGen.fs | 24 ++--- src/fsharp/InnerLambdasToTopLevelFuncs.fs | 66 ++++++------- src/fsharp/LowerCallsAndSeqs.fs | 2 +- src/fsharp/NicePrint.fs | 4 +- src/fsharp/Optimizer.fs | 52 +++++----- src/fsharp/PostInferenceChecks.fs | 4 +- src/fsharp/TastOps.fs | 112 +++++++++++----------- src/fsharp/TypeChecker.fs | 38 ++++---- src/fsharp/TypeRelations.fs | 2 +- src/fsharp/autobox.fs | 4 +- src/utils/SortKey.fs | 2 +- 14 files changed, 167 insertions(+), 167 deletions(-) diff --git a/src/fsharp/CompileOps.fs b/src/fsharp/CompileOps.fs index e284b69ec43..e2ced3b1f45 100644 --- a/src/fsharp/CompileOps.fs +++ b/src/fsharp/CompileOps.fs @@ -5409,7 +5409,7 @@ let GetInitialTcState(m, ccuName, tcConfig:TcConfig, tcGlobals, tcImports:TcImpo tcsTcImplEnv=tcEnv0 tcsCreatesGeneratedProvidedTypes=false tcsRootSigs = Zmap.empty () - tcsRootImpls = SetCustom.empty () + tcsRootImpls = Zset.empty () tcsCcuSig = NewEmptyModuleOrNamespaceType Namespace } @@ -5434,7 +5434,7 @@ let TypeCheckOneInputEventually (checkForErrors, tcConfig:TcConfig, tcImports:Tc errorR(Error(FSComp.SR.buildSignatureAlreadySpecified(qualNameOfFile.Text), m.StartRange)) // Check if the implementation came first in compilation order - if SetCustom.contains qualNameOfFile tcState.tcsRootImpls then + if Zset.contains qualNameOfFile tcState.tcsRootImpls then errorR(Error(FSComp.SR.buildImplementationAlreadyGivenDetail(qualNameOfFile.Text), m)) // Typecheck the signature file @@ -5469,7 +5469,7 @@ let TypeCheckOneInputEventually (checkForErrors, tcConfig:TcConfig, tcImports:Tc let rootSigOpt = tcState.tcsRootSigs.TryFind {CompareObj=qualNameOfFile} // Check if we've already seen an implementation for this fragment - if SetCustom.contains qualNameOfFile tcState.tcsRootImpls then + if Zset.contains qualNameOfFile tcState.tcsRootImpls then errorR(Error(FSComp.SR.buildImplementationAlreadyGiven(qualNameOfFile.Text), m)) let tcImplEnv = tcState.tcsTcImplEnv @@ -5481,7 +5481,7 @@ let TypeCheckOneInputEventually (checkForErrors, tcConfig:TcConfig, tcImports:Tc let hadSig = rootSigOpt.IsSome let implFileSigType = SigTypeOfImplFile implFile - let rootImpls = SetCustom.add qualNameOfFile tcState.tcsRootImpls + let rootImpls = Zset.add qualNameOfFile tcState.tcsRootImpls // Only add it to the environment if it didn't have a signature let m = qualNameOfFile.Range @@ -5556,7 +5556,7 @@ let TypeCheckClosedInputSetFinish (declaredImpls: TypedImplFile list, tcState) = // Check all interfaces have implementations tcState.tcsRootSigs |> Zmap.iter (fun qualNameOfFile _ -> - if not (SetCustom.contains qualNameOfFile tcState.tcsRootImpls) then + if not (Zset.contains qualNameOfFile tcState.tcsRootImpls) then errorR(Error(FSComp.SR.buildSignatureWithoutImplementation(qualNameOfFile.Text), qualNameOfFile.Range))) tcState, declaredImpls diff --git a/src/fsharp/DetupleArgs.fs b/src/fsharp/DetupleArgs.fs index 83f0b44ba47..40dab48cb94 100644 --- a/src/fsharp/DetupleArgs.fs +++ b/src/fsharp/DetupleArgs.fs @@ -161,11 +161,11 @@ let (|TyappAndApp|_|) e = //------------------------------------------------------------------------- module GlobalUsageAnalysis = - let bindAccBounds vals (_isInDTree, v) = SetCustom.add v vals + let bindAccBounds vals (_isInDTree, v) = Zset.add v vals let GetValsBoundInExpr expr = let folder = {ExprFolder0 with valBindingSiteIntercept = bindAccBounds} - let z0 = SetCustom.empty () + let z0 = Zset.empty () let z = FoldExpr folder z0 expr z @@ -197,8 +197,8 @@ module GlobalUsageAnalysis = { Uses = Zmap.empty () Defns = Zmap.empty () RecursiveBindings = Zmap.empty () - DecisionTreeBindings = SetCustom.empty () - TopLevelBindings = SetCustom.empty () + DecisionTreeBindings = Zset.empty () + TopLevelBindings = Zset.empty () IterationIsAtTopLevel = true } /// Log the use of a value with a particular tuple chape at a callsite @@ -211,8 +211,8 @@ module GlobalUsageAnalysis = /// Log the definition of a binding let logBinding z (isInDTree, v) = - let z = if isInDTree then {z with DecisionTreeBindings = SetCustom.add v z.DecisionTreeBindings} else z - let z = if z.IterationIsAtTopLevel then {z with TopLevelBindings = SetCustom.add v z.TopLevelBindings} else z + let z = if isInDTree then {z with DecisionTreeBindings = Zset.add v z.DecisionTreeBindings} else z + let z = if z.IterationIsAtTopLevel then {z with TopLevelBindings = Zset.add v z.TopLevelBindings} else z z diff --git a/src/fsharp/FindUnsolved.fs b/src/fsharp/FindUnsolved.fs index 0aeb9726956..4f2f29d46c1 100644 --- a/src/fsharp/FindUnsolved.fs +++ b/src/fsharp/FindUnsolved.fs @@ -24,7 +24,7 @@ type cenv = mutable unsolved: Typars } let accTy cenv _env ty = - (freeInType CollectTyparsNoCaching (tryNormalizeMeasureInType cenv.g ty)).FreeTypars |> SetCustom.iter (fun tp -> + (freeInType CollectTyparsNoCaching (tryNormalizeMeasureInType cenv.g ty)).FreeTypars |> Zset.iter (fun tp -> if (tp.Rigidity <> TyparRigidity.Rigid) then cenv.unsolved <- tp :: cenv.unsolved) diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index f9d917b6c1c..ecc76f8eb33 100644 --- a/src/fsharp/IlxGen.fs +++ b/src/fsharp/IlxGen.fs @@ -3663,7 +3663,7 @@ and GenObjectExpr cenv cgbuf eenvouter expr (baseType,baseValOpt,basecall,overri and GenSequenceExpr cenv (cgbuf:CodeGenBuffer) eenvouter (nextEnumeratorValRef:ValRef,pcvref:ValRef,currvref:ValRef,stateVars,generateNextExpr,closeExpr,checkCloseExpr:Expr,seqElemTy, m) sequel = let stateVars = [ pcvref; currvref ] @ stateVars - let stateVarsSet = stateVars |> List.map (fun vref -> vref.Deref) |> SetCustom.ofList + let stateVarsSet = stateVars |> List.map (fun vref -> vref.Deref) |> Zset.ofList // pretend that the state variables are bound let eenvouter = @@ -3701,7 +3701,7 @@ and GenSequenceExpr cenv (cgbuf:CodeGenBuffer) eenvouter (nextEnumeratorValRef:V ... *) /// State variables always get zero-initialized - if stateVarsSet |> SetCustom.contains fv then + if stateVarsSet |> Zset.contains fv then GenDefaultValue cenv cgbuf eenv (fv.Type,m) else GenGetLocalVal cenv cgbuf eenv m fv None @@ -3743,7 +3743,7 @@ and GenSequenceExpr cenv (cgbuf:CodeGenBuffer) eenvouter (nextEnumeratorValRef:V for fv in cloFreeVars do /// State variables always get zero-initialized - if stateVarsSet |> SetCustom.contains fv then + if stateVarsSet |> Zset.contains fv then GenDefaultValue cenv cgbuf eenvouter (fv.Type,m) else GenGetLocalVal cenv cgbuf eenvouter m fv None @@ -3903,7 +3903,7 @@ and GetIlxClosureFreeVars cenv m selfv eenvouter takenNames expr = // pointer which gives the current closure itself. This is in the case e.g. let rec f = ... f ... let cloFreeVars = cloFreeVarResults.FreeLocals - |> SetCustom.elements + |> Zset.elements |> List.filter (fun fv -> match StorageForVal m fv eenvouter with | (StaticField _ | StaticProperty _ | Method _ | Null) -> false @@ -3924,8 +3924,8 @@ and GetIlxClosureFreeVars cenv m selfv eenvouter takenNames expr = // -- "internal" ones, which get used internally in the implementation let cloContractFreeTyvarSet = (freeInType CollectTypars (tyOfExpr cenv.g expr)).FreeTypars - let cloInternalFreeTyvars = Set.diff cloFreeVarResults.FreeTyvars.FreeTypars cloContractFreeTyvarSet |> SetCustom.elements - let cloContractFreeTyvars = cloContractFreeTyvarSet |> SetCustom.elements + let cloInternalFreeTyvars = Set.diff cloFreeVarResults.FreeTyvars.FreeTypars cloContractFreeTyvarSet |> Zset.elements + let cloContractFreeTyvars = cloContractFreeTyvarSet |> Zset.elements let cloFreeTyvars = cloContractFreeTyvars @ cloInternalFreeTyvars @@ -4638,20 +4638,20 @@ and GenLetRecBindings cenv cgbuf eenv (allBinds: Bindings,m) = let selfv = (match e with Expr.Obj _ -> None | _ when isLocalTypeFunc -> None | _ -> Option.map mkLocalValRef selfv) let clo,_,eenvclo = GetIlxClosureInfo cenv m isLocalTypeFunc selfv {eenv with letBoundVars=(mkLocalValRef boundv)::eenv.letBoundVars} e clo.cloFreeVars |> List.iter (fun fv -> - if SetCustom.contains fv forwardReferenceSet then + if Zset.contains fv forwardReferenceSet then match StorageForVal m fv eenvclo with | Env (_,_,ilField,_) -> fixups := (boundv, fv, (fun () -> GenLetRecFixup cenv cgbuf eenv (clo.cloSpec,access,ilField,exprForVal m fv,m))) :: !fixups | _ -> error (InternalError("GenLetRec: " + fv.LogicalName + " was not in the environment",m)) ) | Expr.Val (vref,_,_) -> let fv = vref.Deref - let needsFixup = SetCustom.contains fv forwardReferenceSet + let needsFixup = Zset.contains fv forwardReferenceSet if needsFixup then fixups := (boundv, fv,(fun () -> GenExpr cenv cgbuf eenv SPSuppress (set e) discard)) :: !fixups | _ -> failwith "compute real fixup vars" let fixups = ref [] - let recursiveVars = SetCustom.ofList (bindsPossiblyRequiringFixup |> List.map (fun v -> v.Var)) + let recursiveVars = Zset.ofList (bindsPossiblyRequiringFixup |> List.map (fun v -> v.Var)) let _ = (recursiveVars, bindsPossiblyRequiringFixup) ||> List.fold (fun forwardReferenceSet (bind:Binding) -> // Compute fixups @@ -4660,7 +4660,7 @@ and GenLetRecBindings cenv cgbuf eenv (allBinds: Bindings,m) = (exprForVal m bind.Var, (fun _ -> failwith ("internal error: should never need to set non-delayed recursive val: " + bind.Var.LogicalName))) // Record the variable as defined - let forwardReferenceSet = SetCustom.remove bind.Var forwardReferenceSet + let forwardReferenceSet = Zset.remove bind.Var forwardReferenceSet forwardReferenceSet) // Generate the actual bindings @@ -4668,9 +4668,9 @@ and GenLetRecBindings cenv cgbuf eenv (allBinds: Bindings,m) = (recursiveVars, allBinds) ||> List.fold (fun forwardReferenceSet (bind:Binding) -> GenBinding cenv cgbuf eenv bind // Record the variable as defined - let forwardReferenceSet = SetCustom.remove bind.Var forwardReferenceSet + let forwardReferenceSet = Zset.remove bind.Var forwardReferenceSet // Execute and discard any fixups that can now be committed - fixups := !fixups |> List.filter (fun (boundv, fv, action) -> if (SetCustom.contains boundv forwardReferenceSet || SetCustom.contains fv forwardReferenceSet) then true else (action(); false)) + fixups := !fixups |> List.filter (fun (boundv, fv, action) -> if (Zset.contains boundv forwardReferenceSet || Zset.contains fv forwardReferenceSet) then true else (action(); false)) forwardReferenceSet) () diff --git a/src/fsharp/InnerLambdasToTopLevelFuncs.fs b/src/fsharp/InnerLambdasToTopLevelFuncs.fs index 1b88d2fc849..e4fa63a6680 100644 --- a/src/fsharp/InnerLambdasToTopLevelFuncs.fs +++ b/src/fsharp/InnerLambdasToTopLevelFuncs.fs @@ -69,7 +69,7 @@ let destApp (f,fty,tys,args,m) = | f -> (f,fty,tys,args,m) #if DEBUG -let showTyparSet tps = showL (commaListL (List.map typarL (SetCustom.elements tps))) +let showTyparSet tps = showL (commaListL (List.map typarL (Zset.elements tps))) #endif // CLEANUP NOTE: don't like the look of this function - this distinction @@ -137,7 +137,7 @@ let GetValsBoundUnderMustInline xinfo = if v.InlineInfo = ValInline.PseudoVal then Set.union (GetValsBoundInExpr repr) rejectS else rejectS - let rejectS = SetCustom.empty () + let rejectS = Zset.empty () let rejectS = Zmap.fold accRejectFrom xinfo.Defns rejectS rejectS @@ -181,10 +181,10 @@ module Pass1_DetermineTLRAndArities = let SelectTLRVals g xinfo f e = if IsRefusedTLR g f then None // Exclude values bound in a decision tree - else if SetCustom.contains f xinfo.DecisionTreeBindings then None + else if Zset.contains f xinfo.DecisionTreeBindings then None else // Could the binding be TLR? with what arity? - let atTopLevel = SetCustom.contains f xinfo.TopLevelBindings + let atTopLevel = Zset.contains f xinfo.TopLevelBindings let tps,vss,_b,_rty = stripTopLambda (e,f.Type) let nFormals = vss.Length let nMaxApplied = GetMaxNumArgsAtUses xinfo f @@ -211,16 +211,16 @@ module Pass1_DetermineTLRAndArities = // Do not TLR v if it is bound under a mustinline defn // There is simply no point - the original value will be duplicated and TLR'd anyway let rejectS = GetValsBoundUnderMustInline xinfo - let fArities = List.filter (fun (v,_) -> not (SetCustom.contains v rejectS)) fArities + let fArities = List.filter (fun (v,_) -> not (Zset.contains v rejectS)) fArities (*-*) - let tlrS = SetCustom.ofList (List.map fst fArities) + let tlrS = Zset.ofList (List.map fst fArities) let topValS = xinfo.TopLevelBindings (* genuinely top level *) - let topValS = SetCustom.filter (IsMandatoryNonTopLevel g >> not) topValS (* restrict *) + let topValS = Zset.filter (IsMandatoryNonTopLevel g >> not) topValS (* restrict *) (* REPORT MISSED CASES *) #if DEBUG if verboseTLR then let missed = Set.diff xinfo.TopLevelBindings tlrS - missed |> SetCustom.iter (fun v -> dprintf "TopLevel but not TLR = %s\n" v.LogicalName) + missed |> Zset.iter (fun v -> dprintf "TopLevel but not TLR = %s\n" v.LogicalName) #endif (* REPORT OVER *) let arityM = Zmap.ofList fArities @@ -292,11 +292,11 @@ module Pass1_DetermineTLRAndArities = /// [Each fclass has an env, the fclass are the handles to envs.] type BindingGroupSharingSameReqdItems(bindings: Bindings) = let vals = valsOfBinds bindings - let vset = SetCustom.ofList vals + let vset = Zset.ofList vals member fclass.Vals = vals - member fclass.Contains (v: Val) = vset |> SetCustom.contains v + member fclass.Contains (v: Val) = vset |> Zset.contains v member fclass.IsEmpty = isNil vals @@ -348,17 +348,17 @@ type ReqdItemsForDefn = member env.Extend (typars,items) = {env with - reqdTypars = SetCustom.addList typars env.reqdTypars - reqdItems = SetCustom.addList items env.reqdItems} + reqdTypars = Zset.addList typars env.reqdTypars + reqdItems = Zset.addList items env.reqdItems} static member Initial typars m = - {reqdTypars = SetCustom.ofList typars - reqdItems = SetCustom.empty () + {reqdTypars = Zset.ofList typars + reqdItems = Zset.empty () m = m } override env.ToString() = - (showL (commaListL (List.map typarL (SetCustom.elements env.reqdTypars)))) + "--" + - (String.concat "," (List.map string (SetCustom.elements env.reqdItems))) + (showL (commaListL (List.map typarL (Zset.elements env.reqdTypars)))) + "--" + + (String.concat "," (List.map string (Zset.elements env.reqdItems))) (*--debug-stuff--*) @@ -437,7 +437,7 @@ module Pass2_DetermineReqdItems = reqdItemsMap = Zmap.empty () fclassM = Zmap.empty () revDeclist = [] - recShortCallS = SetCustom.empty () } + recShortCallS = Zset.empty () } /// PUSH = start collecting for fclass let PushFrame (fclass: BindingGroupSharingSameReqdItems) (reqdTypars0,reqdVals0,m) state = @@ -466,7 +466,7 @@ module Pass2_DetermineReqdItems = let LogRequiredFrom gv items state = let logIntoFrame (fclass, reqdVals0:zset, env: ReqdItemsForDefn) = let env = - if reqdVals0 |> SetCustom.contains gv then + if reqdVals0 |> Zset.contains gv then env.Extend ([],items) else env @@ -479,7 +479,7 @@ module Pass2_DetermineReqdItems = if verboseTLR then dprintf "shortCall: rec: %s\n" gv.LogicalName // Have short call to gv within it's (mutual) definition(s) {state with - recShortCallS = SetCustom.add gv state.recShortCallS} + recShortCallS = Zset.add gv state.recShortCallS} else if verboseTLR then dprintf "shortCall: not-rec: %s\n" gv.LogicalName state @@ -514,17 +514,17 @@ module Pass2_DetermineReqdItems = LogRequiredFrom f [ReqdVal f] z let accBinds m z (binds: Bindings) = - let tlrBs,nonTlrBs = binds |> List.partition (fun b -> SetCustom.contains b.Var tlrS) + let tlrBs,nonTlrBs = binds |> List.partition (fun b -> Zset.contains b.Var tlrS) // For bindings marked TLR, collect implied env let fclass = BindingGroupSharingSameReqdItems tlrBs // what determines env? let frees = FreeInBindings tlrBs - let reqdTypars0 = frees.FreeTyvars.FreeTypars |> SetCustom.elements (* put in env *) + let reqdTypars0 = frees.FreeTyvars.FreeTypars |> Zset.elements (* put in env *) // occurrences contribute to env - let reqdVals0 = frees.FreeLocals |> SetCustom.elements + let reqdVals0 = frees.FreeLocals |> Zset.elements // tlrBs are not reqdVals0 for themselves let reqdVals0 = reqdVals0 |> List.filter (fun gv -> not (fclass.Contains gv)) - let reqdVals0 = reqdVals0 |> SetCustom.ofList + let reqdVals0 = reqdVals0 |> Zset.ofList // collect into env over bodies let z = PushFrame fclass (reqdTypars0,reqdVals0,m) z let z = (z,tlrBs) ||> List.fold (foldOn (fun b -> b.Expr) exprF) @@ -578,7 +578,7 @@ module Pass2_DetermineReqdItems = let reqdTypars0 = env.reqdTypars let reqdTypars = List.fold Set.union reqdTypars0 directCallReqdTypars - let changed = changed || (not (SetCustom.equal reqdTypars0 reqdTypars)) + let changed = changed || (not (Zset.equal reqdTypars0 reqdTypars)) let env = {env with reqdTypars = reqdTypars} #if DEBUG if verboseTLR then @@ -633,7 +633,7 @@ module Pass2_DetermineReqdItems = if verboseTLR then DumpReqdValMap reqdItemsMap declist |> List.iter (fun fc -> dprintf "Declist: %A\n" fc) - recShortCallS |> SetCustom.iter (fun f -> dprintf "RecShortCall: %s\n" f.LogicalName) + recShortCallS |> Zset.iter (fun f -> dprintf "RecShortCall: %s\n" f.LogicalName) #endif reqdItemsMap,fclassM,declist,recShortCallS @@ -703,7 +703,7 @@ let FlatEnvPacks g fclassM topValS declist (reqdItemsMap: zmap SetCustom.ofList |> SetCustom.elements // noRepeats + let vals = vals |> Zset.ofList |> Zset.elements // noRepeats // Remove genuinely toplevel, no need to close over these let vals = vals |> List.filter (IsMandatoryTopLevel >> not) @@ -739,7 +739,7 @@ let FlatEnvPacks g fclassM topValS declist (reqdItemsMap: zmap List.filter (fun v -> not (isByrefLikeTy g v.Range v.Type)) // Remove values which have been labelled TLR, no need to close over these - let vals = vals |> List.filter (SetCustom.memberOf topValS >> not) + let vals = vals |> List.filter (Zset.memberOf topValS >> not) // Carrier sets cannot include constrained polymorphic values. We can't just take such a value out, so for the moment // we'll just abandon TLR altogether and give a warning about this condition. @@ -779,7 +779,7 @@ let FlatEnvPacks g fclassM topValS declist (reqdItemsMap: zmap f,createFHat f) fs let fHatM = Zmap.ofList ffHats fHatM @@ -1014,7 +1014,7 @@ module Pass4_RewriteAssembly = let fHatBind = mkMultiLambdaBind fHat letSeqPtOpt m fHat_tps fHat_args (fHat_body,rty) fHatBind let rebinds = binds |> List.map fRebinding - let shortRecBinds = rebinds |> List.filter (fun b -> penv.recShortCallS |> SetCustom.contains b.Var) + let shortRecBinds = rebinds |> List.filter (fun b -> penv.recShortCallS |> Zset.contains b.Var) let newBinds = binds |> List.map (fHatNewBinding shortRecBinds) newBinds,rebinds @@ -1024,7 +1024,7 @@ module Pass4_RewriteAssembly = | Some envp -> envp.ep_pack // environment pack bindings let TransBindings xisRec penv (binds:Bindings) = - let tlrBs,nonTlrBs = binds |> List.partition (fun b -> SetCustom.contains b.Var penv.tlrS) + let tlrBs,nonTlrBs = binds |> List.partition (fun b -> Zset.contains b.Var penv.tlrS) let fclass = BindingGroupSharingSameReqdItems tlrBs // Trans each TLR f binding into fHat and f rebind let newTlrBinds,tlrRebinds = TransTLRBindings penv tlrBs @@ -1034,7 +1034,7 @@ module Pass4_RewriteAssembly = // QUERY: yes and no - if we don't, we have an unrealizable term, and many decisions must // QUERY: correlate with LowerCallsAndSeqs. let forceTopBindToHaveArity (bind:Binding) = - if penv.topValS |> SetCustom.contains bind.Var then ConvertBind penv.g bind + if penv.topValS |> Zset.contains bind.Var then ConvertBind penv.g bind else bind let nonTlrBs = nonTlrBs |> List.map forceTopBindToHaveArity @@ -1056,7 +1056,7 @@ module Pass4_RewriteAssembly = // CLEANUP NOTE: should be using a mkApps to make all applications match fx with | Expr.Val (fvref:ValRef,_,m) when - (SetCustom.contains fvref.Deref penv.tlrS) && + (Zset.contains fvref.Deref penv.tlrS) && (let wf = Zmap.force fvref.Deref penv.arityM ("TransApp - wf",nameOfVal) IsArityMet fvref wf tys args) -> diff --git a/src/fsharp/LowerCallsAndSeqs.fs b/src/fsharp/LowerCallsAndSeqs.fs index ae963e4a8b6..792f1088bbb 100644 --- a/src/fsharp/LowerCallsAndSeqs.fs +++ b/src/fsharp/LowerCallsAndSeqs.fs @@ -93,7 +93,7 @@ type LoweredSeqFirstPhaseResult = /// The state variables allocated for one portion of the sequence expression (i.e. the local let-bound variables which become state variables) stateVars: ValRef list } -let isVarFreeInExpr v e = SetCustom.contains v (freeInExpr CollectTyparsAndLocals e).FreeLocals +let isVarFreeInExpr v e = Zset.contains v (freeInExpr CollectTyparsAndLocals e).FreeLocals /// Analyze a TAST expression to detect the elaborated form of a sequence expression. /// Then compile it to a state machine represented as a TAST containing goto, return and label nodes. diff --git a/src/fsharp/NicePrint.fs b/src/fsharp/NicePrint.fs index 914cb2e8007..e6c067fdc9d 100755 --- a/src/fsharp/NicePrint.fs +++ b/src/fsharp/NicePrint.fs @@ -764,7 +764,7 @@ module private PrintTypes = match Zmap.tryFind typar env.inplaceConstraints with | Some (typarConstraintTy) -> - if SetCustom.contains typar env.singletons then + if Zset.contains typar env.singletons then leftL (tagPunctuation "#") ^^ layoutTypeWithInfo denv env typarConstraintTy else (varL ^^ sepL (tagPunctuation ":>") ^^ layoutTypeWithInfo denv env typarConstraintTy) |> bracketL @@ -1193,7 +1193,7 @@ module private PrintTastMemberOrVals = else nameL - let isOverGeneric = List.length (SetCustom.elements (freeInType CollectTyparsNoCaching tau).FreeTypars) < List.length tps // Bug: 1143 + let isOverGeneric = List.length (Zset.elements (freeInType CollectTyparsNoCaching tau).FreeTypars) < List.length tps // Bug: 1143 let isTyFunction = v.IsTypeFunction // Bug: 1143, and innerpoly tests let typarBindingsL = if isTyFunction || isOverGeneric || denv.showTyparBinding then diff --git a/src/fsharp/Optimizer.fs b/src/fsharp/Optimizer.fs index 50168719fcd..21a481d5c39 100644 --- a/src/fsharp/Optimizer.fs +++ b/src/fsharp/Optimizer.fs @@ -974,11 +974,11 @@ let AbstractLazyModulInfoByHiding isAssemblyBoundary mhi = // Under those checks, the further hidden* checks may be subsumed (meaning, not required anymore). let hiddenTycon, hiddenTyconRepr, hiddenVal, hiddenRecdField, hiddenUnionCase = - SetCustom.memberOf mhi.mhiTycons, - SetCustom.memberOf mhi.mhiTyconReprs, - SetCustom.memberOf mhi.mhiVals, - SetCustom.memberOf mhi.mhiRecdFields, - SetCustom.memberOf mhi.mhiUnionCases + Zset.memberOf mhi.mhiTycons, + Zset.memberOf mhi.mhiTyconReprs, + Zset.memberOf mhi.mhiVals, + Zset.memberOf mhi.mhiRecdFields, + Zset.memberOf mhi.mhiUnionCases let rec abstractExprInfo ivalue = match ivalue with @@ -989,7 +989,7 @@ let AbstractLazyModulInfoByHiding isAssemblyBoundary mhi = let tyvars = freeInVal CollectAll v2 if (isAssemblyBoundary && not (freeTyvarsAllPublic tyvars)) || - SetCustom.exists hiddenTycon tyvars.FreeTycons || + Zset.exists hiddenTycon tyvars.FreeTycons || hiddenVal v2 then detail' else ValValue (vref2, detail') @@ -997,17 +997,17 @@ let AbstractLazyModulInfoByHiding isAssemblyBoundary mhi = | CurriedLambdaValue (_, _, _, expr, _) | ConstExprValue(_, expr) when (let fvs = freeInExpr CollectAll expr (isAssemblyBoundary && not (freeVarsAllPublic fvs)) || - SetCustom.exists hiddenVal fvs.FreeLocals || - SetCustom.exists hiddenTycon fvs.FreeTyvars.FreeTycons || - SetCustom.exists hiddenTyconRepr fvs.FreeLocalTyconReprs || - SetCustom.exists hiddenRecdField fvs.FreeRecdFields || - SetCustom.exists hiddenUnionCase fvs.FreeUnionCases ) -> + Zset.exists hiddenVal fvs.FreeLocals || + Zset.exists hiddenTycon fvs.FreeTyvars.FreeTycons || + Zset.exists hiddenTyconRepr fvs.FreeLocalTyconReprs || + Zset.exists hiddenRecdField fvs.FreeRecdFields || + Zset.exists hiddenUnionCase fvs.FreeUnionCases ) -> UnknownValue // Check for escape in constant | ConstValue(_, ty) when (let ftyvs = freeInType CollectAll ty (isAssemblyBoundary && not (freeTyvarsAllPublic ftyvs)) || - SetCustom.exists hiddenTycon ftyvs.FreeTycons) -> + Zset.exists hiddenTycon ftyvs.FreeTycons) -> UnknownValue | TupleValue vinfos -> TupleValue (Array.map abstractExprInfo vinfos) @@ -1071,7 +1071,7 @@ let AbstractExprInfoByVars (boundVars:Val list, boundTyVars) ivalue = (not (isNil boundVars) && List.exists (valEq v2) boundVars) || (not (isNil boundTyVars) && let ftyvs = freeInVal CollectTypars v2 - List.exists (SetCustom.memberOf ftyvs.FreeTypars) boundTyVars) -> + List.exists (Zset.memberOf ftyvs.FreeTypars) boundTyVars) -> // hiding value when used in expression abstractExprInfo detail @@ -1083,8 +1083,8 @@ let AbstractExprInfoByVars (boundVars:Val list, boundTyVars) ivalue = // Check for escape in lambda | CurriedLambdaValue (_, _, _, expr, _) | ConstExprValue(_, expr) when (let fvs = freeInExpr (if isNil boundTyVars then CollectLocals else CollectTyparsAndLocals) expr - (not (isNil boundVars) && List.exists (SetCustom.memberOf fvs.FreeLocals) boundVars) || - (not (isNil boundTyVars) && List.exists (SetCustom.memberOf fvs.FreeTyvars.FreeTypars) boundTyVars) || + (not (isNil boundVars) && List.exists (Zset.memberOf fvs.FreeLocals) boundVars) || + (not (isNil boundTyVars) && List.exists (Zset.memberOf fvs.FreeTyvars.FreeTypars) boundTyVars) || (fvs.UsesMethodLocalConstructs )) -> // Trimming lambda @@ -1094,7 +1094,7 @@ let AbstractExprInfoByVars (boundVars:Val list, boundTyVars) ivalue = | ConstValue(_, ty) when (not (isNil boundTyVars) && (let ftyvs = freeInType CollectTypars ty - List.exists (SetCustom.memberOf ftyvs.FreeTypars) boundTyVars)) -> + List.exists (Zset.memberOf ftyvs.FreeTypars) boundTyVars)) -> UnknownValue // Otherwise check all sub-values @@ -1209,7 +1209,7 @@ let ValueIsUsedOrHasEffect cenv fvs (b:Binding, binfo) = Option.isSome v.MemberInfo || binfo.HasEffect || v.IsFixed || - SetCustom.contains v (fvs()) + Zset.contains v (fvs()) let rec SplitValuesByIsUsedOrHasEffect cenv fvs x = x |> List.filter (ValueIsUsedOrHasEffect cenv fvs) |> List.unzip @@ -1311,7 +1311,7 @@ let TryEliminateBinding cenv _env (TBind(vspec1, e1, spBind)) e2 _m = && (not (vspec2.LogicalName.Contains(suffixForVariablesThatMayNotBeEliminated))) // REVIEW: this looks slow. Look only for one variable instead && (let fvs = accFreeInExprs CollectLocals args emptyFreeVars - not (SetCustom.contains vspec1 fvs.FreeLocals)) + not (Zset.contains vspec1 fvs.FreeLocals)) // Immediate consumption of value as 2nd or subsequent argument to a construction or projection operation let rec GetImmediateUseContext rargsl argsr = @@ -1332,7 +1332,7 @@ let TryEliminateBinding cenv _env (TBind(vspec1, e1, spBind)) e2 _m = | Expr.Match(spMatch, _exprm, TDSwitch(Expr.Val(VRefLocal vspec2, _, _), cases, dflt, _), targets, m, ty2) when (valEq vspec1 vspec2 && let fvs = accFreeInTargets CollectLocals targets (accFreeInSwitchCases CollectLocals cases dflt emptyFreeVars) - not (SetCustom.contains vspec1 fvs.FreeLocals)) -> + not (Zset.contains vspec1 fvs.FreeLocals)) -> let spMatch = spBind.Combine(spMatch) Some (Expr.Match(spMatch, e1.Range, TDSwitch(e1, cases, dflt, m), targets, m, ty2)) @@ -2729,7 +2729,7 @@ and OptimizeLambdas (vspec: Val option) cenv env topValInfo e ety = | None -> CurriedLambdaValue (lambdaId, arities, bsize, expr', ety) | Some baseVal -> let fvs = freeInExpr CollectLocals body' - if fvs.UsesMethodLocalConstructs || (fvs.FreeLocals |> SetCustom.contains baseVal) then + if fvs.UsesMethodLocalConstructs || (fvs.FreeLocals |> Zset.contains baseVal) then UnknownValue else let expr2 = mkMemberLambdas m tps ctorThisValOpt None vsl (body', bodyty) @@ -2805,7 +2805,7 @@ and ComputeSplitToMethodCondition flag threshold cenv env (e:Expr, einfo) = (let fvs = freeInExpr CollectLocals e not fvs.UsesUnboundRethrow && not fvs.UsesMethodLocalConstructs && - fvs.FreeLocals |> SetCustom.forall (fun v -> + fvs.FreeLocals |> Zset.forall (fun v -> // no direct-self-recursive references not (env.dontSplitVars.ContainsVal v) && (v.ValReprInfo.IsSome || @@ -3076,12 +3076,12 @@ and OptimizeModuleExpr cenv env x = not (ValueIsUsedOrHasEffect cenv (fun () -> fvs.FreeLocals) (bind, binfo)) && // Check the thing is hidden by the signature (if any) - (hidden.mhiVals |> SetCustom.contains bind.Var) && + (hidden.mhiVals |> Zset.contains bind.Var) && // Check the thing is not compiled as a static field or property, since reflected definitions and other reflective stuff might need it not (IsCompiledAsStaticProperty cenv.g bind.Var)) - let deadSet = SetCustom.ofList (dead |> List.map (fun (bind, _) -> bind.Var)) + let deadSet = Zset.ofList (dead |> List.map (fun (bind, _) -> bind.Var)) // Eliminate dead private bindings from a module type by mutation. Note that the optimizer doesn't // actually copy the entire term - it copies the expression portions of the term and leaves the @@ -3095,7 +3095,7 @@ and OptimizeModuleExpr cenv env x = let rec elimModTy (mtyp:ModuleOrNamespaceType) = let mty = new ModuleOrNamespaceType(kind=mtyp.ModuleOrNamespaceKind, - vals= (mtyp.AllValsAndMembers |> QueueList.filter (SetCustom.memberOf deadSet >> not)), + vals= (mtyp.AllValsAndMembers |> QueueList.filter (Zset.memberOf deadSet >> not)), entities= mtyp.AllEntities) mtyp.ModuleAndNamespaceDefinitions |> List.iter elimModSpec mty @@ -3109,14 +3109,14 @@ and OptimizeModuleExpr cenv env x = let mbinds = mbinds |> List.choose elimModuleBinding TMDefRec(isRec, tycons, mbinds, m) | TMDefLet(bind, m) -> - if SetCustom.contains bind.Var deadSet then TMDefRec(false, [], [], m) else x + if Zset.contains bind.Var deadSet then TMDefRec(false, [], [], m) else x | TMDefDo _ -> x | TMDefs(defs) -> TMDefs(List.map elimModDef defs) | TMAbstract _ -> x and elimModuleBinding x = match x with | ModuleOrNamespaceBinding.Binding bind -> - if bind.Var |> SetCustom.memberOf deadSet then None + if bind.Var |> Zset.memberOf deadSet then None else Some x | ModuleOrNamespaceBinding.Module(mspec, d) -> // Clean up the ModuleOrNamespaceType by mutation diff --git a/src/fsharp/PostInferenceChecks.fs b/src/fsharp/PostInferenceChecks.fs index 3819310be7f..b951479431b 100644 --- a/src/fsharp/PostInferenceChecks.fs +++ b/src/fsharp/PostInferenceChecks.fs @@ -408,8 +408,8 @@ let CheckEscapes cenv allowProtected m syntacticArgs body = (* m is a range suit if not allowProtected && frees.UsesMethodLocalConstructs then errorR(Error(FSComp.SR.chkProtectedOrBaseCalled(), m)) - elif SetCustom.exists cantBeFree fvs then - let v = List.find cantBeFree (SetCustom.elements fvs) + elif Zset.exists cantBeFree fvs then + let v = List.find cantBeFree (Zset.elements fvs) // byref error before mutable error (byrefs are mutable...). if (isByrefLikeTy cenv.g m v.Type) then diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index 13508208d07..584149475df 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -1814,11 +1814,11 @@ let ValRefIsExplicitImpl g (vref:ValRef) = ValIsExplicitImpl g vref.Deref // an equation assigned by type inference. //--------------------------------------------------------------------------- -let emptyFreeLocals = SetCustom.empty () -let emptyFreeRecdFields = SetCustom.empty () -let emptyFreeUnionCases = SetCustom.empty () -let emptyFreeTycons = SetCustom.empty () -let emptyFreeTypars = SetCustom.empty () +let emptyFreeLocals = Zset.empty () +let emptyFreeRecdFields = Zset.empty () +let emptyFreeUnionCases = Zset.empty () +let emptyFreeTycons = Zset.empty () +let emptyFreeTypars = Zset.empty () let emptyFreeTyvars = { FreeTycons = emptyFreeTycons @@ -1827,8 +1827,8 @@ let emptyFreeTyvars = FreeTypars = emptyFreeTypars} let isEmptyFreeTyvars ftyvs = - SetCustom.isEmpty ftyvs.FreeTypars && - SetCustom.isEmpty ftyvs.FreeTycons + Zset.isEmpty ftyvs.FreeTypars && + Zset.isEmpty ftyvs.FreeTycons let unionFreeTyvars fvs1 fvs2 = if fvs1 === emptyFreeTyvars then fvs2 else @@ -1915,8 +1915,8 @@ let CollectLocals = CollectTyparsAndLocals let accFreeLocalTycon opts x acc = if not opts.includeLocalTycons then acc else - if SetCustom.contains x acc.FreeTycons then acc else - { acc with FreeTycons = SetCustom.add x acc.FreeTycons } + if Zset.contains x acc.FreeTycons then acc else + { acc with FreeTycons = Zset.add x acc.FreeTycons } let accFreeTycon opts (tcr:TyconRef) acc = if not opts.includeLocalTycons then acc @@ -1927,7 +1927,7 @@ let rec boundTypars opts tps acc = // Bound type vars form a recursively-referential set due to constraints, e.g. A : I, B : I // So collect up free vars in all constraints first, then bind all variables let acc = List.foldBack (fun (tp:Typar) acc -> accFreeInTyparConstraints opts tp.Constraints acc) tps acc - List.foldBack (fun tp acc -> { acc with FreeTypars = SetCustom.remove tp acc.FreeTypars}) tps acc + List.foldBack (fun tp acc -> { acc with FreeTypars = Zset.remove tp acc.FreeTypars}) tps acc and accFreeInTyparConstraints opts cxs acc = List.foldBack (accFreeInTyparConstraint opts) cxs acc @@ -1969,8 +1969,8 @@ and accFreeInTraitSln opts sln acc = | ClosedExprSln _ -> acc // nothing to accumulate because it's a closed expression referring only to erasure of provided method calls and accFreeLocalValInTraitSln _opts v fvs = - if SetCustom.contains v fvs.FreeTraitSolutions then fvs - else { fvs with FreeTraitSolutions = SetCustom.add v fvs.FreeTraitSolutions} + if Zset.contains v fvs.FreeTraitSolutions then fvs + else { fvs with FreeTraitSolutions = Zset.add v fvs.FreeTraitSolutions} and accFreeValRefInTraitSln opts (vref:ValRef) fvs = if vref.IsLocalRef then @@ -1981,10 +1981,10 @@ and accFreeValRefInTraitSln opts (vref:ValRef) fvs = and accFreeTyparRef opts (tp:Typar) acc = if not opts.includeTypars then acc else - if SetCustom.contains tp acc.FreeTypars then acc + if Zset.contains tp acc.FreeTypars then acc else accFreeInTyparConstraints opts tp.Constraints - { acc with FreeTypars = SetCustom.add tp acc.FreeTypars} + { acc with FreeTypars = Zset.add tp acc.FreeTypars} and accFreeInType opts ty acc = match stripTyparEqns ty with @@ -2496,25 +2496,25 @@ module SimplifyTypes = postfixConstraints : (Typar * TyparConstraint) list } let typeSimplificationInfo0 = - { singletons = SetCustom.empty () + { singletons = Zset.empty () inplaceConstraints = Zmap.empty () postfixConstraints = [] } let categorizeConstraints simplify m cxs = let singletons = if simplify then Zmap.chooseL (fun tp n -> if n = 1 then Some tp else None) m else [] - let singletons = SetCustom.ofList singletons + let singletons = Zset.ofList singletons // Here, singletons are typars that occur once in the type. // However, they may also occur in a type constraint. // If they do, they are really multiple occurrence - so we should remove them. let constraintTypars = (freeInTyparConstraints CollectTyparsNoCaching (List.map snd cxs)).FreeTypars - let usedInTypeConstraint typar = SetCustom.contains typar constraintTypars - let singletons = singletons |> SetCustom.filter (usedInTypeConstraint >> not) + let usedInTypeConstraint typar = Zset.contains typar constraintTypars + let singletons = singletons |> Zset.filter (usedInTypeConstraint >> not) // Here, singletons should really be used once let inplace, postfix = cxs |> List.partition (fun (tp, tpc) -> simplify && isTTyparCoercesToType tpc && - SetCustom.contains tp singletons && + Zset.contains tp singletons && tp.Constraints.Length = 1) let inplace = inplace |> List.map (function (tp, TyparConstraint.CoercesTo(ty, _)) -> tp, ty | _ -> failwith "not isTTyparCoercesToType") @@ -3201,7 +3201,7 @@ module DebugPrint = begin match Zmap.tryFind typar env.inplaceConstraints with | Some (typarConstraintTy) -> - if SetCustom.contains typar env.singletons then + if Zset.contains typar env.singletons then leftL (tagText "#") ^^ auxTyparConstraintTypL env typarConstraintTy else (varL ^^ sepL (tagText ":>") ^^ auxTyparConstraintTypL env typarConstraintTy) |> wrap @@ -3775,11 +3775,11 @@ type SignatureHidingInfo = mhiUnionCases : zset } static member Empty = - { mhiTycons = SetCustom.empty () - mhiTyconReprs = SetCustom.empty () - mhiVals = SetCustom.empty () - mhiRecdFields = SetCustom.empty () - mhiUnionCases = SetCustom.empty () } + { mhiTycons = Zset.empty () + mhiTyconReprs = Zset.empty () + mhiVals = Zset.empty () + mhiRecdFields = Zset.empty () + mhiUnionCases = Zset.empty () } let addValRemap v v' tmenv = { tmenv with valRemap= tmenv.valRemap.Add v (mkLocalValRef v') } @@ -3799,7 +3799,7 @@ let accEntityRemap (msigty:ModuleOrNamespaceType) (entity:Entity) (mrpi, mhi) = match sigtyconOpt with | None -> // The type constructor is not present in the signature. Hence it is hidden. - let mhi = { mhi with mhiTycons = SetCustom.add entity mhi.mhiTycons } + let mhi = { mhi with mhiTycons = Zset.add entity mhi.mhiTycons } (mrpi, mhi) | Some sigtycon -> // The type constructor is in the signature. Hence record the repackage entry @@ -3810,7 +3810,7 @@ let accEntityRemap (msigty:ModuleOrNamespaceType) (entity:Entity) (mrpi, mhi) = let mhi = if (match entity.TypeReprInfo with TNoRepr -> false | _ -> true) && (match sigtycon.TypeReprInfo with TNoRepr -> true | _ -> false) then // The type representation is absent in the signature, hence it is hidden - { mhi with mhiTyconReprs = SetCustom.add entity mhi.mhiTyconReprs } + { mhi with mhiTyconReprs = Zset.add entity mhi.mhiTyconReprs } else // The type representation is present in the signature. // Find the fields that have been hidden or which were non-public anyway. @@ -3823,7 +3823,7 @@ let accEntityRemap (msigty:ModuleOrNamespaceType) (entity:Entity) (mrpi, mhi) = | _ -> // The field is not in the signature. Hence it is regarded as hidden. let rfref = tcref.MakeNestedRecdFieldRef rfield - { mhi with mhiRecdFields = SetCustom.add rfref mhi.mhiRecdFields }) + { mhi with mhiRecdFields = Zset.add rfref mhi.mhiRecdFields }) entity.AllFieldsArray |> List.foldBack (fun (ucase:UnionCase) mhi -> match sigtycon.GetUnionCaseByName ucase.DisplayName with @@ -3833,7 +3833,7 @@ let accEntityRemap (msigty:ModuleOrNamespaceType) (entity:Entity) (mrpi, mhi) = | _ -> // The constructor is not in the signature. Hence it is regarded as hidden. let ucref = tcref.MakeNestedUnionCaseRef ucase - { mhi with mhiUnionCases = SetCustom.add ucref mhi.mhiUnionCases }) + { mhi with mhiUnionCases = Zset.add ucref mhi.mhiUnionCases }) (entity.UnionCasesAsList) (mrpi, mhi) @@ -3842,7 +3842,7 @@ let accSubEntityRemap (msigty:ModuleOrNamespaceType) (entity:Entity) (mrpi, mhi) match sigtyconOpt with | None -> // The type constructor is not present in the signature. Hence it is hidden. - let mhi = { mhi with mhiTycons = SetCustom.add entity mhi.mhiTycons } + let mhi = { mhi with mhiTycons = Zset.add entity mhi.mhiTycons } (mrpi, mhi) | Some sigtycon -> // The type constructor is in the signature. Hence record the repackage entry @@ -3866,7 +3866,7 @@ let accValRemap g aenv (msigty:ModuleOrNamespaceType) (implVal:Val) (mrpi, mhi) match sigValOpt with | None -> if verbose then dprintf "accValRemap, hide = %s#%d\n" implVal.LogicalName implVal.Stamp - let mhi = { mhi with mhiVals = SetCustom.add implVal mhi.mhiVals } + let mhi = { mhi with mhiVals = Zset.add implVal mhi.mhiVals } (mrpi, mhi) | Some (sigVal:Val) -> // The value is in the signature. Add the repackage entry. @@ -3964,9 +3964,9 @@ let ComputeRemappingFromImplementationToSignature g mdef msigty = let accTyconHidingInfoAtAssemblyBoundary (tycon:Tycon) mhi = if not (canAccessFromEverywhere tycon.Accessibility) then // The type constructor is not public, hence hidden at the assembly boundary. - { mhi with mhiTycons = SetCustom.add tycon mhi.mhiTycons } + { mhi with mhiTycons = Zset.add tycon mhi.mhiTycons } elif not (canAccessFromEverywhere tycon.TypeReprAccessibility) then - { mhi with mhiTyconReprs = SetCustom.add tycon mhi.mhiTyconReprs } + { mhi with mhiTyconReprs = Zset.add tycon mhi.mhiTyconReprs } else mhi |> Array.foldBack @@ -3974,7 +3974,7 @@ let accTyconHidingInfoAtAssemblyBoundary (tycon:Tycon) mhi = if not (canAccessFromEverywhere rfield.Accessibility) then let tcref = mkLocalTyconRef tycon let rfref = tcref.MakeNestedRecdFieldRef rfield - { mhi with mhiRecdFields = SetCustom.add rfref mhi.mhiRecdFields } + { mhi with mhiRecdFields = Zset.add rfref mhi.mhiRecdFields } else mhi) tycon.AllFieldsArray |> List.foldBack @@ -3982,7 +3982,7 @@ let accTyconHidingInfoAtAssemblyBoundary (tycon:Tycon) mhi = if not (canAccessFromEverywhere ucase.Accessibility) then let tcref = mkLocalTyconRef tycon let ucref = tcref.MakeNestedUnionCaseRef ucase - { mhi with mhiUnionCases = SetCustom.add ucref mhi.mhiUnionCases } + { mhi with mhiUnionCases = Zset.add ucref mhi.mhiUnionCases } else mhi) (tycon.UnionCasesAsList) @@ -3997,7 +3997,7 @@ let accValHidingInfoAtAssemblyBoundary (vspec:Val) mhi = // anything that's not a module or member binding gets assembly visibility not vspec.IsMemberOrModuleBinding then // The value is not public, hence hidden at the assembly boundary. - { mhi with mhiVals = SetCustom.add vspec mhi.mhiVals } + { mhi with mhiVals = Zset.add vspec mhi.mhiVals } else mhi @@ -4024,7 +4024,7 @@ let IsHidden setF accessF remapF debugF = | [] -> false // Ah! we escaped to freedom! | (rpi, mhi) :: rest -> // Explicitly hidden? - SetCustom.contains x (setF mhi) || + Zset.contains x (setF mhi) || // Recurse... check rest (remapF rpi x)) fun mrmi x -> @@ -4074,13 +4074,13 @@ let freeVarsAllPublic fvs = // // CODEREVIEW: // What about non-local vals. This fix assumes non-local vals must be public. OK? - SetCustom.forall isPublicVal fvs.FreeLocals && - SetCustom.forall isPublicUnionCase fvs.FreeUnionCases && - SetCustom.forall isPublicRecdField fvs.FreeRecdFields && - SetCustom.forall isPublicTycon fvs.FreeTyvars.FreeTycons + Zset.forall isPublicVal fvs.FreeLocals && + Zset.forall isPublicUnionCase fvs.FreeUnionCases && + Zset.forall isPublicRecdField fvs.FreeRecdFields && + Zset.forall isPublicTycon fvs.FreeTyvars.FreeTycons let freeTyvarsAllPublic tyvars = - SetCustom.forall isPublicTycon tyvars.FreeTycons + Zset.forall isPublicTycon tyvars.FreeTycons // Detect the subset of match expressions we treat in a linear way @@ -4137,8 +4137,8 @@ let accFreeVarsInTraitSln opts tys acc = accFreeTyvars opts accFreeInTraitSln ty let boundLocalVal opts v fvs = if not opts.includeLocals then fvs else let fvs = accFreevarsInVal opts v fvs - if not (SetCustom.contains v fvs.FreeLocals) then fvs - else {fvs with FreeLocals= SetCustom.remove v fvs.FreeLocals} + if not (Zset.contains v fvs.FreeLocals) then fvs + else {fvs with FreeLocals= Zset.remove v fvs.FreeLocals} let boundProtect fvs = if fvs.UsesMethodLocalConstructs then {fvs with UsesMethodLocalConstructs = false} else fvs @@ -4201,15 +4201,15 @@ and accFreeInValFlags opts flag acc = and accFreeLocalVal opts v fvs = if not opts.includeLocals then fvs else - if SetCustom.contains v fvs.FreeLocals then fvs + if Zset.contains v fvs.FreeLocals then fvs else let fvs = accFreevarsInVal opts v fvs - {fvs with FreeLocals=SetCustom.add v fvs.FreeLocals} + {fvs with FreeLocals=Zset.add v fvs.FreeLocals} and accLocalTyconRepr opts b fvs = if not opts.includeLocalTyconReprs then fvs else - if SetCustom.contains b fvs.FreeLocalTyconReprs then fvs - else { fvs with FreeLocalTyconReprs = SetCustom.add b fvs.FreeLocalTyconReprs } + if Zset.contains b fvs.FreeLocalTyconReprs then fvs + else { fvs with FreeLocalTyconReprs = Zset.add b fvs.FreeLocalTyconReprs } and accUsedRecdOrUnionTyconRepr opts (tc:Tycon) fvs = if match tc.TypeReprInfo with TFSharpObjectRepr _ | TRecdRepr _ | TUnionRepr _ -> true | _ -> false @@ -4218,19 +4218,19 @@ and accUsedRecdOrUnionTyconRepr opts (tc:Tycon) fvs = and accFreeUnionCaseRef opts cr fvs = if not opts.includeUnionCases then fvs else - if SetCustom.contains cr fvs.FreeUnionCases then fvs + if Zset.contains cr fvs.FreeUnionCases then fvs else let fvs = fvs |> accUsedRecdOrUnionTyconRepr opts cr.Tycon let fvs = fvs |> accFreevarsInTycon opts cr.TyconRef - { fvs with FreeUnionCases = SetCustom.add cr fvs.FreeUnionCases } + { fvs with FreeUnionCases = Zset.add cr fvs.FreeUnionCases } and accFreeRecdFieldRef opts rfref fvs = if not opts.includeRecdFields then fvs else - if SetCustom.contains rfref fvs.FreeRecdFields then fvs + if Zset.contains rfref fvs.FreeRecdFields then fvs else let fvs = fvs |> accUsedRecdOrUnionTyconRepr opts rfref.Tycon let fvs = fvs |> accFreevarsInTycon opts rfref.TyconRef - { fvs with FreeRecdFields = SetCustom.add rfref fvs.FreeRecdFields } + { fvs with FreeRecdFields = Zset.add rfref fvs.FreeRecdFields } and accFreeExnRef _exnc fvs = fvs // Note: this exnc (TyconRef) should be collected the surround types, e.g. tinst of Expr.Op and accFreeValRef opts (vref:ValRef) fvs = @@ -7683,14 +7683,14 @@ type PrettyNaming.ActivePatternInfo with // not by their argument types. let doesActivePatternHaveFreeTypars g (v:ValRef) = let vty = v.TauType - let vtps = v.Typars |> SetCustom.ofList + let vtps = v.Typars |> Zset.ofList if not (isFunTy g v.TauType) then errorR(Error(FSComp.SR.activePatternIdentIsNotFunctionTyped(v.LogicalName), v.Range)) let argtys, resty = stripFunTy g vty let argtps, restps= (freeInTypes CollectTypars argtys).FreeTypars, (freeInType CollectTypars resty).FreeTypars // Error if an active pattern is generic in type variables that only occur in the result Choice<_, ...>. // Note: The test restricts to v.Typars since typars from the closure are considered fixed. - not (SetCustom.isEmpty (SetCustom.inter (Set.diff restps argtps) vtps)) + not (Zset.isEmpty (Zset.inter (Set.diff restps argtps) vtps)) //--------------------------------------------------------------------------- // RewriteExpr: rewrite bottom up with interceptors @@ -8300,8 +8300,8 @@ let (|CompiledForEachExpr|_|) g expr = enumerableVar.IsCompilerGenerated && enumeratorVar.IsCompilerGenerated && (let fvs = (freeInExpr CollectLocals bodyExpr) - not (SetCustom.contains enumerableVar fvs.FreeLocals) && - not (SetCustom.contains enumeratorVar fvs.FreeLocals)) -> + not (Zset.contains enumerableVar fvs.FreeLocals) && + not (Zset.contains enumeratorVar fvs.FreeLocals)) -> // Extract useful ranges let mEnumExpr = enumerableExpr.Range diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index 0f9b926e4cf..153c66ebe2f 100755 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -2153,7 +2153,7 @@ module GeneralizationHelpers = // Do not generalize type variables which would escape their scope // because they are free in the environment let generalizedTypars, ungeneralizableTypars2 = - List.partition (fun x -> not (SetCustom.contains x freeInEnv)) generalizedTypars + List.partition (fun x -> not (Zset.contains x freeInEnv)) generalizedTypars // Some situations, e.g. implicit class constructions that represent functions as fields, // do not allow generalisation over constrained typars. (since they can not be represented as fields) @@ -2261,7 +2261,7 @@ module GeneralizationHelpers = allDeclaredTypars |> List.iter (fun tp -> - if SetCustom.memberOf freeInEnv tp then + if Zset.memberOf freeInEnv tp then let ty = mkTyparTy tp error(Error(FSComp.SR.tcNotSufficientlyGenericBecauseOfScope(NicePrint.prettyStringOfTy denv ty), m))) @@ -10977,7 +10977,7 @@ and ApplyTypesFromArgumentPatterns (cenv, env, optArgsOK, ty, m, tpenv, Normaliz /// Do the type annotations give the full and complete generic type? If so, enable generic recursion and ComputeIsComplete enclosingDeclaredTypars declaredTypars ty = - SetCustom.isEmpty (List.fold (fun acc v -> SetCustom.remove v acc) + Zset.isEmpty (List.fold (fun acc v -> Zset.remove v acc) (freeInType CollectAllNoCaching ty).FreeTypars (enclosingDeclaredTypars@declaredTypars)) @@ -11588,14 +11588,14 @@ and TcIncrementalLetRecGeneralization cenv scopem //printfn "(failed generalization test 1 for binding for %s)" pgrbind.RecBindingInfo.Val.DisplayName // Any declared type parameters in an type are always generalizable - let freeInBinding = Set.diff freeInBinding (SetCustom.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.ExtraGeneralizableTypars)) + let freeInBinding = Set.diff freeInBinding (Zset.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.ExtraGeneralizableTypars)) if freeInBinding.IsEmpty then true else //printfn "(failed generalization test 2 for binding for %s)" pgrbind.RecBindingInfo.Val.DisplayName // Any declared method parameters can always be generalized - let freeInBinding = Set.diff freeInBinding (SetCustom.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.RecBindingInfo.DeclaredTypars)) + let freeInBinding = Set.diff freeInBinding (Zset.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.RecBindingInfo.DeclaredTypars)) if freeInBinding.IsEmpty then true else @@ -11610,7 +11610,7 @@ and TcIncrementalLetRecGeneralization cenv scopem //printfn "(failed generalization test 4 for binding for %s)" pgrbind.RecBindingInfo.Val.DisplayName // Type variables free in unchecked bindings do stop us generalizing - let freeInBinding = SetCustom.inter (freeInFrozenAndLaterBindings.Force().FreeTypars) freeInBinding + let freeInBinding = Zset.inter (freeInFrozenAndLaterBindings.Force().FreeTypars) freeInBinding if freeInBinding.IsEmpty then true else @@ -11651,8 +11651,8 @@ and TcIncrementalLetRecGeneralization cenv scopem freeInEnv else let freeInBinding = (freeInType CollectAllNoCaching pgrbind.RecBindingInfo.Val.TauType).FreeTypars - let freeInBinding = Set.diff freeInBinding (SetCustom.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.ExtraGeneralizableTypars)) - let freeInBinding = Set.diff freeInBinding (SetCustom.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.RecBindingInfo.DeclaredTypars)) + let freeInBinding = Set.diff freeInBinding (Zset.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.ExtraGeneralizableTypars)) + let freeInBinding = Set.diff freeInBinding (Zset.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.RecBindingInfo.DeclaredTypars)) Set.union freeInBinding freeInEnv) // Process the bindings marked for transition from PreGeneralization --> PostGeneralization @@ -11686,7 +11686,7 @@ and TcIncrementalLetRecGeneralization cenv scopem /// Compute the type variables which may be generalized and perform the generalization and TcLetrecComputeAndGeneralizeGenericTyparsForBinding cenv denv freeInEnv (pgrbind : PreGeneralizationRecursiveBinding) = - let freeInEnv = Set.diff freeInEnv (SetCustom.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.ExtraGeneralizableTypars)) + let freeInEnv = Set.diff freeInEnv (Zset.ofList (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.ExtraGeneralizableTypars)) let rbinfo = pgrbind.RecBindingInfo let vspec = rbinfo.Val @@ -12428,7 +12428,7 @@ module IncrClassChecking = { TakenFieldNames=Set.ofList names RepInfoTcGlobals=g ValReprs = Zmap.empty () - ValsWithRepresentation = SetCustom.empty () } + ValsWithRepresentation = Zset.empty () } /// Find the representation of a value member localRep.LookupRepr (v:Val) = @@ -12491,7 +12491,7 @@ module IncrClassChecking = // All struct variables are forced into fields. Structs may not contain "let" bindings, so no new variables can be // introduced. - if v.IsMutable || (relevantForcedFieldVars |> SetCustom.contains v) || tcref.IsStructOrEnumTycon then + if v.IsMutable || (relevantForcedFieldVars |> Zset.contains v) || tcref.IsStructOrEnumTycon then //dprintfn "Representing %s as a field %s" v.LogicalName name let rfref = RFRef(tcref, name) reportIfUnused() @@ -12548,10 +12548,10 @@ module IncrClassChecking = ValReprs = Zmap.add v repr localRep.ValReprs} member localRep.ValNowWithRepresentation (v:Val) = - {localRep with ValsWithRepresentation = SetCustom.add v localRep.ValsWithRepresentation} + {localRep with ValsWithRepresentation = Zset.add v localRep.ValsWithRepresentation} member localRep.IsValWithRepresentation (v:Val) = - localRep.ValsWithRepresentation |> SetCustom.contains v + localRep.ValsWithRepresentation |> Zset.contains v member localRep.IsValRepresentedAsLocalVar (v:Val) = match localRep.LookupRepr v with @@ -13843,7 +13843,7 @@ module MutRecBindingChecking = if not (isNil allExtraGeneralizableTypars) then let freeInInitialEnv = GeneralizationHelpers.ComputeUngeneralizableTypars envInitial for extraTypar in allExtraGeneralizableTypars do - if SetCustom.memberOf freeInInitialEnv extraTypar then + if Zset.memberOf freeInInitialEnv extraTypar then let ty = mkTyparTy extraTypar error(Error(FSComp.SR.tcNotSufficientlyGenericBecauseOfScope(NicePrint.prettyStringOfTy denv ty), extraTypar.Range)) @@ -13875,9 +13875,9 @@ module MutRecBindingChecking = unsolvedTypars |> List.filter (fun tp -> let freeInTypar = (freeInType CollectAllNoCaching (mkTyparTy tp)).FreeTypars // Check it is not one of the generalized variables... - not (genSet |> SetCustom.contains tp) && + not (genSet |> Zset.contains tp) && // Check it involves a generalized variable in one of its constraints... - freeInTypar |> SetCustom.exists (fun otherTypar -> genSet |> SetCustom.contains otherTypar)) + freeInTypar |> Zset.exists (fun otherTypar -> genSet |> Zset.contains otherTypar)) //printfn "unsolvedTyparsInvolvingGeneralizedVariables.Length = %d" unsolvedTyparsInvolvingGeneralizedVariables.Length //for x in unsolvedTypars do // printfn "unsolvedTyparsInvolvingGeneralizedVariable : %s #%d" x.DisplayName x.Stamp @@ -16688,7 +16688,7 @@ let ElimModuleDoBinding bind = let TcMutRecDefnsEscapeCheck (binds: MutRecShapes<_, _, _, _, _>) env = let freeInEnv = GeneralizationHelpers.ComputeUnabstractableTycons env let checkTycon (tycon: Tycon) = - if not tycon.IsTypeAbbrev && SetCustom.contains tycon freeInEnv then + if not tycon.IsTypeAbbrev && Zset.contains tycon freeInEnv then let nm = tycon.DisplayName errorR(Error(FSComp.SR.tcTypeUsedInInvalidWay(nm, nm, nm), tycon.Range)) @@ -16697,7 +16697,7 @@ let TcMutRecDefnsEscapeCheck (binds: MutRecShapes<_, _, _, _, _>) env = let freeInEnv = GeneralizationHelpers.ComputeUnabstractableTraitSolutions env let checkBinds (binds: Binding list) = for bind in binds do - if SetCustom.contains bind.Var freeInEnv then + if Zset.contains bind.Var freeInEnv then let nm = bind.Var.DisplayName errorR(Error(FSComp.SR.tcMemberUsedInInvalidWay(nm, nm, nm), bind.Var.Range)) @@ -17148,7 +17148,7 @@ let CheckValueRestriction denvAtEnd rootSigOpt implFileTypePriorToSig m = if Option.isNone rootSigOpt then let rec check (mty:ModuleOrNamespaceType) = for v in mty.AllValsAndMembers do - let ftyvs = (freeInVal CollectTyparsNoCaching v).FreeTypars |> SetCustom.elements + let ftyvs = (freeInVal CollectTyparsNoCaching v).FreeTypars |> Zset.elements if (not v.IsCompilerGenerated && not (ftyvs |> List.exists (fun tp -> tp.IsFromError)) && // Do not apply the value restriction to methods and functions diff --git a/src/fsharp/TypeRelations.fs b/src/fsharp/TypeRelations.fs index 711435a6723..5fead660a3f 100755 --- a/src/fsharp/TypeRelations.fs +++ b/src/fsharp/TypeRelations.fs @@ -210,7 +210,7 @@ let ChooseTyparSolutionsForFreeChoiceTypars g amap e = /// Only make choices for variables that are actually used in the expression let ftvs = (freeInExpr CollectTyparsNoCaching e1).FreeTyvars.FreeTypars - let tps = tps |> List.filter (SetCustom.memberOf ftvs) + let tps = tps |> List.filter (Zset.memberOf ftvs) let solutions = tps |> List.map (ChooseTyparSolution g amap) |> IterativelySubstituteTyparSolutions g tps diff --git a/src/fsharp/autobox.fs b/src/fsharp/autobox.fs index 04577a00793..f403d840256 100644 --- a/src/fsharp/autobox.fs +++ b/src/fsharp/autobox.fs @@ -26,7 +26,7 @@ let DecideEscapes syntacticArgs body = not passedIn && (v.IsMutable && v.ValReprInfo.IsNone) let frees = freeInExpr CollectLocals body - frees.FreeLocals |> SetCustom.filter cantBeFree + frees.FreeLocals |> Zset.filter cantBeFree /// Find all the mutable locals that escape a lambda expression, ignoring the arguments to the lambda let DecideLambda exprF cenv topValInfo expr ety z = @@ -39,7 +39,7 @@ let DecideLambda exprF cenv topValInfo expr ety z = let args = Option.fold snoc args baseValOpt let syntacticArgs = Option.fold snoc args ctorThisValOpt - let z = SetCustom.union z (DecideEscapes syntacticArgs body) + let z = Zset.union z (DecideEscapes syntacticArgs body) let z = match exprF with Some f -> f z body | None -> z z | _ -> z diff --git a/src/utils/SortKey.fs b/src/utils/SortKey.fs index 902bb32b58c..94e88457ae8 100644 --- a/src/utils/SortKey.fs +++ b/src/utils/SortKey.fs @@ -91,7 +91,7 @@ module Set = type zset<'Key,'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> = Set> [] -type SetCustom<'Key>() = +type Zset<'Key>() = static member empty<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct>() : zset<'Key,'Comparer> = Set.empty> From 8f14562342ae5855dcd1c8d5d8458c757c391d8a Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sun, 12 Aug 2018 18:28:24 +1000 Subject: [PATCH 89/92] Brought Zmap naming inline with Map --- src/fsharp/CompileOps.fs | 2 +- src/fsharp/InnerLambdasToTopLevelFuncs.fs | 4 ++-- src/fsharp/TastOps.fs | 2 +- src/utils/SortKey.fs | 6 +++--- 4 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/fsharp/CompileOps.fs b/src/fsharp/CompileOps.fs index e2ced3b1f45..f0fe182cdec 100644 --- a/src/fsharp/CompileOps.fs +++ b/src/fsharp/CompileOps.fs @@ -5430,7 +5430,7 @@ let TypeCheckOneInputEventually (checkForErrors, tcConfig:TcConfig, tcImports:Tc | ParsedInput.SigFile (ParsedSigFileInput(_, qualNameOfFile, _, _, _) as file) -> // Check if we've seen this top module signature before. - if Zmap.mem qualNameOfFile tcState.tcsRootSigs then + if Zmap.containsKey qualNameOfFile tcState.tcsRootSigs then errorR(Error(FSComp.SR.buildSignatureAlreadySpecified(qualNameOfFile.Text), m.StartRange)) // Check if the implementation came first in compilation order diff --git a/src/fsharp/InnerLambdasToTopLevelFuncs.fs b/src/fsharp/InnerLambdasToTopLevelFuncs.fs index e4fa63a6680..a1f5aa6fdab 100644 --- a/src/fsharp/InnerLambdasToTopLevelFuncs.fs +++ b/src/fsharp/InnerLambdasToTopLevelFuncs.fs @@ -138,7 +138,7 @@ let GetValsBoundUnderMustInline xinfo = Set.union (GetValsBoundInExpr repr) rejectS else rejectS let rejectS = Zset.empty () - let rejectS = Zmap.fold accRejectFrom xinfo.Defns rejectS + let rejectS = Zmap.foldBack accRejectFrom xinfo.Defns rejectS rejectS //------------------------------------------------------------------------- @@ -593,7 +593,7 @@ module Pass2_DetermineReqdItems = let rec fixpoint reqdItemsMap = let changed = false - let changed,reqdItemsMap = Zmap.foldMap (closeStep reqdItemsMap) changed reqdItemsMap + let changed,reqdItemsMap = Zmap.foldBackMap (closeStep reqdItemsMap) changed reqdItemsMap if changed then fixpoint reqdItemsMap else diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index 584149475df..9c290ddd64a 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -2478,7 +2478,7 @@ module SimplifyTypes = | TType_measure _ -> z let incM x m = - if Zmap.mem x m then Zmap.add x (1 + Zmap.find x m) m + if Zmap.containsKey x m then Zmap.add x (1 + Zmap.find x m) m else Zmap.add x 1 m let accTyparCounts z ty = diff --git a/src/utils/SortKey.fs b/src/utils/SortKey.fs index 94e88457ae8..52a1b943786 100644 --- a/src/utils/SortKey.fs +++ b/src/utils/SortKey.fs @@ -43,7 +43,7 @@ type Zmap<'Key,'Value>() = static member inline tryFind<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (k:'Key) (m:zmap<'Key,'Comparer,'Value>) = Map.tryFind {CompareObj=k} m - static member inline mem<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (k:'Key) (m:zmap<'Key,'Comparer,'Value>) = + static member inline containsKey<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (k:'Key) (m:zmap<'Key,'Comparer,'Value>) = Map.containsKey {CompareObj=k} m static member inline memberOf<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (m:zmap<'Key,'Comparer,'Value>) (k:'Key) = @@ -55,7 +55,7 @@ type Zmap<'Key,'Value>() = static member inline find<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (k:'Key) (m:zmap<'Key,'Comparer,'Value>) = Map.find {CompareObj=k} m - static member inline fold<'Comparer, 'State when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (folder:'Key->'Value->'State->'State) (m:zmap<'Key,'Comparer,'Value>) (state:'State) : 'State = + static member inline foldBack<'Comparer, 'State when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (folder:'Key->'Value->'State->'State) (m:zmap<'Key,'Comparer,'Value>) (state:'State) : 'State = Map.foldBack (fun {CompareObj=k} t s -> folder k t s) m state static member inline remove<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (k:'Key) (m:zmap<'Key,'Comparer,'Value>) = @@ -73,7 +73,7 @@ type Zmap<'Key,'Value>() = static member inline iter<'Comparer when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (f:'Key->'Value->unit) (m:zmap<'Key,'Comparer,'Value>) = Map.iter (fun {CompareObj=k} v -> f k v) m - static member foldMap<'Comparer, 'State, 'U when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (folder:'State->'Key->'Value->'State*'U) (initialState:'State) (initialMap:zmap<'Key,'Comparer,'Value>) : 'State * zmap<'Key,'Comparer,'U> = + static member foldBackMap<'Comparer, 'State, 'U when 'Comparer :> IComparer<'Key> and 'Comparer : struct> (folder:'State->'Key->'Value->'State*'U) (initialState:'State) (initialMap:zmap<'Key,'Comparer,'Value>) : 'State * zmap<'Key,'Comparer,'U> = let f = OptimizedClosures.FSharpFunc<_,_,_,_>.Adapt folder let struct (finalState, finalMap) = (initialMap, struct (initialState, Zmap.empty<'Comparer> ())) From e81f27eb346eff3d2e58e2bfd9f37fb05a4690a0 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Mon, 13 Aug 2018 19:07:33 +1000 Subject: [PATCH 90/92] Revert "Deleted zset and TaggedCollections" This reverts commit e525f298691740a0b47bcffb43e10f91388b033e. --- .../FSharp.Compiler.Service.fsproj | 12 + src/absil/zset.fs | 43 ++ src/absil/zset.fsi | 42 ++ .../FSharp.Compiler.Private.fsproj | 12 + .../FSharp.Compiler.Private.fsproj | 39 +- src/fsharp/Fsc-proto/Fsc-proto.fsproj | 12 + src/fsharp/lib.fs | 18 + src/utils/TaggedCollections.fs | 703 ++++++++++++++++++ src/utils/TaggedCollections.fsi | 119 +++ 9 files changed, 995 insertions(+), 5 deletions(-) create mode 100644 src/absil/zset.fs create mode 100644 src/absil/zset.fsi create mode 100644 src/utils/TaggedCollections.fs create mode 100644 src/utils/TaggedCollections.fsi diff --git a/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj b/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj index 972578c7f3e..3d5c4dedfbf 100644 --- a/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj +++ b/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj @@ -111,6 +111,12 @@ Utilities/EditDistance.fs + + Utilities/TaggedCollections.fsi + + + Utilities/TaggedCollections.fs + Utilities/SortKey.fs @@ -132,6 +138,12 @@ Utilities/filename.fs + + Utilities/zset.fsi + + + Utilities/zset.fs + Utilities/bytes.fsi diff --git a/src/absil/zset.fs b/src/absil/zset.fs new file mode 100644 index 00000000000..960caa06e36 --- /dev/null +++ b/src/absil/zset.fs @@ -0,0 +1,43 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +namespace Microsoft.FSharp.Compiler.AbstractIL.Internal + +open Microsoft.FSharp.Compiler.AbstractIL +open Microsoft.FSharp.Compiler.AbstractIL.Internal +open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library +open Internal.Utilities +open Internal.Utilities.Collections.Tagged +open System.Collections.Generic + +/// Sets with a specific comparison function +type internal Zset<'T> = Internal.Utilities.Collections.Tagged.Set<'T> + +[] +module internal Zset = + + let empty (ord : IComparer<'T>) = Internal.Utilities.Collections.Tagged.Set<_,_>.Empty(ord) + + let isEmpty (s:Zset<_>) = s.IsEmpty + + let contains x (s:Zset<_>) = s.Contains(x) + let add x (s:Zset<_>) = s.Add(x) + let addList xs a = List.fold (fun a x -> add x a) a xs + + let singleton ord x = add x (empty ord) + let remove x (s:Zset<_>) = s.Remove(x) + + let fold (f : 'T -> 'b -> 'b) (s:Zset<_>) b = s.Fold f b + let iter f (s:Zset<_>) = s.Iterate f + let forall p (s:Zset<_>) = s.ForAll p + let count (s:Zset<_>) = s.Count + let exists p (s:Zset<_>) = s.Exists p + let subset (s1:Zset<_>) (s2:Zset<_>) = s1.IsSubsetOf s2 + let equal (s1:Zset<_>) (s2:Zset<_>) = Internal.Utilities.Collections.Tagged.Set<_,_>.Equality(s1,s2) + let elements (s:Zset<_>) = s.ToList() + let filter p (s:Zset<_>) = s.Filter p + + let union (s1:Zset<_>) (s2:Zset<_>) = Internal.Utilities.Collections.Tagged.Set<_,_>.Union(s1,s2) + let inter (s1:Zset<_>) (s2:Zset<_>) = Internal.Utilities.Collections.Tagged.Set<_,_>.Intersection(s1,s2) + let diff (s1:Zset<_>) (s2:Zset<_>) = Internal.Utilities.Collections.Tagged.Set<_,_>.Difference(s1,s2) + + let memberOf m k = contains k m diff --git a/src/absil/zset.fsi b/src/absil/zset.fsi new file mode 100644 index 00000000000..094e0288128 --- /dev/null +++ b/src/absil/zset.fsi @@ -0,0 +1,42 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +namespace Microsoft.FSharp.Compiler.AbstractIL.Internal + +open Internal.Utilities +open Microsoft.FSharp.Compiler.AbstractIL +open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library +open System.Collections.Generic + +/// Sets with a specific comparison function +type internal Zset<'T> = Internal.Utilities.Collections.Tagged.Set<'T> + + +[] +module internal Zset = + + val empty : IComparer<'T> -> Zset<'T> + val isEmpty : Zset<'T> -> bool + val contains : 'T -> Zset<'T> -> bool + val memberOf : Zset<'T> -> 'T -> bool + val add : 'T -> Zset<'T> -> Zset<'T> + val addList : 'T list -> Zset<'T> -> Zset<'T> + val singleton : IComparer<'T> -> 'T -> Zset<'T> + val remove : 'T -> Zset<'T> -> Zset<'T> + + val count : Zset<'T> -> int + val union : Zset<'T> -> Zset<'T> -> Zset<'T> + val inter : Zset<'T> -> Zset<'T> -> Zset<'T> + val diff : Zset<'T> -> Zset<'T> -> Zset<'T> + val equal : Zset<'T> -> Zset<'T> -> bool + val subset : Zset<'T> -> Zset<'T> -> bool + val forall : predicate:('T -> bool) -> Zset<'T> -> bool + val exists : predicate:('T -> bool) -> Zset<'T> -> bool + val filter : predicate:('T -> bool) -> Zset<'T> -> Zset<'T> + + val fold : ('T -> 'State -> 'State) -> Zset<'T> -> 'State -> 'State + val iter : ('T -> unit) -> Zset<'T> -> unit + + val elements : Zset<'T> -> 'T list + + + diff --git a/src/buildfromsource/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj b/src/buildfromsource/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj index 23836872cba..16883847faa 100644 --- a/src/buildfromsource/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj +++ b/src/buildfromsource/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj @@ -75,6 +75,12 @@ Utilities\EditDistance.fs + + Utilities\TaggedCollections.fsi + + + Utilities\TaggedCollections.fs + Utilities\SortKey.fs @@ -93,6 +99,12 @@ Utilities\filename.fs + + Utilities\zset.fsi + + + Utilities\zset.fs + Utilities\bytes.fsi diff --git a/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj b/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj index b511a84cad3..afd20bf59ac 100644 --- a/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj +++ b/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj @@ -54,6 +54,8 @@ + + FSComp.txt @@ -111,6 +113,12 @@ Utilities\EditDistance.fs + + Utilities\TaggedCollections.fsi + + + Utilities\TaggedCollections.fs + Utilities\SortKey.fs @@ -129,6 +137,12 @@ Utilities\filename.fs + + Utilities\zset.fsi + + + Utilities\zset.fs + Utilities\bytes.fsi @@ -441,6 +455,8 @@ Logic\TypeChecker.fs + + Optimize\Optimizer.fsi @@ -471,6 +487,8 @@ CodeGen\IlxGen.fs + + Driver\CompileOps.fsi @@ -489,6 +507,8 @@ Driver\fsc.fs + + Symbols/SymbolHelpers.fsi @@ -513,6 +533,8 @@ Symbols/SymbolPatterns.fs + + Service/IncrementalBuild.fsi @@ -615,6 +637,8 @@ Service/ServiceAnalysis.fs + + FSIstrings.txt @@ -624,16 +648,22 @@ InteractiveSession/fsi.fs - + + Misc/MSBuildReferenceResolver.fs + Misc/LegacyHostedCompilerForTesting.fs + + + + - + @@ -649,6 +679,8 @@ ..\..\..\packages\System.ValueTuple.$(SystemValueTuplePackageVersion)\lib\netstandard1.0\System.ValueTuple.dll true + + $(FSharpSourcesRoot)\..\packages\Microsoft.Build.Framework.$(MicrosoftBuildFrameworkPackageVersion)\lib\net46\Microsoft.Build.Framework.dll @@ -669,9 +701,6 @@ - - $(FSharpSourcesRoot)\..\packages\Microsoft.VisualFSharp.Type.Providers.Redist.$(MicrosoftVisualFSharpTypeProvidersRedistPackageVersion)\content\4.3.0.0\FSharp.Data.TypeProviders.dll - {DED3BBD7-53F4-428A-8C9F-27968E768605} FSharp.Core diff --git a/src/fsharp/Fsc-proto/Fsc-proto.fsproj b/src/fsharp/Fsc-proto/Fsc-proto.fsproj index d18c720f5fa..a0d7bbe60fa 100644 --- a/src/fsharp/Fsc-proto/Fsc-proto.fsproj +++ b/src/fsharp/Fsc-proto/Fsc-proto.fsproj @@ -97,6 +97,12 @@ Utilities\EditDistance.fs + + TaggedCollections.fsi + + + TaggedCollections.fs + SortKey.fs @@ -115,6 +121,12 @@ filename.fs + + zset.fsi + + + zset.fs + bytes.fsi diff --git a/src/fsharp/lib.fs b/src/fsharp/lib.fs index 16f48f195ed..5a84551bec1 100755 --- a/src/fsharp/lib.fs +++ b/src/fsharp/lib.fs @@ -248,6 +248,24 @@ let mapTriple (f1,f2,f3) (a1,a2,a3) = (f1 a1, f2 a2, f3 a3) let mapQuadruple (f1,f2,f3,f4) (a1,a2,a3,a4) = (f1 a1, f2 a2, f3 a3, f4 a4) let fmap2Of2 f z (a1,a2) = let z,a2 = f z a2 in z,(a1,a2) +//module List = +// let noRepeats xOrder xs = +// let s = Zset.addList xs (Zset.empty xOrder) // build set +// Zset.elements s // get elements... no repeats + +//--------------------------------------------------------------------------- +// Zset +//------------------------------------------------------------------------- + +//module Zset = +// //let ofList order xs = Zset.addList xs (Zset.empty order) + +// // CLEANUP NOTE: move to Zset? +// let rec fixpoint f (s as s0) = +// let s = f s +// if Zset.equal s s0 then s0 (* fixed *) +// else fixpoint f s (* iterate *) + //--------------------------------------------------------------------------- // Misc //------------------------------------------------------------------------- diff --git a/src/utils/TaggedCollections.fs b/src/utils/TaggedCollections.fs new file mode 100644 index 00000000000..13c39890c69 --- /dev/null +++ b/src/utils/TaggedCollections.fs @@ -0,0 +1,703 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +namespace Internal.Utilities.Collections.Tagged + + #nowarn "51" + #nowarn "69" // interface implementations in augmentations + #nowarn "60" // override implementations in augmentations + + open Microsoft.FSharp.Core + open Microsoft.FSharp.Core.Operators + open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators + open System + open System.Collections.Generic + open Internal.Utilities + open Internal.Utilities.Collections + + + [] + [] + type SetTree<'T> = + | SetEmpty // height = 0 + | SetNode of 'T * SetTree<'T> * SetTree<'T> * int // height = int +#if ONE + | SetOne of 'T // height = 1 +#endif + // OPTIMIZATION: store SetNode(k,SetEmpty,SetEmpty,1) ---> SetOne(k) + + + // CONSIDER: SetTree<'T> = SetEmpty | SetNode of 'T * SetTree<'T> * SetTree<'T> * int + // with SetOne = SetNode of (x,null,null,1) + + [] + module SetTree = + let empty = SetEmpty + + let height t = + match t with + | SetEmpty -> 0 +#if ONE + | SetOne _ -> 1 +#endif + | SetNode (_,_,_,h) -> h + +#if CHECKED + let rec checkInvariant t = + // A good sanity check, loss of balance can hit perf + match t with + | SetEmpty -> true + | SetOne _ -> true + | SetNode (k,t1,t2,h) -> + let h1 = height t1 in + let h2 = height t2 in + (-2 <= (h1 - h2) && (h1 - h2) <= 2) && checkInvariant t1 && checkInvariant t2 +#else + let inline SetOne(x) = SetNode(x,SetEmpty,SetEmpty,1) +#endif + + let tolerance = 2 + + let mk l hl k r hr = +#if ONE + if hl = 0 && hr = 0 then SetOne (k) + else +#endif + let m = if hl < hr then hr else hl + SetNode(k,l,r,m+1) + + let rebalance t1 k t2 = + let t1h = height t1 + let t2h = height t2 + if t2h > t1h + tolerance then // right is heavier than left + match t2 with + | SetNode(t2k,t2l,t2r,_) -> + // one of the nodes must have height > height t1 + 1 + let t2lh = height t2l + if t2lh > t1h + 1 then // balance left: combination + match t2l with + | SetNode(t2lk,t2ll,t2lr,_) -> + let l = mk t1 t1h k t2ll (height t2ll) + let r = mk t2lr (height t2lr) t2k t2r (height t2r) + mk l (height l) t2lk r (height r) + | _ -> failwith "rebalance" + else // rotate left + let l = mk t1 t1h k t2l t2lh + mk l (height l) t2k t2r (height t2r) + | _ -> failwith "rebalance" + else + if t1h > t2h + tolerance then // left is heavier than right + match t1 with + | SetNode(t1k,t1l,t1r,_) -> + // one of the nodes must have height > height t2 + 1 + let t1rh = height t1r + if t1rh > t2h + 1 then + // balance right: combination + match t1r with + | SetNode(t1rk,t1rl,t1rr,_) -> + let l = mk t1l (height t1l) t1k t1rl (height t1rl) + let r = mk t1rr (height t1rr) k t2 t2h + mk l (height l) t1rk r (height r) + | _ -> failwith "rebalance" + else + let r = mk t1r t1rh k t2 t2h + mk t1l (height t1l) t1k r (height r) + | _ -> failwith "rebalance" + else mk t1 t1h k t2 t2h + + let rec add (comparer: IComparer<'T>) k t = + match t with + | SetNode (k2,l,r,_) -> + let c = comparer.Compare(k,k2) + if c < 0 then rebalance (add comparer k l) k2 r + elif c = 0 then t + else rebalance l k2 (add comparer k r) +#if ONE + | SetOne(k2) -> + // nb. no check for rebalance needed for small trees, also be sure to reuse node already allocated + let c = comparer.Compare(k,k2) + if c < 0 then SetNode (k,SetEmpty,t,2) + elif c = 0 then t + else SetNode (k,t,SetEmpty,2) +#endif + | SetEmpty -> SetOne(k) + + let rec balance comparer t1 k t2 = + // Given t1 < k < t2 where t1 and t2 are "balanced", + // return a balanced tree for . + // Recall: balance means subtrees heights differ by at most "tolerance" + match t1,t2 with + | SetEmpty,t2 -> add comparer k t2 // drop t1 = empty + | t1,SetEmpty -> add comparer k t1 // drop t2 = empty +#if ONE + | SetOne k1,t2 -> add comparer k (add comparer k1 t2) + | t1,SetOne k2 -> add comparer k (add comparer k2 t1) +#endif + | SetNode(k1,t11,t12,t1h),SetNode(k2,t21,t22,t2h) -> + // Have: (t11 < k1 < t12) < k < (t21 < k2 < t22) + // Either (a) h1,h2 differ by at most 2 - no rebalance needed. + // (b) h1 too small, i.e. h1+2 < h2 + // (c) h2 too small, i.e. h2+2 < h1 + if t1h+tolerance < t2h then + // case: b, h1 too small + // push t1 into low side of t2, may increase height by 1 so rebalance + rebalance (balance comparer t1 k t21) k2 t22 + elif t2h+tolerance < t1h then + // case: c, h2 too small + // push t2 into high side of t1, may increase height by 1 so rebalance + rebalance t11 k1 (balance comparer t12 k t2) + else + // case: a, h1 and h2 meet balance requirement + mk t1 t1h k t2 t2h + + let rec split (comparer : IComparer<'T>) pivot t = + // Given a pivot and a set t + // Return { x in t s.t. x < pivot }, pivot in t? , { x in t s.t. x > pivot } + match t with + | SetNode(k1,t11,t12,_) -> + let c = comparer.Compare(pivot,k1) + if c < 0 then // pivot t1 + let t11_lo,havePivot,t11_hi = split comparer pivot t11 + t11_lo,havePivot,balance comparer t11_hi k1 t12 + elif c = 0 then // pivot is k1 + t11,true,t12 + else // pivot t2 + let t12_lo,havePivot,t12_hi = split comparer pivot t12 + balance comparer t11 k1 t12_lo,havePivot,t12_hi +#if ONE + | SetOne k1 -> + let c = comparer.Compare(k1,pivot) + if c < 0 then t ,false,SetEmpty // singleton under pivot + elif c = 0 then SetEmpty,true ,SetEmpty // singleton is pivot + else SetEmpty,false,t // singleton over pivot +#endif + | SetEmpty -> + SetEmpty,false,SetEmpty + + let rec spliceOutSuccessor t = + match t with + | SetEmpty -> failwith "internal error: Map.splice_out_succ_or_pred" +#if ONE + | SetOne (k2) -> k2,empty +#endif + | SetNode (k2,l,r,_) -> + match l with + | SetEmpty -> k2,r + | _ -> let k3,l' = spliceOutSuccessor l in k3,mk l' (height l') k2 r (height r) + + let rec remove (comparer: IComparer<'T>) k t = + match t with + | SetEmpty -> t +#if ONE + | SetOne (k2) -> + let c = comparer.Compare(k,k2) + if c = 0 then empty + else t +#endif + | SetNode (k2,l,r,_) -> + let c = comparer.Compare(k,k2) + if c < 0 then rebalance (remove comparer k l) k2 r + elif c = 0 then + match l,r with + | SetEmpty,_ -> r + | _,SetEmpty -> l + | _ -> + let sk,r' = spliceOutSuccessor r + mk l (height l) sk r' (height r') + else rebalance l k2 (remove comparer k r) + + let rec contains (comparer: IComparer<'T>) k t = + match t with + | SetNode(k2,l,r,_) -> + let c = comparer.Compare(k,k2) + if c < 0 then contains comparer k l + elif c = 0 then true + else contains comparer k r +#if ONE + | SetOne(k2) -> (comparer.Compare(k,k2) = 0) +#endif + | SetEmpty -> false + + let rec iter f t = + match t with + | SetNode(k2,l,r,_) -> iter f l; f k2; iter f r +#if ONE + | SetOne(k2) -> f k2 +#endif + | SetEmpty -> () + + // Fold, left-to-right. + // + // NOTE: This differs from the behaviour of Map.fold which folds right-to-left. + let rec fold f m x = + match m with + | SetNode(k,l,r,_) -> fold f r (f k (fold f l x)) +#if ONE + | SetOne(k) -> f k x +#endif + | SetEmpty -> x + + let rec forAll f m = + match m with + | SetNode(k2,l,r,_) -> f k2 && forAll f l && forAll f r +#if ONE + | SetOne(k2) -> f k2 +#endif + | SetEmpty -> true + + let rec exists f m = + match m with + | SetNode(k2,l,r,_) -> f k2 || exists f l || exists f r +#if ONE + | SetOne(k2) -> f k2 +#endif + | SetEmpty -> false + + let isEmpty m = match m with | SetEmpty -> true | _ -> false + + let subset comparer a b = forAll (fun x -> contains comparer x b) a + + let rec elementsAux m acc = + match m with + | SetNode(k2,l,r,_) -> k2 :: (elementsAux l (elementsAux r acc)) +#if ONE + | SetOne(k2) -> k2 :: acc +#endif + | SetEmpty -> acc + + let elements a = elementsAux a [] + + let rec filterAux comparer f s acc = + match s with + | SetNode(k,l,r,_) -> + let acc = if f k then add comparer k acc else acc + filterAux comparer f l (filterAux comparer f r acc) +#if ONE + | SetOne(k) -> if f k then add comparer k acc else acc +#endif + | SetEmpty -> acc + + let filter comparer f s = filterAux comparer f s empty + + let rec diffAux comparer m acc = + match m with + | SetNode(k,l,r,_) -> diffAux comparer l (diffAux comparer r (remove comparer k acc)) +#if ONE + | SetOne(k) -> remove comparer k acc +#endif + | SetEmpty -> acc + + let diff comparer a b = diffAux comparer b a + + let rec countAux s acc = + match s with + | SetNode(_,l,r,_) -> countAux l (countAux r (acc+1)) +#if ONE + | SetOne(k) -> acc+1 +#endif + | SetEmpty -> acc + + let count s = countAux s 0 + + let rec union comparer t1 t2 = + // Perf: tried bruteForce for low heights, but nothing significant + match t1,t2 with + | SetNode(k1,t11,t12,h1),SetNode(k2,t21,t22,h2) -> // (t11 < k < t12) AND (t21 < k2 < t22) + // Divide and Conquer: + // Suppose t1 is largest. + // Split t2 using pivot k1 into lo and hi. + // Union disjoint subproblems and then combine. + if h1 > h2 then + let lo,_,hi = split comparer k1 t2 in + balance comparer (union comparer t11 lo) k1 (union comparer t12 hi) + else + let lo,_,hi = split comparer k2 t1 in + balance comparer (union comparer t21 lo) k2 (union comparer t22 hi) + | SetEmpty,t -> t + | t,SetEmpty -> t +#if ONE + | SetOne k1,t2 -> add comparer k1 t2 + | t1,SetOne k2 -> add comparer k2 t1 +#endif + + let rec intersectionAux comparer b m acc = + match m with + | SetNode(k,l,r,_) -> + let acc = intersectionAux comparer b r acc + let acc = if contains comparer k b then add comparer k acc else acc + intersectionAux comparer b l acc +#if ONE + | SetOne(k) -> + if contains comparer k b then add comparer k acc else acc +#endif + | SetEmpty -> acc + + let intersection comparer a b = intersectionAux comparer b a empty + + let partition1 comparer f k (acc1,acc2) = + if f k then (add comparer k acc1,acc2) + else (acc1,add comparer k acc2) + + let rec partitionAux comparer f s acc = + match s with + | SetNode(k,l,r,_) -> + let acc = partitionAux comparer f r acc + let acc = partition1 comparer f k acc + partitionAux comparer f l acc +#if ONE + | SetOne(k) -> partition1 comparer f k acc +#endif + | SetEmpty -> acc + + let partition comparer f s = partitionAux comparer f s (empty,empty) + + // It's easier to get many less-important algorithms right using this active pattern + let (|MatchSetNode|MatchSetEmpty|) s = + match s with + | SetNode(k2,l,r,_) -> MatchSetNode(k2,l,r) +#if ONE + | SetOne(k2) -> MatchSetNode(k2,SetEmpty,SetEmpty) +#endif + | SetEmpty -> MatchSetEmpty + + let rec nextElemCont (comparer: IComparer<'T>) k s cont = + match s with + | MatchSetNode(k2,l,r) -> + let c = comparer.Compare(k,k2) + if c < 0 then nextElemCont comparer k l (function None -> cont(Some(k2)) | res -> res) + elif c = 0 then cont(minimumElementOpt r) + else nextElemCont comparer k r cont + | MatchSetEmpty -> cont(None) + + and nextElem comparer k s = nextElemCont comparer k s (fun res -> res) + + and prevElemCont (comparer: IComparer<'T>) k s cont = + match s with + | MatchSetNode(k2,l,r) -> + let c = comparer.Compare(k,k2) + if c > 0 then prevElemCont comparer k r (function None -> cont(Some(k2)) | res -> res) + elif c = 0 then cont(maximumElementOpt r) + else prevElemCont comparer k l cont + | MatchSetEmpty -> cont(None) + + and prevElem comparer k s = prevElemCont comparer k s (fun res -> res) + + and minimumElementAux s n = + match s with + | SetNode(k,l,_,_) -> minimumElementAux l k +#if ONE + | SetOne(k) -> k +#endif + | SetEmpty -> n + + and minimumElementOpt s = + match s with + | SetNode(k,l,_,_) -> Some(minimumElementAux l k) +#if ONE + | SetOne(k) -> Some k +#endif + | SetEmpty -> None + + and maximumElementAux s n = + match s with + | SetNode(k,_,r,_) -> maximumElementAux r k +#if ONE + | SetOne(k) -> k +#endif + | SetEmpty -> n + + and maximumElementOpt s = + match s with + | SetNode(k,_,r,_) -> Some(maximumElementAux r k) +#if ONE + | SetOne(k) -> Some(k) +#endif + | SetEmpty -> None + + let minimumElement s = + match minimumElementOpt s with + | Some(k) -> k + | None -> failwith "minimumElement" + + let maximumElement s = + match maximumElementOpt s with + | Some(k) -> k + | None -> failwith "maximumElement" + + + //-------------------------------------------------------------------------- + // Imperative left-to-right iterators. + //-------------------------------------------------------------------------- + + type SetIterator<'T>(s:SetTree<'T>) = + + // collapseLHS: + // a) Always returns either [] or a list starting with SetOne. + // b) The "fringe" of the set stack is unchanged. + let rec collapseLHS stack = + match stack with + | [] -> [] + | SetEmpty :: rest -> collapseLHS rest +#if ONE + | SetOne k :: rest -> stack +#else + | SetNode(_,SetEmpty,SetEmpty,_) :: _ -> stack +#endif + | SetNode(k,l,r,_) :: rest -> collapseLHS (l :: SetOne k :: r :: rest) + + // invariant: always collapseLHS result + let mutable stack = collapseLHS [s] + // true when MoveNext has been called + let mutable started = false + + let notStarted() = raise (new System.InvalidOperationException("Enumeration has not started. Call MoveNext.")) + let alreadyFinished() = raise (new System.InvalidOperationException("Enumeration already finished.")) + + member i.Current = + if started then + match stack with +#if ONE + | SetOne k :: _ -> k +#else + | SetNode( k,_,_,_) :: _ -> k +#endif + | [] -> alreadyFinished() + | _ -> failwith "Please report error: Set iterator, unexpected stack for current" + else + notStarted() + + member i.MoveNext() = + if started then + match stack with +#if ONE + | SetOne _ :: rest -> +#else + | SetNode _ :: rest -> +#endif + stack <- collapseLHS rest; + not stack.IsEmpty + | [] -> false + | _ -> failwith "Please report error: Set iterator, unexpected stack for moveNext" + else + started <- true; // The first call to MoveNext "starts" the enumeration. + not stack.IsEmpty + + let toSeq s = + let i = ref (SetIterator s) + { new IEnumerator<_> with + member __.Current = (!i).Current + interface System.Collections.IEnumerator with + member __.Current = box (!i).Current + member __.MoveNext() = (!i).MoveNext() + member __.Reset() = i := SetIterator s + interface System.IDisposable with + member __.Dispose() = () } + + //-------------------------------------------------------------------------- + // Set comparison. This can be expensive. + //-------------------------------------------------------------------------- + + let rec compareStacks (comparer: IComparer<'T>) l1 l2 = + match l1,l2 with + | [],[] -> 0 + | [],_ -> -1 + | _ ,[] -> 1 + | (SetEmpty _ :: t1),(SetEmpty :: t2) -> compareStacks comparer t1 t2 +#if ONE + | (SetOne(n1k) :: t1),(SetOne(n2k) :: t2) -> + let c = comparer.Compare(n1k,n2k) + if c <> 0 then c else compareStacks comparer t1 t2 + | (SetOne(n1k) :: t1),(SetNode(n2k,SetEmpty,n2r,_) :: t2) -> + let c = comparer.Compare(n1k,n2k) + if c <> 0 then c else compareStacks comparer (empty :: t1) (n2r :: t2) + | (SetNode(n1k,(SetEmpty as emp),n1r,_) :: t1),(SetOne(n2k) :: t2) -> + let c = comparer.Compare(n1k,n2k) + if c <> 0 then c else compareStacks comparer (n1r :: t1) (emp :: t2) +#endif + | (SetNode(n1k,SetEmpty,n1r,_) :: t1),(SetNode(n2k,SetEmpty,n2r,_) :: t2) -> + let c = comparer.Compare(n1k,n2k) + if c <> 0 then c else compareStacks comparer (n1r :: t1) (n2r :: t2) +#if ONE + | (SetOne(n1k) :: t1),_ -> + compareStacks comparer (empty :: SetOne(n1k) :: t1) l2 +#endif + | (SetNode(n1k,n1l,n1r,_) :: t1),_ -> + compareStacks comparer (n1l :: SetNode(n1k,empty,n1r,0) :: t1) l2 +#if ONE + | _,(SetOne(n2k) :: t2) -> + compareStacks comparer l1 (empty :: SetOne(n2k) :: t2) +#endif + | _,(SetNode(n2k,n2l,n2r,_) :: t2) -> + compareStacks comparer l1 (n2l :: SetNode(n2k,empty,n2r,0) :: t2) + + let compare comparer s1 s2 = + match s1,s2 with + | SetEmpty,SetEmpty -> 0 + | SetEmpty,_ -> -1 + | _,SetEmpty -> 1 + | _ -> compareStacks comparer [s1] [s2] + + let choose s = minimumElement s + + let toList s = + let rec loop m x = + match m with + | SetNode(k,l,r,_) -> loop l (k :: (loop r x)) +#if ONE + | SetOne(k) -> k :: x +#endif + | SetEmpty -> x + loop s [] + + let copyToArray s (arr: _[]) i = + let j = ref i + iter (fun x -> arr.[!j] <- x; j := !j + 1) s + + let toArray s = + let n = (count s) + let res = Array.zeroCreate n + copyToArray s res 0; + res + + let rec mkFromEnumerator comparer acc (e : IEnumerator<_>) = + if e.MoveNext() then + mkFromEnumerator comparer (add comparer e.Current acc) e + else acc + + let ofSeq comparer (c : IEnumerable<_>) = + use ie = c.GetEnumerator() + mkFromEnumerator comparer empty ie + + let ofArray comparer l = Array.fold (fun acc k -> add comparer k acc) empty l + + + [] + [] + type internal Set<'T,'ComparerTag> when 'ComparerTag :> IComparer<'T>(comparer: IComparer<'T>, tree: SetTree<'T>) = + + static let refresh (s:Set<_,_>) t = Set<_,_>(comparer=s.Comparer, tree=t) + + member s.Tree = tree + member s.Comparer : IComparer<'T> = comparer + + static member Empty(comparer: 'ComparerTag) : Set<'T,'ComparerTag> = + Set<_,_>(comparer=comparer, tree=SetTree.empty) + + + member s.Add(x) : Set<'T,'ComparerTag> = refresh s (SetTree.add comparer x tree) + member s.Remove(x) : Set<'T,'ComparerTag> = refresh s (SetTree.remove comparer x tree) + member s.Count = SetTree.count tree + member s.Contains(x) = SetTree.contains comparer x tree + member s.Iterate(x) = SetTree.iter x tree + member s.Fold f x = SetTree.fold f tree x + +#if CHECKED + member s.CheckBalanceInvariant = checkInvariant tree // diagnostics... +#endif + member s.IsEmpty = SetTree.isEmpty tree + + member s.Partition f : Set<'T,'ComparerTag> * Set<'T,'ComparerTag> = + match tree with + | SetEmpty -> s,s + | _ -> + let t1,t2 = SetTree.partition comparer f tree + refresh s t1, refresh s t2 + + member s.Filter f : Set<'T,'ComparerTag> = + match tree with + | SetEmpty -> s + | _ -> SetTree.filter comparer f tree |> refresh s + + member s.Exists f = SetTree.exists f tree + + member s.ForAll f = SetTree.forAll f tree + + static member (-) ((a: Set<'T,'ComparerTag>),(b: Set<'T,'ComparerTag>)) = Set<_,_>.Difference(a,b) + + static member (+) ((a: Set<'T,'ComparerTag>),(b: Set<'T,'ComparerTag>)) = Set<_,_>.Union(a,b) + + static member Intersection((a: Set<'T,'ComparerTag>),(b: Set<'T,'ComparerTag>)) : Set<'T,'ComparerTag> = + match b.Tree with + | SetEmpty -> b // A INTER 0 = 0 + | _ -> + match a.Tree with + | SetEmpty -> a // 0 INTER B = 0 + | _ -> SetTree.intersection a.Comparer a.Tree b.Tree |> refresh a + + static member Union(a: Set<'T,'ComparerTag>,b: Set<'T,'ComparerTag>) : Set<'T,'ComparerTag> = + match b.Tree with + | SetEmpty -> a // A U 0 = A + | _ -> + match a.Tree with + | SetEmpty -> b // 0 U B = B + | _ -> SetTree.union a.Comparer a.Tree b.Tree |> refresh a + + static member Difference(a: Set<'T,'ComparerTag>,b: Set<'T,'ComparerTag>) : Set<'T,'ComparerTag> = + match a.Tree with + | SetEmpty -> a // 0 - B = 0 + | _ -> + match b.Tree with + | SetEmpty -> a // A - 0 = A + | _ -> SetTree.diff a.Comparer a.Tree b.Tree |> refresh a + + static member Equality(a: Set<'T,'ComparerTag>,b: Set<'T,'ComparerTag>) = + (SetTree.compare a.Comparer a.Tree b.Tree = 0) + + static member Compare(a: Set<'T,'ComparerTag>,b: Set<'T,'ComparerTag>) = + SetTree.compare a.Comparer a.Tree b.Tree + + member s.Choose = SetTree.choose tree + + member s.MinimumElement = SetTree.minimumElement tree + + member s.MaximumElement = SetTree.maximumElement tree + + member s.IsSubsetOf((y: Set<'T,'ComparerTag>)) = SetTree.subset comparer tree y.Tree + + member s.IsSupersetOf((y: Set<'T,'ComparerTag>)) = SetTree.subset comparer y.Tree tree + + member s.ToList () = SetTree.toList tree + + member s.ToArray () = SetTree.toArray tree + + override this.Equals(that) = + match that with + // Cast to the exact same type as this, otherwise not equal. + | :? Set<'T,'ComparerTag> as that -> ((this :> System.IComparable).CompareTo(that) = 0) + | _ -> false + + interface System.IComparable with + // Cast s2 to the exact same type as s1, see 4884. + // It is not OK to cast s2 to seq<'T>, since different compares could permute the elements. + member s1.CompareTo(s2: obj) = SetTree.compare s1.Comparer s1.Tree ((s2 :?> Set<'T,'ComparerTag>).Tree) + + member this.ComputeHashCode() = + let combineHash x y = (x <<< 1) + y + 631 + let mutable res = 0 + for x in this do + res <- combineHash res (Unchecked.hash x) + abs res + + override this.GetHashCode() = this.ComputeHashCode() + + interface ICollection<'T> with + member s.Add(_) = raise (new System.NotSupportedException("ReadOnlyCollection")) + member s.Clear() = raise (new System.NotSupportedException("ReadOnlyCollection")) + member s.Remove(_) = raise (new System.NotSupportedException("ReadOnlyCollection")) + member s.Contains(x) = SetTree.contains comparer x tree + member s.CopyTo(arr,i) = SetTree.copyToArray tree arr i + member s.IsReadOnly = true + member s.Count = SetTree.count tree + + interface IEnumerable<'T> with + member s.GetEnumerator() = SetTree.toSeq tree + + interface System.Collections.IEnumerable with + override s.GetEnumerator() = (SetTree.toSeq tree :> System.Collections.IEnumerator) + + static member Singleton(comparer,x) : Set<'T,'ComparerTag> = + Set<_,_>.Empty(comparer).Add(x) + + static member Create(comparer : 'ComparerTag,l : seq<'T>) : Set<'T,'ComparerTag> = + Set<_,_>(comparer=comparer, tree=SetTree.ofSeq comparer l) + + type internal Set<'T> = Set<'T, IComparer<'T>> diff --git a/src/utils/TaggedCollections.fsi b/src/utils/TaggedCollections.fsi new file mode 100644 index 00000000000..24d029668d7 --- /dev/null +++ b/src/utils/TaggedCollections.fsi @@ -0,0 +1,119 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +/// This namespace contains FSharp.PowerPack extensions for the F# collection types +namespace Internal.Utilities.Collections.Tagged + + open System + open System.Collections.Generic + + /// Immutable sets based on binary trees, default tag + + /// Immutable sets where a constraint tag carries information about the class of key-comparer being used. + [] + type internal Set<'T,'ComparerTag> when 'ComparerTag :> IComparer<'T> = + + /// A useful shortcut for Set.add. Note this operation produces a new set + /// and does not mutate the original set. The new set will share many storage + /// nodes with the original. See the Set module for further operations on sets. + member Add : 'T -> Set<'T,'ComparerTag> + + /// A useful shortcut for Set.remove. Note this operation produces a new set + /// and does not mutate the original set. The new set will share many storage + /// nodes with the original. See the Set module for further operations on sets. + member Remove : 'T -> Set<'T,'ComparerTag> + + /// Return the number of elements in the set. + member Count : int + + /// A useful shortcut for Set.contains. See the Set module for further operations on sets. + member Contains : 'T -> bool + + /// A useful shortcut for Set.isEmpty. See the Set module for further operations on sets. + member IsEmpty : bool + + /// Apply the given function to each binding in the collection. + member Iterate : ('T -> unit) -> unit + + /// Apply the given accumulating function to all the elements of the set. + member Fold : ('T -> 'State -> 'State) -> 'State -> 'State + + /// Build two new sets, one containing the elements for which the given predicate returns True, + /// and another with the remaining elements. + member Partition: predicate:('T -> bool) -> Set<'T,'ComparerTag> * Set<'T,'ComparerTag> + + /// Return a new collection containing only the elements of the collection + /// for which the given predicate returns True. + member Filter: predicate:('T -> bool) -> Set<'T,'ComparerTag> + + /// Test if any element of the collection satisfies the given predicate. + /// If the input function is f and the elements are i0...iN then computes + /// p i0 or ... or p iN. + member Exists: predicate:('T -> bool) -> bool + + /// Test if all elements of the collection satisfy the given predicate. + /// If the input function is f and the elements are i0...iN and j0...jN then + /// computes p i0 && ... && p iN. + member ForAll: predicate:('T -> bool) -> bool + + /// A set based on the given comparer containing the given initial elements. + static member Create: 'ComparerTag * seq<'T> -> Set<'T,'ComparerTag> + + /// The empty set based on the given comparer. + static member Empty: 'ComparerTag -> Set<'T,'ComparerTag> + + /// A singleton set based on the given comparison operator. + static member Singleton: 'ComparerTag * 'T -> Set<'T,'ComparerTag> + + /// Compares two sets and returns True if they are equal or False otherwise. + static member Equality : Set<'T,'ComparerTag> * Set<'T,'ComparerTag> -> bool + + /// Compares a and b and returns 1 if a > b, -1 if b < a and 0 if a = b. + static member Compare : a:Set<'T,'ComparerTag> * b:Set<'T,'ComparerTag> -> int + + /// Return a new set with the elements of the second set removed from the first. + static member (-) : Set<'T,'ComparerTag> * Set<'T,'ComparerTag> -> Set<'T,'ComparerTag> + + /// Compute the union of the two sets. + static member (+) : Set<'T,'ComparerTag> * Set<'T,'ComparerTag> -> Set<'T,'ComparerTag> + + /// Compute the intersection of the two sets. + static member Intersection : Set<'T,'ComparerTag> * Set<'T,'ComparerTag> -> Set<'T,'ComparerTag> + + /// Compute the union of the two sets. + static member Union : Set<'T,'ComparerTag> * Set<'T,'ComparerTag> -> Set<'T,'ComparerTag> + + /// Return a new set with the elements of the second set removed from the first. + static member Difference: Set<'T,'ComparerTag> * Set<'T,'ComparerTag> -> Set<'T,'ComparerTag> + + /// The number of elements in the set. + member Choose : 'T + + /// Returns the lowest element in the set according to the ordering being used for the set. + member MinimumElement: 'T + + /// Returns the highest element in the set according to the ordering being used for the set. + member MaximumElement: 'T + + /// Evaluates to True if all elements of the second set are in the first. + member IsSubsetOf: Set<'T,'ComparerTag> -> bool + + /// Evaluates to True if all elements of the first set are in the second. + member IsSupersetOf: Set<'T,'ComparerTag> -> bool + + /// The elements of the set as a list. + member ToList : unit -> 'T list + + /// The elements of the set as an array. + member ToArray: unit -> 'T array + + interface ICollection<'T> + + interface IEnumerable<'T> + + interface System.Collections.IEnumerable + + interface System.IComparable + + override Equals : obj -> bool + + type internal Set<'T> = Set<'T, IComparer<'T>> \ No newline at end of file From d5cd1be6e15a8c4847e49a346af4eabb3c2414f6 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Mon, 13 Aug 2018 19:12:24 +1000 Subject: [PATCH 91/92] Removing zset & taggedcollections --- .../FSharp.Compiler.Service.fsproj | 12 - src/absil/zset.fs | 43 -- src/absil/zset.fsi | 42 -- .../FSharp.Compiler.Private.fsproj | 12 - .../FSharp.Compiler.Private.fsproj | 12 - src/fsharp/Fsc-proto/Fsc-proto.fsproj | 12 - src/utils/TaggedCollections.fs | 703 ------------------ src/utils/TaggedCollections.fsi | 119 --- 8 files changed, 955 deletions(-) delete mode 100644 src/absil/zset.fs delete mode 100644 src/absil/zset.fsi delete mode 100644 src/utils/TaggedCollections.fs delete mode 100644 src/utils/TaggedCollections.fsi diff --git a/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj b/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj index 3d5c4dedfbf..972578c7f3e 100644 --- a/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj +++ b/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj @@ -111,12 +111,6 @@ Utilities/EditDistance.fs - - Utilities/TaggedCollections.fsi - - - Utilities/TaggedCollections.fs - Utilities/SortKey.fs @@ -138,12 +132,6 @@ Utilities/filename.fs - - Utilities/zset.fsi - - - Utilities/zset.fs - Utilities/bytes.fsi diff --git a/src/absil/zset.fs b/src/absil/zset.fs deleted file mode 100644 index 960caa06e36..00000000000 --- a/src/absil/zset.fs +++ /dev/null @@ -1,43 +0,0 @@ -// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. - -namespace Microsoft.FSharp.Compiler.AbstractIL.Internal - -open Microsoft.FSharp.Compiler.AbstractIL -open Microsoft.FSharp.Compiler.AbstractIL.Internal -open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library -open Internal.Utilities -open Internal.Utilities.Collections.Tagged -open System.Collections.Generic - -/// Sets with a specific comparison function -type internal Zset<'T> = Internal.Utilities.Collections.Tagged.Set<'T> - -[] -module internal Zset = - - let empty (ord : IComparer<'T>) = Internal.Utilities.Collections.Tagged.Set<_,_>.Empty(ord) - - let isEmpty (s:Zset<_>) = s.IsEmpty - - let contains x (s:Zset<_>) = s.Contains(x) - let add x (s:Zset<_>) = s.Add(x) - let addList xs a = List.fold (fun a x -> add x a) a xs - - let singleton ord x = add x (empty ord) - let remove x (s:Zset<_>) = s.Remove(x) - - let fold (f : 'T -> 'b -> 'b) (s:Zset<_>) b = s.Fold f b - let iter f (s:Zset<_>) = s.Iterate f - let forall p (s:Zset<_>) = s.ForAll p - let count (s:Zset<_>) = s.Count - let exists p (s:Zset<_>) = s.Exists p - let subset (s1:Zset<_>) (s2:Zset<_>) = s1.IsSubsetOf s2 - let equal (s1:Zset<_>) (s2:Zset<_>) = Internal.Utilities.Collections.Tagged.Set<_,_>.Equality(s1,s2) - let elements (s:Zset<_>) = s.ToList() - let filter p (s:Zset<_>) = s.Filter p - - let union (s1:Zset<_>) (s2:Zset<_>) = Internal.Utilities.Collections.Tagged.Set<_,_>.Union(s1,s2) - let inter (s1:Zset<_>) (s2:Zset<_>) = Internal.Utilities.Collections.Tagged.Set<_,_>.Intersection(s1,s2) - let diff (s1:Zset<_>) (s2:Zset<_>) = Internal.Utilities.Collections.Tagged.Set<_,_>.Difference(s1,s2) - - let memberOf m k = contains k m diff --git a/src/absil/zset.fsi b/src/absil/zset.fsi deleted file mode 100644 index 094e0288128..00000000000 --- a/src/absil/zset.fsi +++ /dev/null @@ -1,42 +0,0 @@ -// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. - -namespace Microsoft.FSharp.Compiler.AbstractIL.Internal - -open Internal.Utilities -open Microsoft.FSharp.Compiler.AbstractIL -open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library -open System.Collections.Generic - -/// Sets with a specific comparison function -type internal Zset<'T> = Internal.Utilities.Collections.Tagged.Set<'T> - - -[] -module internal Zset = - - val empty : IComparer<'T> -> Zset<'T> - val isEmpty : Zset<'T> -> bool - val contains : 'T -> Zset<'T> -> bool - val memberOf : Zset<'T> -> 'T -> bool - val add : 'T -> Zset<'T> -> Zset<'T> - val addList : 'T list -> Zset<'T> -> Zset<'T> - val singleton : IComparer<'T> -> 'T -> Zset<'T> - val remove : 'T -> Zset<'T> -> Zset<'T> - - val count : Zset<'T> -> int - val union : Zset<'T> -> Zset<'T> -> Zset<'T> - val inter : Zset<'T> -> Zset<'T> -> Zset<'T> - val diff : Zset<'T> -> Zset<'T> -> Zset<'T> - val equal : Zset<'T> -> Zset<'T> -> bool - val subset : Zset<'T> -> Zset<'T> -> bool - val forall : predicate:('T -> bool) -> Zset<'T> -> bool - val exists : predicate:('T -> bool) -> Zset<'T> -> bool - val filter : predicate:('T -> bool) -> Zset<'T> -> Zset<'T> - - val fold : ('T -> 'State -> 'State) -> Zset<'T> -> 'State -> 'State - val iter : ('T -> unit) -> Zset<'T> -> unit - - val elements : Zset<'T> -> 'T list - - - diff --git a/src/buildfromsource/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj b/src/buildfromsource/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj index 16883847faa..23836872cba 100644 --- a/src/buildfromsource/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj +++ b/src/buildfromsource/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj @@ -75,12 +75,6 @@ Utilities\EditDistance.fs - - Utilities\TaggedCollections.fsi - - - Utilities\TaggedCollections.fs - Utilities\SortKey.fs @@ -99,12 +93,6 @@ Utilities\filename.fs - - Utilities\zset.fsi - - - Utilities\zset.fs - Utilities\bytes.fsi diff --git a/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj b/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj index afd20bf59ac..b2bb687f25c 100644 --- a/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj +++ b/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj @@ -113,12 +113,6 @@ Utilities\EditDistance.fs - - Utilities\TaggedCollections.fsi - - - Utilities\TaggedCollections.fs - Utilities\SortKey.fs @@ -137,12 +131,6 @@ Utilities\filename.fs - - Utilities\zset.fsi - - - Utilities\zset.fs - Utilities\bytes.fsi diff --git a/src/fsharp/Fsc-proto/Fsc-proto.fsproj b/src/fsharp/Fsc-proto/Fsc-proto.fsproj index a0d7bbe60fa..d18c720f5fa 100644 --- a/src/fsharp/Fsc-proto/Fsc-proto.fsproj +++ b/src/fsharp/Fsc-proto/Fsc-proto.fsproj @@ -97,12 +97,6 @@ Utilities\EditDistance.fs - - TaggedCollections.fsi - - - TaggedCollections.fs - SortKey.fs @@ -121,12 +115,6 @@ filename.fs - - zset.fsi - - - zset.fs - bytes.fsi diff --git a/src/utils/TaggedCollections.fs b/src/utils/TaggedCollections.fs deleted file mode 100644 index 13c39890c69..00000000000 --- a/src/utils/TaggedCollections.fs +++ /dev/null @@ -1,703 +0,0 @@ -// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. - -namespace Internal.Utilities.Collections.Tagged - - #nowarn "51" - #nowarn "69" // interface implementations in augmentations - #nowarn "60" // override implementations in augmentations - - open Microsoft.FSharp.Core - open Microsoft.FSharp.Core.Operators - open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators - open System - open System.Collections.Generic - open Internal.Utilities - open Internal.Utilities.Collections - - - [] - [] - type SetTree<'T> = - | SetEmpty // height = 0 - | SetNode of 'T * SetTree<'T> * SetTree<'T> * int // height = int -#if ONE - | SetOne of 'T // height = 1 -#endif - // OPTIMIZATION: store SetNode(k,SetEmpty,SetEmpty,1) ---> SetOne(k) - - - // CONSIDER: SetTree<'T> = SetEmpty | SetNode of 'T * SetTree<'T> * SetTree<'T> * int - // with SetOne = SetNode of (x,null,null,1) - - [] - module SetTree = - let empty = SetEmpty - - let height t = - match t with - | SetEmpty -> 0 -#if ONE - | SetOne _ -> 1 -#endif - | SetNode (_,_,_,h) -> h - -#if CHECKED - let rec checkInvariant t = - // A good sanity check, loss of balance can hit perf - match t with - | SetEmpty -> true - | SetOne _ -> true - | SetNode (k,t1,t2,h) -> - let h1 = height t1 in - let h2 = height t2 in - (-2 <= (h1 - h2) && (h1 - h2) <= 2) && checkInvariant t1 && checkInvariant t2 -#else - let inline SetOne(x) = SetNode(x,SetEmpty,SetEmpty,1) -#endif - - let tolerance = 2 - - let mk l hl k r hr = -#if ONE - if hl = 0 && hr = 0 then SetOne (k) - else -#endif - let m = if hl < hr then hr else hl - SetNode(k,l,r,m+1) - - let rebalance t1 k t2 = - let t1h = height t1 - let t2h = height t2 - if t2h > t1h + tolerance then // right is heavier than left - match t2 with - | SetNode(t2k,t2l,t2r,_) -> - // one of the nodes must have height > height t1 + 1 - let t2lh = height t2l - if t2lh > t1h + 1 then // balance left: combination - match t2l with - | SetNode(t2lk,t2ll,t2lr,_) -> - let l = mk t1 t1h k t2ll (height t2ll) - let r = mk t2lr (height t2lr) t2k t2r (height t2r) - mk l (height l) t2lk r (height r) - | _ -> failwith "rebalance" - else // rotate left - let l = mk t1 t1h k t2l t2lh - mk l (height l) t2k t2r (height t2r) - | _ -> failwith "rebalance" - else - if t1h > t2h + tolerance then // left is heavier than right - match t1 with - | SetNode(t1k,t1l,t1r,_) -> - // one of the nodes must have height > height t2 + 1 - let t1rh = height t1r - if t1rh > t2h + 1 then - // balance right: combination - match t1r with - | SetNode(t1rk,t1rl,t1rr,_) -> - let l = mk t1l (height t1l) t1k t1rl (height t1rl) - let r = mk t1rr (height t1rr) k t2 t2h - mk l (height l) t1rk r (height r) - | _ -> failwith "rebalance" - else - let r = mk t1r t1rh k t2 t2h - mk t1l (height t1l) t1k r (height r) - | _ -> failwith "rebalance" - else mk t1 t1h k t2 t2h - - let rec add (comparer: IComparer<'T>) k t = - match t with - | SetNode (k2,l,r,_) -> - let c = comparer.Compare(k,k2) - if c < 0 then rebalance (add comparer k l) k2 r - elif c = 0 then t - else rebalance l k2 (add comparer k r) -#if ONE - | SetOne(k2) -> - // nb. no check for rebalance needed for small trees, also be sure to reuse node already allocated - let c = comparer.Compare(k,k2) - if c < 0 then SetNode (k,SetEmpty,t,2) - elif c = 0 then t - else SetNode (k,t,SetEmpty,2) -#endif - | SetEmpty -> SetOne(k) - - let rec balance comparer t1 k t2 = - // Given t1 < k < t2 where t1 and t2 are "balanced", - // return a balanced tree for . - // Recall: balance means subtrees heights differ by at most "tolerance" - match t1,t2 with - | SetEmpty,t2 -> add comparer k t2 // drop t1 = empty - | t1,SetEmpty -> add comparer k t1 // drop t2 = empty -#if ONE - | SetOne k1,t2 -> add comparer k (add comparer k1 t2) - | t1,SetOne k2 -> add comparer k (add comparer k2 t1) -#endif - | SetNode(k1,t11,t12,t1h),SetNode(k2,t21,t22,t2h) -> - // Have: (t11 < k1 < t12) < k < (t21 < k2 < t22) - // Either (a) h1,h2 differ by at most 2 - no rebalance needed. - // (b) h1 too small, i.e. h1+2 < h2 - // (c) h2 too small, i.e. h2+2 < h1 - if t1h+tolerance < t2h then - // case: b, h1 too small - // push t1 into low side of t2, may increase height by 1 so rebalance - rebalance (balance comparer t1 k t21) k2 t22 - elif t2h+tolerance < t1h then - // case: c, h2 too small - // push t2 into high side of t1, may increase height by 1 so rebalance - rebalance t11 k1 (balance comparer t12 k t2) - else - // case: a, h1 and h2 meet balance requirement - mk t1 t1h k t2 t2h - - let rec split (comparer : IComparer<'T>) pivot t = - // Given a pivot and a set t - // Return { x in t s.t. x < pivot }, pivot in t? , { x in t s.t. x > pivot } - match t with - | SetNode(k1,t11,t12,_) -> - let c = comparer.Compare(pivot,k1) - if c < 0 then // pivot t1 - let t11_lo,havePivot,t11_hi = split comparer pivot t11 - t11_lo,havePivot,balance comparer t11_hi k1 t12 - elif c = 0 then // pivot is k1 - t11,true,t12 - else // pivot t2 - let t12_lo,havePivot,t12_hi = split comparer pivot t12 - balance comparer t11 k1 t12_lo,havePivot,t12_hi -#if ONE - | SetOne k1 -> - let c = comparer.Compare(k1,pivot) - if c < 0 then t ,false,SetEmpty // singleton under pivot - elif c = 0 then SetEmpty,true ,SetEmpty // singleton is pivot - else SetEmpty,false,t // singleton over pivot -#endif - | SetEmpty -> - SetEmpty,false,SetEmpty - - let rec spliceOutSuccessor t = - match t with - | SetEmpty -> failwith "internal error: Map.splice_out_succ_or_pred" -#if ONE - | SetOne (k2) -> k2,empty -#endif - | SetNode (k2,l,r,_) -> - match l with - | SetEmpty -> k2,r - | _ -> let k3,l' = spliceOutSuccessor l in k3,mk l' (height l') k2 r (height r) - - let rec remove (comparer: IComparer<'T>) k t = - match t with - | SetEmpty -> t -#if ONE - | SetOne (k2) -> - let c = comparer.Compare(k,k2) - if c = 0 then empty - else t -#endif - | SetNode (k2,l,r,_) -> - let c = comparer.Compare(k,k2) - if c < 0 then rebalance (remove comparer k l) k2 r - elif c = 0 then - match l,r with - | SetEmpty,_ -> r - | _,SetEmpty -> l - | _ -> - let sk,r' = spliceOutSuccessor r - mk l (height l) sk r' (height r') - else rebalance l k2 (remove comparer k r) - - let rec contains (comparer: IComparer<'T>) k t = - match t with - | SetNode(k2,l,r,_) -> - let c = comparer.Compare(k,k2) - if c < 0 then contains comparer k l - elif c = 0 then true - else contains comparer k r -#if ONE - | SetOne(k2) -> (comparer.Compare(k,k2) = 0) -#endif - | SetEmpty -> false - - let rec iter f t = - match t with - | SetNode(k2,l,r,_) -> iter f l; f k2; iter f r -#if ONE - | SetOne(k2) -> f k2 -#endif - | SetEmpty -> () - - // Fold, left-to-right. - // - // NOTE: This differs from the behaviour of Map.fold which folds right-to-left. - let rec fold f m x = - match m with - | SetNode(k,l,r,_) -> fold f r (f k (fold f l x)) -#if ONE - | SetOne(k) -> f k x -#endif - | SetEmpty -> x - - let rec forAll f m = - match m with - | SetNode(k2,l,r,_) -> f k2 && forAll f l && forAll f r -#if ONE - | SetOne(k2) -> f k2 -#endif - | SetEmpty -> true - - let rec exists f m = - match m with - | SetNode(k2,l,r,_) -> f k2 || exists f l || exists f r -#if ONE - | SetOne(k2) -> f k2 -#endif - | SetEmpty -> false - - let isEmpty m = match m with | SetEmpty -> true | _ -> false - - let subset comparer a b = forAll (fun x -> contains comparer x b) a - - let rec elementsAux m acc = - match m with - | SetNode(k2,l,r,_) -> k2 :: (elementsAux l (elementsAux r acc)) -#if ONE - | SetOne(k2) -> k2 :: acc -#endif - | SetEmpty -> acc - - let elements a = elementsAux a [] - - let rec filterAux comparer f s acc = - match s with - | SetNode(k,l,r,_) -> - let acc = if f k then add comparer k acc else acc - filterAux comparer f l (filterAux comparer f r acc) -#if ONE - | SetOne(k) -> if f k then add comparer k acc else acc -#endif - | SetEmpty -> acc - - let filter comparer f s = filterAux comparer f s empty - - let rec diffAux comparer m acc = - match m with - | SetNode(k,l,r,_) -> diffAux comparer l (diffAux comparer r (remove comparer k acc)) -#if ONE - | SetOne(k) -> remove comparer k acc -#endif - | SetEmpty -> acc - - let diff comparer a b = diffAux comparer b a - - let rec countAux s acc = - match s with - | SetNode(_,l,r,_) -> countAux l (countAux r (acc+1)) -#if ONE - | SetOne(k) -> acc+1 -#endif - | SetEmpty -> acc - - let count s = countAux s 0 - - let rec union comparer t1 t2 = - // Perf: tried bruteForce for low heights, but nothing significant - match t1,t2 with - | SetNode(k1,t11,t12,h1),SetNode(k2,t21,t22,h2) -> // (t11 < k < t12) AND (t21 < k2 < t22) - // Divide and Conquer: - // Suppose t1 is largest. - // Split t2 using pivot k1 into lo and hi. - // Union disjoint subproblems and then combine. - if h1 > h2 then - let lo,_,hi = split comparer k1 t2 in - balance comparer (union comparer t11 lo) k1 (union comparer t12 hi) - else - let lo,_,hi = split comparer k2 t1 in - balance comparer (union comparer t21 lo) k2 (union comparer t22 hi) - | SetEmpty,t -> t - | t,SetEmpty -> t -#if ONE - | SetOne k1,t2 -> add comparer k1 t2 - | t1,SetOne k2 -> add comparer k2 t1 -#endif - - let rec intersectionAux comparer b m acc = - match m with - | SetNode(k,l,r,_) -> - let acc = intersectionAux comparer b r acc - let acc = if contains comparer k b then add comparer k acc else acc - intersectionAux comparer b l acc -#if ONE - | SetOne(k) -> - if contains comparer k b then add comparer k acc else acc -#endif - | SetEmpty -> acc - - let intersection comparer a b = intersectionAux comparer b a empty - - let partition1 comparer f k (acc1,acc2) = - if f k then (add comparer k acc1,acc2) - else (acc1,add comparer k acc2) - - let rec partitionAux comparer f s acc = - match s with - | SetNode(k,l,r,_) -> - let acc = partitionAux comparer f r acc - let acc = partition1 comparer f k acc - partitionAux comparer f l acc -#if ONE - | SetOne(k) -> partition1 comparer f k acc -#endif - | SetEmpty -> acc - - let partition comparer f s = partitionAux comparer f s (empty,empty) - - // It's easier to get many less-important algorithms right using this active pattern - let (|MatchSetNode|MatchSetEmpty|) s = - match s with - | SetNode(k2,l,r,_) -> MatchSetNode(k2,l,r) -#if ONE - | SetOne(k2) -> MatchSetNode(k2,SetEmpty,SetEmpty) -#endif - | SetEmpty -> MatchSetEmpty - - let rec nextElemCont (comparer: IComparer<'T>) k s cont = - match s with - | MatchSetNode(k2,l,r) -> - let c = comparer.Compare(k,k2) - if c < 0 then nextElemCont comparer k l (function None -> cont(Some(k2)) | res -> res) - elif c = 0 then cont(minimumElementOpt r) - else nextElemCont comparer k r cont - | MatchSetEmpty -> cont(None) - - and nextElem comparer k s = nextElemCont comparer k s (fun res -> res) - - and prevElemCont (comparer: IComparer<'T>) k s cont = - match s with - | MatchSetNode(k2,l,r) -> - let c = comparer.Compare(k,k2) - if c > 0 then prevElemCont comparer k r (function None -> cont(Some(k2)) | res -> res) - elif c = 0 then cont(maximumElementOpt r) - else prevElemCont comparer k l cont - | MatchSetEmpty -> cont(None) - - and prevElem comparer k s = prevElemCont comparer k s (fun res -> res) - - and minimumElementAux s n = - match s with - | SetNode(k,l,_,_) -> minimumElementAux l k -#if ONE - | SetOne(k) -> k -#endif - | SetEmpty -> n - - and minimumElementOpt s = - match s with - | SetNode(k,l,_,_) -> Some(minimumElementAux l k) -#if ONE - | SetOne(k) -> Some k -#endif - | SetEmpty -> None - - and maximumElementAux s n = - match s with - | SetNode(k,_,r,_) -> maximumElementAux r k -#if ONE - | SetOne(k) -> k -#endif - | SetEmpty -> n - - and maximumElementOpt s = - match s with - | SetNode(k,_,r,_) -> Some(maximumElementAux r k) -#if ONE - | SetOne(k) -> Some(k) -#endif - | SetEmpty -> None - - let minimumElement s = - match minimumElementOpt s with - | Some(k) -> k - | None -> failwith "minimumElement" - - let maximumElement s = - match maximumElementOpt s with - | Some(k) -> k - | None -> failwith "maximumElement" - - - //-------------------------------------------------------------------------- - // Imperative left-to-right iterators. - //-------------------------------------------------------------------------- - - type SetIterator<'T>(s:SetTree<'T>) = - - // collapseLHS: - // a) Always returns either [] or a list starting with SetOne. - // b) The "fringe" of the set stack is unchanged. - let rec collapseLHS stack = - match stack with - | [] -> [] - | SetEmpty :: rest -> collapseLHS rest -#if ONE - | SetOne k :: rest -> stack -#else - | SetNode(_,SetEmpty,SetEmpty,_) :: _ -> stack -#endif - | SetNode(k,l,r,_) :: rest -> collapseLHS (l :: SetOne k :: r :: rest) - - // invariant: always collapseLHS result - let mutable stack = collapseLHS [s] - // true when MoveNext has been called - let mutable started = false - - let notStarted() = raise (new System.InvalidOperationException("Enumeration has not started. Call MoveNext.")) - let alreadyFinished() = raise (new System.InvalidOperationException("Enumeration already finished.")) - - member i.Current = - if started then - match stack with -#if ONE - | SetOne k :: _ -> k -#else - | SetNode( k,_,_,_) :: _ -> k -#endif - | [] -> alreadyFinished() - | _ -> failwith "Please report error: Set iterator, unexpected stack for current" - else - notStarted() - - member i.MoveNext() = - if started then - match stack with -#if ONE - | SetOne _ :: rest -> -#else - | SetNode _ :: rest -> -#endif - stack <- collapseLHS rest; - not stack.IsEmpty - | [] -> false - | _ -> failwith "Please report error: Set iterator, unexpected stack for moveNext" - else - started <- true; // The first call to MoveNext "starts" the enumeration. - not stack.IsEmpty - - let toSeq s = - let i = ref (SetIterator s) - { new IEnumerator<_> with - member __.Current = (!i).Current - interface System.Collections.IEnumerator with - member __.Current = box (!i).Current - member __.MoveNext() = (!i).MoveNext() - member __.Reset() = i := SetIterator s - interface System.IDisposable with - member __.Dispose() = () } - - //-------------------------------------------------------------------------- - // Set comparison. This can be expensive. - //-------------------------------------------------------------------------- - - let rec compareStacks (comparer: IComparer<'T>) l1 l2 = - match l1,l2 with - | [],[] -> 0 - | [],_ -> -1 - | _ ,[] -> 1 - | (SetEmpty _ :: t1),(SetEmpty :: t2) -> compareStacks comparer t1 t2 -#if ONE - | (SetOne(n1k) :: t1),(SetOne(n2k) :: t2) -> - let c = comparer.Compare(n1k,n2k) - if c <> 0 then c else compareStacks comparer t1 t2 - | (SetOne(n1k) :: t1),(SetNode(n2k,SetEmpty,n2r,_) :: t2) -> - let c = comparer.Compare(n1k,n2k) - if c <> 0 then c else compareStacks comparer (empty :: t1) (n2r :: t2) - | (SetNode(n1k,(SetEmpty as emp),n1r,_) :: t1),(SetOne(n2k) :: t2) -> - let c = comparer.Compare(n1k,n2k) - if c <> 0 then c else compareStacks comparer (n1r :: t1) (emp :: t2) -#endif - | (SetNode(n1k,SetEmpty,n1r,_) :: t1),(SetNode(n2k,SetEmpty,n2r,_) :: t2) -> - let c = comparer.Compare(n1k,n2k) - if c <> 0 then c else compareStacks comparer (n1r :: t1) (n2r :: t2) -#if ONE - | (SetOne(n1k) :: t1),_ -> - compareStacks comparer (empty :: SetOne(n1k) :: t1) l2 -#endif - | (SetNode(n1k,n1l,n1r,_) :: t1),_ -> - compareStacks comparer (n1l :: SetNode(n1k,empty,n1r,0) :: t1) l2 -#if ONE - | _,(SetOne(n2k) :: t2) -> - compareStacks comparer l1 (empty :: SetOne(n2k) :: t2) -#endif - | _,(SetNode(n2k,n2l,n2r,_) :: t2) -> - compareStacks comparer l1 (n2l :: SetNode(n2k,empty,n2r,0) :: t2) - - let compare comparer s1 s2 = - match s1,s2 with - | SetEmpty,SetEmpty -> 0 - | SetEmpty,_ -> -1 - | _,SetEmpty -> 1 - | _ -> compareStacks comparer [s1] [s2] - - let choose s = minimumElement s - - let toList s = - let rec loop m x = - match m with - | SetNode(k,l,r,_) -> loop l (k :: (loop r x)) -#if ONE - | SetOne(k) -> k :: x -#endif - | SetEmpty -> x - loop s [] - - let copyToArray s (arr: _[]) i = - let j = ref i - iter (fun x -> arr.[!j] <- x; j := !j + 1) s - - let toArray s = - let n = (count s) - let res = Array.zeroCreate n - copyToArray s res 0; - res - - let rec mkFromEnumerator comparer acc (e : IEnumerator<_>) = - if e.MoveNext() then - mkFromEnumerator comparer (add comparer e.Current acc) e - else acc - - let ofSeq comparer (c : IEnumerable<_>) = - use ie = c.GetEnumerator() - mkFromEnumerator comparer empty ie - - let ofArray comparer l = Array.fold (fun acc k -> add comparer k acc) empty l - - - [] - [] - type internal Set<'T,'ComparerTag> when 'ComparerTag :> IComparer<'T>(comparer: IComparer<'T>, tree: SetTree<'T>) = - - static let refresh (s:Set<_,_>) t = Set<_,_>(comparer=s.Comparer, tree=t) - - member s.Tree = tree - member s.Comparer : IComparer<'T> = comparer - - static member Empty(comparer: 'ComparerTag) : Set<'T,'ComparerTag> = - Set<_,_>(comparer=comparer, tree=SetTree.empty) - - - member s.Add(x) : Set<'T,'ComparerTag> = refresh s (SetTree.add comparer x tree) - member s.Remove(x) : Set<'T,'ComparerTag> = refresh s (SetTree.remove comparer x tree) - member s.Count = SetTree.count tree - member s.Contains(x) = SetTree.contains comparer x tree - member s.Iterate(x) = SetTree.iter x tree - member s.Fold f x = SetTree.fold f tree x - -#if CHECKED - member s.CheckBalanceInvariant = checkInvariant tree // diagnostics... -#endif - member s.IsEmpty = SetTree.isEmpty tree - - member s.Partition f : Set<'T,'ComparerTag> * Set<'T,'ComparerTag> = - match tree with - | SetEmpty -> s,s - | _ -> - let t1,t2 = SetTree.partition comparer f tree - refresh s t1, refresh s t2 - - member s.Filter f : Set<'T,'ComparerTag> = - match tree with - | SetEmpty -> s - | _ -> SetTree.filter comparer f tree |> refresh s - - member s.Exists f = SetTree.exists f tree - - member s.ForAll f = SetTree.forAll f tree - - static member (-) ((a: Set<'T,'ComparerTag>),(b: Set<'T,'ComparerTag>)) = Set<_,_>.Difference(a,b) - - static member (+) ((a: Set<'T,'ComparerTag>),(b: Set<'T,'ComparerTag>)) = Set<_,_>.Union(a,b) - - static member Intersection((a: Set<'T,'ComparerTag>),(b: Set<'T,'ComparerTag>)) : Set<'T,'ComparerTag> = - match b.Tree with - | SetEmpty -> b // A INTER 0 = 0 - | _ -> - match a.Tree with - | SetEmpty -> a // 0 INTER B = 0 - | _ -> SetTree.intersection a.Comparer a.Tree b.Tree |> refresh a - - static member Union(a: Set<'T,'ComparerTag>,b: Set<'T,'ComparerTag>) : Set<'T,'ComparerTag> = - match b.Tree with - | SetEmpty -> a // A U 0 = A - | _ -> - match a.Tree with - | SetEmpty -> b // 0 U B = B - | _ -> SetTree.union a.Comparer a.Tree b.Tree |> refresh a - - static member Difference(a: Set<'T,'ComparerTag>,b: Set<'T,'ComparerTag>) : Set<'T,'ComparerTag> = - match a.Tree with - | SetEmpty -> a // 0 - B = 0 - | _ -> - match b.Tree with - | SetEmpty -> a // A - 0 = A - | _ -> SetTree.diff a.Comparer a.Tree b.Tree |> refresh a - - static member Equality(a: Set<'T,'ComparerTag>,b: Set<'T,'ComparerTag>) = - (SetTree.compare a.Comparer a.Tree b.Tree = 0) - - static member Compare(a: Set<'T,'ComparerTag>,b: Set<'T,'ComparerTag>) = - SetTree.compare a.Comparer a.Tree b.Tree - - member s.Choose = SetTree.choose tree - - member s.MinimumElement = SetTree.minimumElement tree - - member s.MaximumElement = SetTree.maximumElement tree - - member s.IsSubsetOf((y: Set<'T,'ComparerTag>)) = SetTree.subset comparer tree y.Tree - - member s.IsSupersetOf((y: Set<'T,'ComparerTag>)) = SetTree.subset comparer y.Tree tree - - member s.ToList () = SetTree.toList tree - - member s.ToArray () = SetTree.toArray tree - - override this.Equals(that) = - match that with - // Cast to the exact same type as this, otherwise not equal. - | :? Set<'T,'ComparerTag> as that -> ((this :> System.IComparable).CompareTo(that) = 0) - | _ -> false - - interface System.IComparable with - // Cast s2 to the exact same type as s1, see 4884. - // It is not OK to cast s2 to seq<'T>, since different compares could permute the elements. - member s1.CompareTo(s2: obj) = SetTree.compare s1.Comparer s1.Tree ((s2 :?> Set<'T,'ComparerTag>).Tree) - - member this.ComputeHashCode() = - let combineHash x y = (x <<< 1) + y + 631 - let mutable res = 0 - for x in this do - res <- combineHash res (Unchecked.hash x) - abs res - - override this.GetHashCode() = this.ComputeHashCode() - - interface ICollection<'T> with - member s.Add(_) = raise (new System.NotSupportedException("ReadOnlyCollection")) - member s.Clear() = raise (new System.NotSupportedException("ReadOnlyCollection")) - member s.Remove(_) = raise (new System.NotSupportedException("ReadOnlyCollection")) - member s.Contains(x) = SetTree.contains comparer x tree - member s.CopyTo(arr,i) = SetTree.copyToArray tree arr i - member s.IsReadOnly = true - member s.Count = SetTree.count tree - - interface IEnumerable<'T> with - member s.GetEnumerator() = SetTree.toSeq tree - - interface System.Collections.IEnumerable with - override s.GetEnumerator() = (SetTree.toSeq tree :> System.Collections.IEnumerator) - - static member Singleton(comparer,x) : Set<'T,'ComparerTag> = - Set<_,_>.Empty(comparer).Add(x) - - static member Create(comparer : 'ComparerTag,l : seq<'T>) : Set<'T,'ComparerTag> = - Set<_,_>(comparer=comparer, tree=SetTree.ofSeq comparer l) - - type internal Set<'T> = Set<'T, IComparer<'T>> diff --git a/src/utils/TaggedCollections.fsi b/src/utils/TaggedCollections.fsi deleted file mode 100644 index 24d029668d7..00000000000 --- a/src/utils/TaggedCollections.fsi +++ /dev/null @@ -1,119 +0,0 @@ -// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. - -/// This namespace contains FSharp.PowerPack extensions for the F# collection types -namespace Internal.Utilities.Collections.Tagged - - open System - open System.Collections.Generic - - /// Immutable sets based on binary trees, default tag - - /// Immutable sets where a constraint tag carries information about the class of key-comparer being used. - [] - type internal Set<'T,'ComparerTag> when 'ComparerTag :> IComparer<'T> = - - /// A useful shortcut for Set.add. Note this operation produces a new set - /// and does not mutate the original set. The new set will share many storage - /// nodes with the original. See the Set module for further operations on sets. - member Add : 'T -> Set<'T,'ComparerTag> - - /// A useful shortcut for Set.remove. Note this operation produces a new set - /// and does not mutate the original set. The new set will share many storage - /// nodes with the original. See the Set module for further operations on sets. - member Remove : 'T -> Set<'T,'ComparerTag> - - /// Return the number of elements in the set. - member Count : int - - /// A useful shortcut for Set.contains. See the Set module for further operations on sets. - member Contains : 'T -> bool - - /// A useful shortcut for Set.isEmpty. See the Set module for further operations on sets. - member IsEmpty : bool - - /// Apply the given function to each binding in the collection. - member Iterate : ('T -> unit) -> unit - - /// Apply the given accumulating function to all the elements of the set. - member Fold : ('T -> 'State -> 'State) -> 'State -> 'State - - /// Build two new sets, one containing the elements for which the given predicate returns True, - /// and another with the remaining elements. - member Partition: predicate:('T -> bool) -> Set<'T,'ComparerTag> * Set<'T,'ComparerTag> - - /// Return a new collection containing only the elements of the collection - /// for which the given predicate returns True. - member Filter: predicate:('T -> bool) -> Set<'T,'ComparerTag> - - /// Test if any element of the collection satisfies the given predicate. - /// If the input function is f and the elements are i0...iN then computes - /// p i0 or ... or p iN. - member Exists: predicate:('T -> bool) -> bool - - /// Test if all elements of the collection satisfy the given predicate. - /// If the input function is f and the elements are i0...iN and j0...jN then - /// computes p i0 && ... && p iN. - member ForAll: predicate:('T -> bool) -> bool - - /// A set based on the given comparer containing the given initial elements. - static member Create: 'ComparerTag * seq<'T> -> Set<'T,'ComparerTag> - - /// The empty set based on the given comparer. - static member Empty: 'ComparerTag -> Set<'T,'ComparerTag> - - /// A singleton set based on the given comparison operator. - static member Singleton: 'ComparerTag * 'T -> Set<'T,'ComparerTag> - - /// Compares two sets and returns True if they are equal or False otherwise. - static member Equality : Set<'T,'ComparerTag> * Set<'T,'ComparerTag> -> bool - - /// Compares a and b and returns 1 if a > b, -1 if b < a and 0 if a = b. - static member Compare : a:Set<'T,'ComparerTag> * b:Set<'T,'ComparerTag> -> int - - /// Return a new set with the elements of the second set removed from the first. - static member (-) : Set<'T,'ComparerTag> * Set<'T,'ComparerTag> -> Set<'T,'ComparerTag> - - /// Compute the union of the two sets. - static member (+) : Set<'T,'ComparerTag> * Set<'T,'ComparerTag> -> Set<'T,'ComparerTag> - - /// Compute the intersection of the two sets. - static member Intersection : Set<'T,'ComparerTag> * Set<'T,'ComparerTag> -> Set<'T,'ComparerTag> - - /// Compute the union of the two sets. - static member Union : Set<'T,'ComparerTag> * Set<'T,'ComparerTag> -> Set<'T,'ComparerTag> - - /// Return a new set with the elements of the second set removed from the first. - static member Difference: Set<'T,'ComparerTag> * Set<'T,'ComparerTag> -> Set<'T,'ComparerTag> - - /// The number of elements in the set. - member Choose : 'T - - /// Returns the lowest element in the set according to the ordering being used for the set. - member MinimumElement: 'T - - /// Returns the highest element in the set according to the ordering being used for the set. - member MaximumElement: 'T - - /// Evaluates to True if all elements of the second set are in the first. - member IsSubsetOf: Set<'T,'ComparerTag> -> bool - - /// Evaluates to True if all elements of the first set are in the second. - member IsSupersetOf: Set<'T,'ComparerTag> -> bool - - /// The elements of the set as a list. - member ToList : unit -> 'T list - - /// The elements of the set as an array. - member ToArray: unit -> 'T array - - interface ICollection<'T> - - interface IEnumerable<'T> - - interface System.Collections.IEnumerable - - interface System.IComparable - - override Equals : obj -> bool - - type internal Set<'T> = Set<'T, IComparer<'T>> \ No newline at end of file From 73faf347d22716da3a7e1d3bcfabeeb505b8c80f Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Mon, 13 Aug 2018 19:17:13 +1000 Subject: [PATCH 92/92] Removed unused commented code --- src/fsharp/lib.fs | 18 ------------------ 1 file changed, 18 deletions(-) diff --git a/src/fsharp/lib.fs b/src/fsharp/lib.fs index 5a84551bec1..16f48f195ed 100755 --- a/src/fsharp/lib.fs +++ b/src/fsharp/lib.fs @@ -248,24 +248,6 @@ let mapTriple (f1,f2,f3) (a1,a2,a3) = (f1 a1, f2 a2, f3 a3) let mapQuadruple (f1,f2,f3,f4) (a1,a2,a3,a4) = (f1 a1, f2 a2, f3 a3, f4 a4) let fmap2Of2 f z (a1,a2) = let z,a2 = f z a2 in z,(a1,a2) -//module List = -// let noRepeats xOrder xs = -// let s = Zset.addList xs (Zset.empty xOrder) // build set -// Zset.elements s // get elements... no repeats - -//--------------------------------------------------------------------------- -// Zset -//------------------------------------------------------------------------- - -//module Zset = -// //let ofList order xs = Zset.addList xs (Zset.empty order) - -// // CLEANUP NOTE: move to Zset? -// let rec fixpoint f (s as s0) = -// let s = f s -// if Zset.equal s s0 then s0 (* fixed *) -// else fixpoint f s (* iterate *) - //--------------------------------------------------------------------------- // Misc //-------------------------------------------------------------------------