From 9f21d518dd0345940a4f614c5538be3b2c64d894 Mon Sep 17 00:00:00 2001 From: Victor Baybekov Date: Wed, 6 Jan 2021 23:41:35 +0100 Subject: [PATCH 01/15] Map: Optimize away `ininst` check Store height in leaves. Compared to the old discussion, when Left/Right were proposed to be stored in a universal node, this adds 4 bytes to leaves or 2 bytes per item on average (vs 16/8). --- src/fsharp/FSharp.Core/map.fs | 243 ++++++++++++++++++++-------------- 1 file changed, 140 insertions(+), 103 deletions(-) diff --git a/src/fsharp/FSharp.Core/map.fs b/src/fsharp/FSharp.Core/map.fs index c0f28b9715a..92338fd63bf 100644 --- a/src/fsharp/FSharp.Core/map.fs +++ b/src/fsharp/FSharp.Core/map.fs @@ -5,25 +5,27 @@ namespace Microsoft.FSharp.Collections open System open System.Collections.Generic open System.Diagnostics +open System.Runtime.CompilerServices open System.Text open Microsoft.FSharp.Core open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators [] [] -type internal MapTree<'Key, 'Value>(k: 'Key, v: 'Value) = +type internal MapTree<'Key, 'Value>(k: 'Key, v: 'Value, h: int) = + member _.Height = h member _.Key = k member _.Value = v - + new(k: 'Key, v: 'Value) = MapTree(k,v,1) + [] [] [] type internal MapTreeNode<'Key, 'Value>(k:'Key, v:'Value, left:MapTree<'Key, 'Value>, right: MapTree<'Key, 'Value>, h: int) = - inherit MapTree<'Key,'Value>(k, v) - + inherit MapTree<'Key,'Value>(k, v, h) member _.Left = left member _.Right = right - member _.Height = h + [] module MapTree = @@ -32,14 +34,17 @@ module MapTree = let inline isEmpty (m:MapTree<'Key, 'Value>) = isNull m + let inline private asNode(value:MapTree<'Key,'Value>) : MapTreeNode<'Key,'Value> = + value :?> MapTreeNode<'Key,'Value> + let rec sizeAux acc (m:MapTree<'Key, 'Value>) = if isEmpty m then acc else - match m with - | :? MapTreeNode<'Key, 'Value> as mn -> sizeAux (sizeAux (acc+1) mn.Left) mn.Right - | _ -> acc + 1 - + match m.Height with + | 1 -> acc + 1 + | _ -> let mn = asNode m in sizeAux (sizeAux (acc+1) mn.Left) mn.Right + let size x = sizeAux 0 x #if TRACE_SETS_AND_MAPS @@ -82,10 +87,7 @@ module MapTree = let inline height (m: MapTree<'Key, 'Value>) = if isEmpty m then 0 - else - match m with - | :? MapTreeNode<'Key, 'Value> as mn -> mn.Height - | _ -> 1 + else m.Height [] let tolerance = 2 @@ -98,9 +100,6 @@ module MapTree = MapTree(k,v) else MapTreeNode(k,v,l,r,m+1) :> MapTree<'Key, 'Value> // new map is higher by 1 than the highest - - let inline private asNode(value:MapTree<'Key,'Value>) : MapTreeNode<'Key,'Value> = - value :?> MapTreeNode<'Key,'Value> let rebalance t1 (k: 'Key) (v: 'Value) t2 : MapTree<'Key, 'Value> = let t1h = height t1 @@ -129,33 +128,39 @@ module MapTree = if isEmpty m then MapTree(k,v) else let c = comparer.Compare(k,m.Key) - match m with - | :? MapTreeNode<'Key, 'Value> as mn -> - if c < 0 then rebalance (add comparer k v mn.Left) mn.Key mn.Value mn.Right - elif c = 0 then MapTreeNode(k,v,mn.Left,mn.Right,mn.Height) :> MapTree<'Key, 'Value> - else rebalance mn.Left mn.Key mn.Value (add comparer k v mn.Right) - | _ -> + match m.Height with + | 1 -> if c < 0 then MapTreeNode (k,v,empty,m,2) :> MapTree<'Key, 'Value> elif c = 0 then MapTree(k,v) else MapTreeNode (k,v,m,empty,2) :> MapTree<'Key, 'Value> - + | _ -> + let mn = asNode m + if c < 0 then rebalance (add comparer k v mn.Left) mn.Key mn.Value mn.Right + elif c = 0 then MapTreeNode(k,v,mn.Left,mn.Right,mn.Height) :> MapTree<'Key, 'Value> + else rebalance mn.Left mn.Key mn.Value (add comparer k v mn.Right) + let rec tryGetValue (comparer: IComparer<'Key>) k (v: byref<'Value>) (m: MapTree<'Key, 'Value>) = if isEmpty m then false else let c = comparer.Compare(k, m.Key) if c = 0 then v <- m.Value; true else - match m with - | :? MapTreeNode<'Key, 'Value> as mn -> + match m.Height with + | 1 -> false + | _ -> + let mn = asNode m tryGetValue comparer k &v (if c < 0 then mn.Left else mn.Right) - | _ -> false - + + [] + let throwKeyNotFound() = raise (KeyNotFoundException()) + + [] let find (comparer: IComparer<'Key>) k (m: MapTree<'Key, 'Value>) = let mutable v = Unchecked.defaultof<'Value> if tryGetValue comparer k &v m then v else - raise (KeyNotFoundException()) + throwKeyNotFound() let tryFind (comparer: IComparer<'Key>) k (m: MapTree<'Key, 'Value>) = let mutable v = Unchecked.defaultof<'Value> @@ -170,12 +175,14 @@ module MapTree = let rec partitionAux (comparer: IComparer<'Key>) (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) acc = if isEmpty m then acc else - match m with - | :? MapTreeNode<'Key, 'Value> as mn -> + match m.Height with + | 1 -> partition1 comparer f m.Key m.Value acc + | _ -> + let mn = asNode m let acc = partitionAux comparer f mn.Right acc let acc = partition1 comparer f mn.Key mn.Value acc partitionAux comparer f mn.Left acc - | _ -> partition1 comparer f m.Key m.Value acc + let partition (comparer: IComparer<'Key>) f m = partitionAux comparer (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) m (empty, empty) @@ -186,12 +193,14 @@ module MapTree = let rec filterAux (comparer: IComparer<'Key>) (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) acc = if isEmpty m then acc else - match m with - | :? MapTreeNode<'Key, 'Value> as mn -> + match m.Height with + | 1 -> filter1 comparer f m.Key m.Value acc + | _ -> + let mn = asNode m let acc = filterAux comparer f mn.Left acc let acc = filter1 comparer f mn.Key mn.Value acc filterAux comparer f mn.Right acc - | _ -> filter1 comparer f m.Key m.Value acc + let filter (comparer: IComparer<'Key>) f m = filterAux comparer (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) m empty @@ -199,18 +208,21 @@ module MapTree = let rec spliceOutSuccessor (m: MapTree<'Key, 'Value>) = if isEmpty m then failwith "internal error: Map.spliceOutSuccessor" else - match m with - | :? MapTreeNode<'Key, 'Value> as mn -> + match m.Height with + | 1 -> m.Key, m.Value, empty + | _ -> + let mn = asNode m if isEmpty mn.Left then mn.Key, mn.Value, mn.Right else let k3, v3, l' = spliceOutSuccessor mn.Left in k3, v3, mk l' mn.Key mn.Value mn.Right - | _ -> m.Key, m.Value, empty let rec remove (comparer: IComparer<'Key>) k (m: MapTree<'Key, 'Value>) = if isEmpty m then empty else let c = comparer.Compare(k, m.Key) - match m with - | :? MapTreeNode<'Key, 'Value> as mn -> + match m.Height with + | 1 -> if c = 0 then empty else m + | _ -> + let mn = asNode m if c < 0 then rebalance (remove comparer k mn.Left) mn.Key mn.Value mn.Right elif c = 0 then if isEmpty mn.Left then mn.Right @@ -219,8 +231,7 @@ module MapTree = let sk, sv, r' = spliceOutSuccessor mn.Right mk mn.Left sk sv r' else rebalance mn.Left mn.Key mn.Value (remove comparer k mn.Right) - | _ -> - if c = 0 then empty else m + let rec change (comparer: IComparer<'Key>) k (u: 'Value option -> 'Value option) (m: MapTree<'Key, 'Value>) : MapTree<'Key,'Value> = if isEmpty m then @@ -228,8 +239,23 @@ module MapTree = | None -> m | Some v -> MapTree (k, v) else - match m with - | :? MapTreeNode<'Key, 'Value> as mn -> + match m.Height with + | 1 -> + let c = comparer.Compare(k, m.Key) + if c < 0 then + match u None with + | None -> m + | Some v -> MapTreeNode (k, v, empty, m, 2) :> MapTree<'Key,'Value> + elif c = 0 then + match u (Some m.Value) with + | None -> empty + | Some v -> MapTree (k, v) + else + match u None with + | None -> m + | Some v -> MapTreeNode (k, v, m, empty, 2) :> MapTree<'Key,'Value> + | _ -> + let mn = asNode m let c = comparer.Compare(k, mn.Key) if c < 0 then rebalance (change comparer k u mn.Left) mn.Key mn.Value mn.Right @@ -244,37 +270,28 @@ module MapTree = | Some v -> MapTreeNode (k, v, mn.Left, mn.Right, mn.Height) :> MapTree<'Key,'Value> else rebalance mn.Left mn.Key mn.Value (change comparer k u mn.Right) - | _ -> - let c = comparer.Compare(k, m.Key) - if c < 0 then - match u None with - | None -> m - | Some v -> MapTreeNode (k, v, empty, m, 2) :> MapTree<'Key,'Value> - elif c = 0 then - match u (Some m.Value) with - | None -> empty - | Some v -> MapTree (k, v) - else - match u None with - | None -> m - | Some v -> MapTreeNode (k, v, m, empty, 2) :> MapTree<'Key,'Value> let rec mem (comparer: IComparer<'Key>) k (m: MapTree<'Key, 'Value>) = if isEmpty m then false else let c = comparer.Compare(k, m.Key) - match m with - | :? MapTreeNode<'Key, 'Value> as mn -> + match m.Height with + | 1 -> c = 0 + | _ -> + let mn = asNode m if c < 0 then mem comparer k mn.Left else (c = 0 || mem comparer k mn.Right) - | _ -> c = 0 + let rec iterOpt (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) = if isEmpty m then () else - match m with - | :? MapTreeNode<'Key, 'Value> as mn -> iterOpt f mn.Left; f.Invoke (mn.Key, mn.Value); iterOpt f mn.Right - | _ -> f.Invoke (m.Key, m.Value) + match m.Height with + | 1 -> f.Invoke (m.Key, m.Value) + | _ -> + let mn = asNode m + iterOpt f mn.Left; f.Invoke (mn.Key, mn.Value); iterOpt f mn.Right + let iter f m = iterOpt (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) m @@ -282,8 +299,10 @@ module MapTree = let rec tryPickOpt (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) = if isEmpty m then None else - match m with - | :? MapTreeNode<'Key, 'Value> as mn -> + match m.Height with + | 1 -> f.Invoke (m.Key, m.Value) + | _ -> + let mn = asNode m match tryPickOpt f mn.Left with | Some _ as res -> res | None -> @@ -291,7 +310,7 @@ module MapTree = | Some _ as res -> res | None -> tryPickOpt f mn.Right - | _ -> f.Invoke (m.Key, m.Value) + let tryPick f m = tryPickOpt (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) m @@ -299,9 +318,12 @@ module MapTree = let rec existsOpt (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) = if isEmpty m then false else - match m with - | :? MapTreeNode<'Key, 'Value> as mn -> existsOpt f mn.Left || f.Invoke (mn.Key, mn.Value) || existsOpt f mn.Right - | _ -> f.Invoke (m.Key, m.Value) + match m.Height with + | 1 -> f.Invoke (m.Key, m.Value) + | _ -> + let mn = asNode m + existsOpt f mn.Left || f.Invoke (mn.Key, mn.Value) || existsOpt f mn.Right + let exists f m = existsOpt (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) m @@ -309,9 +331,12 @@ module MapTree = let rec forallOpt (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) = if isEmpty m then true else - match m with - | :? MapTreeNode<'Key, 'Value> as mn -> forallOpt f mn.Left && f.Invoke (mn.Key, mn.Value) && forallOpt f mn.Right - | _ -> f.Invoke (m.Key, m.Value) + match m.Height with + | 1 -> f.Invoke (m.Key, m.Value) + | _ -> + let mn = asNode m + forallOpt f mn.Left && f.Invoke (mn.Key, mn.Value) && forallOpt f mn.Right + let forall f m = @@ -320,24 +345,27 @@ module MapTree = let rec map (f:'Value -> 'Result) (m: MapTree<'Key, 'Value>) : MapTree<'Key, 'Result> = if isEmpty m then empty else - match m with - | :? MapTreeNode<'Key, 'Value> as mn -> + match m.Height with + | 1 -> MapTree (m.Key, f m.Value) + | _ -> + let mn = asNode m let l2 = map f mn.Left let v2 = f mn.Value let r2 = map f mn.Right MapTreeNode (mn.Key, v2, l2, r2, mn.Height) :> MapTree<'Key, 'Result> - | _ -> MapTree (m.Key, f m.Value) let rec mapiOpt (f: OptimizedClosures.FSharpFunc<'Key, 'Value, 'Result>) (m: MapTree<'Key, 'Value>) = if isEmpty m then empty else - match m with - | :? MapTreeNode<'Key, 'Value> as mn -> + match m.Height with + | 1 -> MapTree (m.Key, f.Invoke (m.Key, m.Value)) + | _ -> + let mn = asNode m let l2 = mapiOpt f mn.Left let v2 = f.Invoke (mn.Key, mn.Value) let r2 = mapiOpt f mn.Right MapTreeNode (mn.Key, v2, l2, r2, mn.Height) :> MapTree<'Key, 'Result> - | _ -> MapTree (m.Key, f.Invoke (m.Key, m.Value)) + let mapi f m = mapiOpt (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) m @@ -345,12 +373,14 @@ module MapTree = let rec foldBackOpt (f: OptimizedClosures.FSharpFunc<_, _, _, _>) (m: MapTree<'Key, 'Value>) x = if isEmpty m then x else - match m with - | :? MapTreeNode<'Key, 'Value> as mn -> + match m.Height with + | 1 -> f.Invoke (m.Key, m.Value, x) + | _ -> + let mn = asNode m let x = foldBackOpt f mn.Right x let x = f.Invoke (mn.Key, mn.Value, x) foldBackOpt f mn.Left x - | _ -> f.Invoke (m.Key, m.Value, x) + let foldBack f m x = foldBackOpt (OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt f) m x @@ -358,12 +388,13 @@ module MapTree = let rec foldOpt (f: OptimizedClosures.FSharpFunc<_, _, _, _>) x (m: MapTree<'Key, 'Value>) = if isEmpty m then x else - match m with - | :? MapTreeNode<'Key, 'Value> as mn -> + match m.Height with + | 1 -> f.Invoke (x, m.Key, m.Value) + | _ -> + let mn = asNode m let x = foldOpt f x mn.Left let x = f.Invoke (x, mn.Key, mn.Value) foldOpt f x mn.Right - | _ -> f.Invoke (x, m.Key, m.Value) let fold f x m = foldOpt (OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt f) x m @@ -372,19 +403,20 @@ module MapTree = let rec foldFromTo (f: OptimizedClosures.FSharpFunc<_, _, _, _>) (m: MapTree<'Key, 'Value>) x = if isEmpty m then x else - match m with - | :? MapTreeNode<'Key, 'Value> as mn -> + match m.Height with + | 1 -> + let cLoKey = comparer.Compare(lo, m.Key) + let cKeyHi = comparer.Compare(m.Key, hi) + let x = if cLoKey <= 0 && cKeyHi <= 0 then f.Invoke (m.Key, m.Value, x) else x + x + | _ -> + let mn = asNode m let cLoKey = comparer.Compare(lo, mn.Key) let cKeyHi = comparer.Compare(mn.Key, hi) let x = if cLoKey < 0 then foldFromTo f mn.Left x else x let x = if cLoKey <= 0 && cKeyHi <= 0 then f.Invoke (mn.Key, mn.Value, x) else x let x = if cKeyHi < 0 then foldFromTo f mn.Right x else x x - | _ -> - let cLoKey = comparer.Compare(lo, m.Key) - let cKeyHi = comparer.Compare(m.Key, hi) - let x = if cLoKey <= 0 && cKeyHi <= 0 then f.Invoke (m.Key, m.Value, x) else x - x if comparer.Compare(lo, hi) = 1 then x else foldFromTo f m x @@ -395,9 +427,12 @@ module MapTree = let rec loop (m: MapTree<'Key, 'Value>) acc = if isEmpty m then acc else - match m with - | :? MapTreeNode<'Key, 'Value> as mn -> loop mn.Left ((mn.Key, mn.Value) :: loop mn.Right acc) - | _ -> (m.Key, m.Value) :: acc + match m.Height with + | 1 -> (m.Key, m.Value) :: acc + | _ -> + let mn = asNode m + loop mn.Left ((mn.Key, mn.Value) :: loop mn.Right acc) + loop m [] let toArray m = @@ -448,9 +483,11 @@ module MapTree = | m :: rest -> if isEmpty m then collapseLHS rest else - match m with - | :? MapTreeNode<'Key, 'Value> as mn -> collapseLHS (mn.Left :: MapTree (mn.Key, mn.Value) :: mn.Right :: rest) - | _ -> stack + match m.Height with + | 1 -> stack + | _ -> + let mn = asNode m + collapseLHS (mn.Left :: MapTree (mn.Key, mn.Value) :: mn.Right :: rest) let mkIterator m = { stack = collapseLHS [m]; started = false } @@ -466,9 +503,9 @@ module MapTree = match i.stack with | [] -> alreadyFinished() | m :: _ -> - match m with - | :? MapTreeNode<'Key, 'Value> -> failwith "Please report error: Map iterator, unexpected stack for current" - | _ -> new KeyValuePair<_, _>(m.Key, m.Value) + match m.Height with + | 1 -> new KeyValuePair<_, _>(m.Key, m.Value) + | _ -> failwith "Please report error: Map iterator, unexpected stack for current" else notStarted() @@ -477,11 +514,11 @@ module MapTree = match i.stack with | [] -> false | m :: rest -> - match m with - | :? MapTreeNode<'Key, 'Value> -> failwith "Please report error: Map iterator, unexpected stack for moveNext" - | _ -> + match m.Height with + | 1 -> i.stack <- collapseLHS rest not i.stack.IsEmpty + | _ -> 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 From aa0572c18e1cb07f86f786cbb9c60e3cf5272de5 Mon Sep 17 00:00:00 2001 From: Victor Baybekov Date: Thu, 7 Jan 2021 13:55:44 +0100 Subject: [PATCH 02/15] Map: use `if` instead of `match` `Match` produces `sub 1` and `switch` instruction. Here, for any non-trivial count, nodes are more frequent than leaves on the path, so branch prediction should be beneficial. --- src/fsharp/FSharp.Core/map.fs | 135 +++++++++++++++++----------------- 1 file changed, 68 insertions(+), 67 deletions(-) diff --git a/src/fsharp/FSharp.Core/map.fs b/src/fsharp/FSharp.Core/map.fs index 92338fd63bf..3f657c5d94b 100644 --- a/src/fsharp/FSharp.Core/map.fs +++ b/src/fsharp/FSharp.Core/map.fs @@ -41,9 +41,11 @@ module MapTree = if isEmpty m then acc else - match m.Height with - | 1 -> acc + 1 - | _ -> let mn = asNode m in sizeAux (sizeAux (acc+1) mn.Left) mn.Right + if m.Height = 1 then + acc + 1 + else + let mn = asNode m + sizeAux (sizeAux (acc+1) mn.Left) mn.Right let size x = sizeAux 0 x @@ -128,12 +130,11 @@ module MapTree = if isEmpty m then MapTree(k,v) else let c = comparer.Compare(k,m.Key) - match m.Height with - | 1 -> + if m.Height = 1 then if c < 0 then MapTreeNode (k,v,empty,m,2) :> MapTree<'Key, 'Value> elif c = 0 then MapTree(k,v) else MapTreeNode (k,v,m,empty,2) :> MapTree<'Key, 'Value> - | _ -> + else let mn = asNode m if c < 0 then rebalance (add comparer k v mn.Left) mn.Key mn.Value mn.Right elif c = 0 then MapTreeNode(k,v,mn.Left,mn.Right,mn.Height) :> MapTree<'Key, 'Value> @@ -145,9 +146,8 @@ module MapTree = let c = comparer.Compare(k, m.Key) if c = 0 then v <- m.Value; true else - match m.Height with - | 1 -> false - | _ -> + if m.Height = 1 then false + else let mn = asNode m tryGetValue comparer k &v (if c < 0 then mn.Left else mn.Right) @@ -175,15 +175,14 @@ module MapTree = let rec partitionAux (comparer: IComparer<'Key>) (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) acc = if isEmpty m then acc else - match m.Height with - | 1 -> partition1 comparer f m.Key m.Value acc - | _ -> + if m.Height = 1 then + partition1 comparer f m.Key m.Value acc + else let mn = asNode m let acc = partitionAux comparer f mn.Right acc let acc = partition1 comparer f mn.Key mn.Value acc partitionAux comparer f mn.Left acc - let partition (comparer: IComparer<'Key>) f m = partitionAux comparer (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) m (empty, empty) @@ -193,9 +192,9 @@ module MapTree = let rec filterAux (comparer: IComparer<'Key>) (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) acc = if isEmpty m then acc else - match m.Height with - | 1 -> filter1 comparer f m.Key m.Value acc - | _ -> + if m.Height = 1 then + filter1 comparer f m.Key m.Value acc + else let mn = asNode m let acc = filterAux comparer f mn.Left acc let acc = filter1 comparer f mn.Key mn.Value acc @@ -208,9 +207,9 @@ module MapTree = let rec spliceOutSuccessor (m: MapTree<'Key, 'Value>) = if isEmpty m then failwith "internal error: Map.spliceOutSuccessor" else - match m.Height with - | 1 -> m.Key, m.Value, empty - | _ -> + if m.Height = 1 then + m.Key, m.Value, empty + else let mn = asNode m if isEmpty mn.Left then mn.Key, mn.Value, mn.Right else let k3, v3, l' = spliceOutSuccessor mn.Left in k3, v3, mk l' mn.Key mn.Value mn.Right @@ -219,9 +218,9 @@ module MapTree = if isEmpty m then empty else let c = comparer.Compare(k, m.Key) - match m.Height with - | 1 -> if c = 0 then empty else m - | _ -> + if m.Height = 1 then + if c = 0 then empty else m + else let mn = asNode m if c < 0 then rebalance (remove comparer k mn.Left) mn.Key mn.Value mn.Right elif c = 0 then @@ -239,8 +238,7 @@ module MapTree = | None -> m | Some v -> MapTree (k, v) else - match m.Height with - | 1 -> + if m.Height = 1 then let c = comparer.Compare(k, m.Key) if c < 0 then match u None with @@ -254,7 +252,7 @@ module MapTree = match u None with | None -> m | Some v -> MapTreeNode (k, v, m, empty, 2) :> MapTree<'Key,'Value> - | _ -> + else let mn = asNode m let c = comparer.Compare(k, mn.Key) if c < 0 then @@ -275,9 +273,9 @@ module MapTree = if isEmpty m then false else let c = comparer.Compare(k, m.Key) - match m.Height with - | 1 -> c = 0 - | _ -> + if m.Height = 1 then + c = 0 + else let mn = asNode m if c < 0 then mem comparer k mn.Left else (c = 0 || mem comparer k mn.Right) @@ -286,9 +284,9 @@ module MapTree = let rec iterOpt (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) = if isEmpty m then () else - match m.Height with - | 1 -> f.Invoke (m.Key, m.Value) - | _ -> + if m.Height = 1 then + f.Invoke (m.Key, m.Value) + else let mn = asNode m iterOpt f mn.Left; f.Invoke (mn.Key, mn.Value); iterOpt f mn.Right @@ -299,9 +297,9 @@ module MapTree = let rec tryPickOpt (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) = if isEmpty m then None else - match m.Height with - | 1 -> f.Invoke (m.Key, m.Value) - | _ -> + if m.Height = 1 then + f.Invoke (m.Key, m.Value) + else let mn = asNode m match tryPickOpt f mn.Left with | Some _ as res -> res @@ -318,9 +316,9 @@ module MapTree = let rec existsOpt (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) = if isEmpty m then false else - match m.Height with - | 1 -> f.Invoke (m.Key, m.Value) - | _ -> + if m.Height = 1 then + f.Invoke (m.Key, m.Value) + else let mn = asNode m existsOpt f mn.Left || f.Invoke (mn.Key, mn.Value) || existsOpt f mn.Right @@ -331,9 +329,9 @@ module MapTree = let rec forallOpt (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) = if isEmpty m then true else - match m.Height with - | 1 -> f.Invoke (m.Key, m.Value) - | _ -> + if m.Height = 1 then + f.Invoke (m.Key, m.Value) + else let mn = asNode m forallOpt f mn.Left && f.Invoke (mn.Key, mn.Value) && forallOpt f mn.Right @@ -345,9 +343,9 @@ module MapTree = let rec map (f:'Value -> 'Result) (m: MapTree<'Key, 'Value>) : MapTree<'Key, 'Result> = if isEmpty m then empty else - match m.Height with - | 1 -> MapTree (m.Key, f m.Value) - | _ -> + if m.Height = 1 then + MapTree (m.Key, f m.Value) + else let mn = asNode m let l2 = map f mn.Left let v2 = f mn.Value @@ -357,9 +355,9 @@ module MapTree = let rec mapiOpt (f: OptimizedClosures.FSharpFunc<'Key, 'Value, 'Result>) (m: MapTree<'Key, 'Value>) = if isEmpty m then empty else - match m.Height with - | 1 -> MapTree (m.Key, f.Invoke (m.Key, m.Value)) - | _ -> + if m.Height = 1 then + MapTree (m.Key, f.Invoke (m.Key, m.Value)) + else let mn = asNode m let l2 = mapiOpt f mn.Left let v2 = f.Invoke (mn.Key, mn.Value) @@ -373,9 +371,9 @@ module MapTree = let rec foldBackOpt (f: OptimizedClosures.FSharpFunc<_, _, _, _>) (m: MapTree<'Key, 'Value>) x = if isEmpty m then x else - match m.Height with - | 1 -> f.Invoke (m.Key, m.Value, x) - | _ -> + if m.Height = 1 then + f.Invoke (m.Key, m.Value, x) + else let mn = asNode m let x = foldBackOpt f mn.Right x let x = f.Invoke (mn.Key, mn.Value, x) @@ -388,9 +386,9 @@ module MapTree = let rec foldOpt (f: OptimizedClosures.FSharpFunc<_, _, _, _>) x (m: MapTree<'Key, 'Value>) = if isEmpty m then x else - match m.Height with - | 1 -> f.Invoke (x, m.Key, m.Value) - | _ -> + if m.Height = 1 then + f.Invoke (x, m.Key, m.Value) + else let mn = asNode m let x = foldOpt f x mn.Left let x = f.Invoke (x, mn.Key, mn.Value) @@ -403,13 +401,12 @@ module MapTree = let rec foldFromTo (f: OptimizedClosures.FSharpFunc<_, _, _, _>) (m: MapTree<'Key, 'Value>) x = if isEmpty m then x else - match m.Height with - | 1 -> + if m.Height = 1 then let cLoKey = comparer.Compare(lo, m.Key) let cKeyHi = comparer.Compare(m.Key, hi) let x = if cLoKey <= 0 && cKeyHi <= 0 then f.Invoke (m.Key, m.Value, x) else x x - | _ -> + else let mn = asNode m let cLoKey = comparer.Compare(lo, mn.Key) let cKeyHi = comparer.Compare(mn.Key, hi) @@ -427,9 +424,9 @@ module MapTree = let rec loop (m: MapTree<'Key, 'Value>) acc = if isEmpty m then acc else - match m.Height with - | 1 -> (m.Key, m.Value) :: acc - | _ -> + if m.Height = 1 then + (m.Key, m.Value) :: acc + else let mn = asNode m loop mn.Left ((mn.Key, mn.Value) :: loop mn.Right acc) @@ -483,9 +480,9 @@ module MapTree = | m :: rest -> if isEmpty m then collapseLHS rest else - match m.Height with - | 1 -> stack - | _ -> + if m.Height = 1 then + stack + else let mn = asNode m collapseLHS (mn.Left :: MapTree (mn.Key, mn.Value) :: mn.Right :: rest) @@ -497,15 +494,20 @@ module MapTree = let alreadyFinished() = raise (InvalidOperationException(SR.GetString(SR.enumerationAlreadyFinished))) + + let unexpectedStackForCurrent() = + failwith "Please report error: Map iterator, unexpected stack for current" + + let unexpectedStackForMoveNext() = + failwith "Please report error: Map iterator, unexpected stack for moveNext" let current i = if i.started then match i.stack with | [] -> alreadyFinished() | m :: _ -> - match m.Height with - | 1 -> new KeyValuePair<_, _>(m.Key, m.Value) - | _ -> failwith "Please report error: Map iterator, unexpected stack for current" + if m.Height = 1 then KeyValuePair<_, _>(m.Key, m.Value) + else unexpectedStackForCurrent() else notStarted() @@ -514,11 +516,10 @@ module MapTree = match i.stack with | [] -> false | m :: rest -> - match m.Height with - | 1 -> + if m.Height = 1 then i.stack <- collapseLHS rest not i.stack.IsEmpty - | _ -> failwith "Please report error: Map iterator, unexpected stack for moveNext" + else unexpectedStackForMoveNext() else i.started <- true (* The first call to MoveNext "starts" the enumeration. *) not i.stack.IsEmpty From bc2825896193c7769980c8ddbaff36e829f8e259 Mon Sep 17 00:00:00 2001 From: Victor Baybekov Date: Sun, 10 Jan 2021 02:03:15 +0100 Subject: [PATCH 03/15] Map: Optimize away `ininst` check: fix trace --- src/fsharp/FSharp.Core/map.fs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/fsharp/FSharp.Core/map.fs b/src/fsharp/FSharp.Core/map.fs index 3f657c5d94b..062bb1424da 100644 --- a/src/fsharp/FSharp.Core/map.fs +++ b/src/fsharp/FSharp.Core/map.fs @@ -73,11 +73,11 @@ module MapTree = (totalSizeOnMapLookup / float numLookups)) System.Console.WriteLine("#largestMapSize = {0}, largestMapStackTrace = {1}", largestMapSize, largestMapStackTrace) - let MapTree n = + let MapTree (k,v) = report() numOnes <- numOnes + 1 totalSizeOnNodeCreation <- totalSizeOnNodeCreation + 1.0 - MapTree n + MapTree (k,v) let MapTreeNode (x, l, v, r, h) = report() From 2ccfed33f2635ff3e98d76d19c3c96022d6d0e67 Mon Sep 17 00:00:00 2001 From: Victor Baybekov Date: Sun, 10 Jan 2021 02:27:35 +0100 Subject: [PATCH 04/15] Set: Optimize away `isinst` check Same as #10845 --- src/fsharp/FSharp.Core/set.fs | 277 ++++++++++++++++++---------------- 1 file changed, 146 insertions(+), 131 deletions(-) diff --git a/src/fsharp/FSharp.Core/set.fs b/src/fsharp/FSharp.Core/set.fs index 23455cb1d44..f09ca1528db 100644 --- a/src/fsharp/FSharp.Core/set.fs +++ b/src/fsharp/FSharp.Core/set.fs @@ -16,19 +16,19 @@ open Microsoft.FSharp.Collections [] [] -type internal SetTree<'T>(k: 'T) = +type internal SetTree<'T>(k: 'T, h: int) = + member _.Height = h member _.Key = k - + new(k: 'T) = SetTree(k,1) + [] [] [] type internal SetTreeNode<'T>(v:'T, left:SetTree<'T>, right: SetTree<'T>, h: int) = - inherit SetTree<'T>(v) - + inherit SetTree<'T>(v,h) member _.Left = left member _.Right = right - member _.Height = h - + [] module internal SetTree = @@ -36,13 +36,18 @@ module internal SetTree = let inline isEmpty (t:SetTree<'T>) = isNull t + let inline private asNode(value:SetTree<'T>) : SetTreeNode<'T> = + value :?> SetTreeNode<'T> + let rec countAux (t:SetTree<'T>) acc = if isEmpty t then acc else - match t with - | :? SetTreeNode<'T> as tn -> countAux tn.Left (countAux tn.Right (acc+1)) - | _ -> acc+1 + if t.Height = 1 then + acc + 1 + else + let tn = asNode t + countAux tn.Left (countAux tn.Right (acc+1)) let count s = countAux s 0 @@ -84,22 +89,19 @@ module internal SetTree = let inline height (t:SetTree<'T>) = if isEmpty t then 0 - else - match t with - | :? SetTreeNode<'T> as tn -> tn.Height - | _ -> 1 + else t.Height #if CHECKED let rec checkInvariant (t:SetTree<'T>) = // A good sanity check, loss of balance can hit perf if isEmpty t then true else - match t with - | :? SetTreeNode<'T> as tn -> + if t.Height = 1 then true + else + let tn = asNode t let h1 = height tn.Left let h2 = height tn.Right (-2 <= (h1 - h2) && (h1 - h2) <= 2) && checkInvariant tn.Left && checkInvariant tn.Right - | _ -> true #endif [] @@ -114,9 +116,6 @@ module internal SetTree = else SetTreeNode (k, l, r, m+1) :> SetTree<'T> - let inline private asNode(value:SetTree<'T>) : SetTreeNode<'T> = - value :?> SetTreeNode<'T> - let rebalance t1 v t2 = let t1h = height t1 let t2h = height t2 @@ -144,17 +143,17 @@ module internal SetTree = if isEmpty t then SetTree k else let c = comparer.Compare(k, t.Key) - match t with - | :? SetTreeNode<'T> as tn -> - if c < 0 then rebalance (add comparer k tn.Left) tn.Key tn.Right - elif c = 0 then t - else rebalance tn.Left tn.Key (add comparer k tn.Right) - | _ -> + if t.Height = 1 then // nb. no check for rebalance needed for small trees, also be sure to reuse node already allocated let c = comparer.Compare(k, t.Key) if c < 0 then SetTreeNode (k, empty, t, 2) :> SetTree<'T> elif c = 0 then t else SetTreeNode (k, t, empty, 2) :> SetTree<'T> + else + let tn = asNode t + if c < 0 then rebalance (add comparer k tn.Left) tn.Key tn.Right + elif c = 0 then t + else rebalance tn.Left tn.Key (add comparer k tn.Right) let rec balance comparer (t1:SetTree<'T>) k (t2:SetTree<'T>) = // Given t1 < k < t2 where t1 and t2 are "balanced", @@ -163,10 +162,12 @@ module internal SetTree = if isEmpty t1 then add comparer k t2 // drop t1 = empty elif isEmpty t2 then add comparer k t1 // drop t2 = empty else - match t1 with - | :? SetTreeNode<'T> as t1n -> - match t2 with - | :? SetTreeNode<'T> as t2n -> + if t1.Height = 1 then add comparer k (add comparer t1.Key t2) + else + let t1n = asNode t1 + if t2.Height = 1 then add comparer k (add comparer t2.Key t1) + else + let t2n = asNode t2 // Have: (t1l < k1 < t1r) < k < (t2l < k2 < t2r) // Either (a) h1, h2 differ by at most 2 - no rebalance needed. // (b) h1 too small, i.e. h1+2 < h2 @@ -182,16 +183,19 @@ module internal SetTree = else // case: a, h1 and h2 meet balance requirement mk t1 k t2 - | _ -> add comparer k (add comparer t2.Key t1) - | _ -> add comparer k (add comparer t1.Key t2) let rec split (comparer: IComparer<'T>) pivot (t:SetTree<'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 } if isEmpty t then empty, false, empty else - match t with - | :? SetTreeNode<'T> as tn -> + if t.Height = 1 then + let c = comparer.Compare(t.Key, pivot) + if c < 0 then t, false, empty // singleton under pivot + elif c = 0 then empty, true, empty // singleton is pivot + else empty, false, t // singleton over pivot + else + let tn = asNode t let c = comparer.Compare(pivot, tn.Key) if c < 0 then // pivot t1 let t11Lo, havePivot, t11Hi = split comparer pivot tn.Left @@ -201,27 +205,24 @@ module internal SetTree = else // pivot t2 let t12Lo, havePivot, t12Hi = split comparer pivot tn.Right balance comparer tn.Left tn.Key t12Lo, havePivot, t12Hi - | _ -> - let c = comparer.Compare(t.Key, pivot) - if c < 0 then t, false, empty // singleton under pivot - elif c = 0 then empty, true, empty // singleton is pivot - else empty, false, t // singleton over pivot let rec spliceOutSuccessor (t:SetTree<'T>) = if isEmpty t then failwith "internal error: Set.spliceOutSuccessor" else - match t with - | :? SetTreeNode<'T> as tn -> + if t.Height = 1 then t.Key, empty + else + let tn = asNode t if isEmpty tn.Left then tn.Key, tn.Right else let k3, l' = spliceOutSuccessor tn.Left in k3, mk l' tn.Key tn.Right - | _ -> t.Key, empty let rec remove (comparer: IComparer<'T>) k (t:SetTree<'T>) = if isEmpty t then t else let c = comparer.Compare(k, t.Key) - match t with - | :? SetTreeNode<'T> as tn -> + if t.Height = 1 then + if c = 0 then empty else t + else + let tn = asNode t if c < 0 then rebalance (remove comparer k tn.Left) tn.Key tn.Right elif c = 0 then if isEmpty tn.Left then tn.Right @@ -229,63 +230,64 @@ module internal SetTree = else let sk, r' = spliceOutSuccessor tn.Right mk tn.Left sk r' - else rebalance tn.Left tn.Key (remove comparer k tn.Right) - | _ -> - if c = 0 then empty - else t + else rebalance tn.Left tn.Key (remove comparer k tn.Right) let rec mem (comparer: IComparer<'T>) k (t:SetTree<'T>) = if isEmpty t then false else let c = comparer.Compare(k, t.Key) - match t with - | :? SetTreeNode<'T> as tn -> + if t.Height = 1 then (c = 0) + else + let tn = asNode t if c < 0 then mem comparer k tn.Left elif c = 0 then true else mem comparer k tn.Right - | _ -> (c = 0) let rec iter f (t:SetTree<'T>) = if isEmpty t then () else - match t with - | :? SetTreeNode<'T> as tn -> iter f tn.Left; f tn.Key; iter f tn.Right - | _ -> f t.Key + if t.Height = 1 then f t.Key + else + let tn = asNode t + iter f tn.Left; f tn.Key; iter f tn.Right let rec foldBackOpt (f:OptimizedClosures.FSharpFunc<_, _, _>) (t:SetTree<'T>) x = if isEmpty t then x else - match t with - | :? SetTreeNode<'T> as tn -> foldBackOpt f tn.Left (f.Invoke(tn.Key, (foldBackOpt f tn.Right x))) - | _ -> f.Invoke(t.Key, x) + if t.Height = 1 then f.Invoke(t.Key, x) + else + let tn = asNode t + foldBackOpt f tn.Left (f.Invoke(tn.Key, (foldBackOpt f tn.Right x))) let foldBack f m x = foldBackOpt (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) m x let rec foldOpt (f:OptimizedClosures.FSharpFunc<_, _, _>) x (t:SetTree<'T>) = if isEmpty t then x else - match t with - | :? SetTreeNode<'T> as tn -> + if t.Height = 1 then f.Invoke(x, t.Key) + else + let tn = asNode t let x = foldOpt f x tn.Left in let x = f.Invoke(x, tn.Key) foldOpt f x tn.Right - | _ -> f.Invoke(x, t.Key) let fold f x m = foldOpt (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) x m let rec forall f (t:SetTree<'T>) = if isEmpty t then true else - match t with - | :? SetTreeNode<'T> as tn -> f tn.Key && forall f tn.Left && forall f tn.Right - | _ -> f t.Key + if t.Height = 1 then f t.Key + else + let tn = asNode t + f tn.Key && forall f tn.Left && forall f tn.Right let rec exists f (t:SetTree<'T>) = if isEmpty t then false else - match t with - | :? SetTreeNode<'T> as tn -> f tn.Key || exists f tn.Left || exists f tn.Right - | _ -> f t.Key + if t.Height = 1 then f t.Key + else + let tn = asNode t + f tn.Key || exists f tn.Left || exists f tn.Right let subset comparer a b = forall (fun x -> mem comparer x b) a @@ -296,11 +298,12 @@ module internal SetTree = let rec filterAux comparer f (t:SetTree<'T>) acc = if isEmpty t then acc else - match t with - | :? SetTreeNode<'T> as tn -> + if t.Height = 1 then + if f t.Key then add comparer t.Key acc else acc + else + let tn = asNode t let acc = if f tn.Key then add comparer tn.Key acc else acc filterAux comparer f tn.Left (filterAux comparer f tn.Right acc) - | _ -> if f t.Key then add comparer t.Key acc else acc let filter comparer f s = filterAux comparer f s empty @@ -309,9 +312,10 @@ module internal SetTree = else if isEmpty t then acc else - match t with - | :? SetTreeNode<'T> as tn -> diffAux comparer tn.Left (diffAux comparer tn.Right (remove comparer tn.Key acc)) - | _ -> remove comparer t.Key acc + if t.Height = 1 then remove comparer t.Key acc + else + let tn = asNode t + diffAux comparer tn.Left (diffAux comparer tn.Right (remove comparer tn.Key acc)) let diff comparer a b = diffAux comparer b a @@ -320,10 +324,12 @@ module internal SetTree = if isEmpty t1 then t2 elif isEmpty t2 then t1 else - match t1 with - | :? SetTreeNode<'T> as t1n -> - match t2 with - | :? SetTreeNode<'T> as t2n -> // (t1l < k < t1r) AND (t2l < k2 < t2r) + if t1.Height = 1 then add comparer t1.Key t2 + else + let t1n = asNode t1 + if t2.Height = 1 then add comparer t2.Key t1 + else + let t2n = asNode t2 // (t1l < k < t1r) AND (t2l < k2 < t2r) // Divide and Conquer: // Suppose t1 is largest. // Split t2 using pivot k1 into lo and hi. @@ -334,19 +340,17 @@ module internal SetTree = else let lo, _, hi = split comparer t2n.Key t1 in balance comparer (union comparer t2n.Left lo) t2n.Key (union comparer t2n.Right hi) - | _ -> add comparer t2.Key t1 - | _ -> add comparer t1.Key t2 let rec intersectionAux comparer b (t:SetTree<'T>) acc = if isEmpty t then acc else - match t with - | :? SetTreeNode<'T> as tn -> + if t.Height = 1 then + if mem comparer t.Key b then add comparer t.Key acc else acc + else + let tn = asNode t let acc = intersectionAux comparer b tn.Right acc let acc = if mem comparer tn.Key b then add comparer tn.Key acc else acc intersectionAux comparer b tn.Left acc - | _ -> - if mem comparer t.Key b then add comparer t.Key acc else acc let intersection comparer a b = intersectionAux comparer b a empty @@ -355,42 +359,46 @@ module internal SetTree = let rec partitionAux comparer f (t:SetTree<'T>) acc = if isEmpty t then acc else - match t with - | :? SetTreeNode<'T> as tn -> + if t.Height = 1 then partition1 comparer f t.Key acc + else + let tn = asNode t let acc = partitionAux comparer f tn.Right acc let acc = partition1 comparer f tn.Key acc partitionAux comparer f tn.Left acc - | _ -> partition1 comparer f t.Key acc let partition comparer f s = partitionAux comparer f s (empty, empty) let rec minimumElementAux (t:SetTree<'T>) n = if isEmpty t then n else - match t with - | :? SetTreeNode<'T> as tn -> minimumElementAux tn.Left tn.Key - | _ -> t.Key + if t.Height = 1 then t.Key + else + let tn = asNode t + minimumElementAux tn.Left tn.Key and minimumElementOpt (t:SetTree<'T>) = if isEmpty t then None else - match t with - | :? SetTreeNode<'T> as tn -> Some(minimumElementAux tn.Left tn.Key) - | _ -> Some t.Key + if t.Height = 1 then Some t.Key + else + let tn = asNode t + Some(minimumElementAux tn.Left tn.Key) and maximumElementAux (t:SetTree<'T>) n = if isEmpty t then n else - match t with - | :? SetTreeNode<'T> as tn -> maximumElementAux tn.Right tn.Key - | _ -> t.Key + if t.Height = 1 then t.Key + else + let tn = asNode t + maximumElementAux tn.Right tn.Key and maximumElementOpt (t:SetTree<'T>) = if isEmpty t then None else - match t with - | :? SetTreeNode<'T> as tn -> Some(maximumElementAux tn.Right tn.Key) - | _ -> Some t.Key + if t.Height = 1 then Some t.Key + else + let tn = asNode t + Some(maximumElementAux tn.Right tn.Key) let minimumElement s = match minimumElementOpt s with @@ -418,9 +426,10 @@ module internal SetTree = | x :: rest -> if isEmpty x then collapseLHS rest else - match x with - | :? SetTreeNode<'T> as xn-> collapseLHS (xn.Left :: SetTree xn.Key :: xn.Right :: rest) - | _ -> stack + if x.Height = 1 then stack + else + let xn = asNode x + collapseLHS (xn.Left :: SetTree xn.Key :: xn.Right :: rest) let mkIterator s = { stack = collapseLHS [s]; started = false } @@ -436,16 +445,19 @@ module internal SetTree = else notStarted() + let unexpectedStackForMoveNext() = failwith "Please report error: Set iterator, unexpected stack for moveNext" + let unexpectedstateInSetTreeCompareStacks() = failwith "unexpected state in SetTree.compareStacks" + let rec moveNext i = if i.started then match i.stack with | [] -> false | t :: rest -> - match t with - | :? SetTreeNode<'T> -> failwith "Please report error: Set iterator, unexpected stack for moveNext" - | _ -> + if t.Height = 1 then i.stack <- collapseLHS rest - not i.stack.IsEmpty + not i.stack.IsEmpty + else + unexpectedStackForMoveNext() else i.started <- true; // The first call to MoveNext "starts" the enumeration. not i.stack.IsEmpty @@ -466,16 +478,18 @@ module internal SetTree = let cont() = match l1, l2 with | (x1 :: t1), _ when not (isEmpty x1) -> - match x1 with - | :? SetTreeNode<'T> as x1n -> + if x1.Height = 1 then + compareStacks comparer (empty :: SetTree x1.Key :: t1) l2 + else + let x1n = asNode x1 compareStacks comparer (x1n.Left :: (SetTreeNode (x1n.Key, empty, x1n.Right, 0) :> SetTree<'T>) :: t1) l2 - | _ -> compareStacks comparer (empty :: SetTree x1.Key :: t1) l2 | _, (x2 :: t2) when not (isEmpty x2) -> - match x2 with - | :? SetTreeNode<'T> as x2n -> + if x2.Height = 1 then + compareStacks comparer l1 (empty :: SetTree x2.Key :: t2) + else + let x2n = asNode x2 compareStacks comparer l1 (x2n.Left :: (SetTreeNode (x2n.Key, empty, x2n.Right, 0) :> SetTree<'T> ) :: t2) - | _ -> compareStacks comparer l1 (empty :: SetTree x2.Key :: t2) - | _ -> failwith "unexpected state in SetTree.compareStacks" + | _ -> unexpectedstateInSetTreeCompareStacks() match l1, l2 with | [], [] -> 0 @@ -487,30 +501,30 @@ module internal SetTree = else cont() elif isEmpty x2 then cont() else - match x1 with - | :? SetTreeNode<'T> as x1n -> + if x1.Height = 1 then + if x2.Height = 1 then + let c = comparer.Compare(x1.Key, x2.Key) + if c <> 0 then c else compareStacks comparer t1 t2 + else + let x2n = asNode x2 + if isEmpty x2n.Left then + let c = comparer.Compare(x1.Key, x2n.Key) + if c <> 0 then c else compareStacks comparer (empty :: t1) (x2n.Right :: t2) + else cont() + else + let x1n = asNode x1 if isEmpty x1n.Left then - match x2 with - | :? SetTreeNode<'T> as x2n -> + if x2.Height = 1 then + let c = comparer.Compare(x1n.Key, x2.Key) + if c <> 0 then c else compareStacks comparer (x1n.Right :: t1) (empty :: t2) + else + let x2n = asNode x2 if isEmpty x2n.Left then let c = comparer.Compare(x1n.Key, x2n.Key) if c <> 0 then c else compareStacks comparer (x1n.Right :: t1) (x2n.Right :: t2) else cont() - | _ -> - let c = comparer.Compare(x1n.Key, x2.Key) - if c <> 0 then c else compareStacks comparer (x1n.Right :: t1) (empty :: t2) else cont() - | _ -> - match x2 with - | :? SetTreeNode<'T> as x2n -> - if isEmpty x2n.Left then - let c = comparer.Compare(x1.Key, x2n.Key) - if c <> 0 then c else compareStacks comparer (empty :: t1) (x2n.Right :: t2) - else cont() - | _ -> - let c = comparer.Compare(x1.Key, x2.Key) - if c <> 0 then c else compareStacks comparer t1 t2 - + let compare comparer (t1:SetTree<'T>) (t2:SetTree<'T>) = if isEmpty t1 then if isEmpty t2 then 0 @@ -526,9 +540,10 @@ module internal SetTree = let rec loop (t':SetTree<'T>) acc = if isEmpty t' then acc else - match t' with - | :? SetTreeNode<'T> as tn -> loop tn.Left (tn.Key :: loop tn.Right acc) - | _ -> t'.Key :: acc + if t'.Height = 1 then t'.Key :: acc + else + let tn = asNode t + loop tn.Left (tn.Key :: loop tn.Right acc) loop t [] let copyToArray s (arr: _[]) i = From 79a8e7fb35cd35adc54d6547361ef1a569a52fb0 Mon Sep 17 00:00:00 2001 From: Victor Baybekov Date: Sun, 10 Jan 2021 02:35:34 +0100 Subject: [PATCH 05/15] Set: Optimize away `isinst` check: remove duplicate compare call in add --- src/fsharp/FSharp.Core/set.fs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/fsharp/FSharp.Core/set.fs b/src/fsharp/FSharp.Core/set.fs index f09ca1528db..33720d7066a 100644 --- a/src/fsharp/FSharp.Core/set.fs +++ b/src/fsharp/FSharp.Core/set.fs @@ -145,7 +145,6 @@ module internal SetTree = let c = comparer.Compare(k, t.Key) if t.Height = 1 then // nb. no check for rebalance needed for small trees, also be sure to reuse node already allocated - let c = comparer.Compare(k, t.Key) if c < 0 then SetTreeNode (k, empty, t, 2) :> SetTree<'T> elif c = 0 then t else SetTreeNode (k, t, empty, 2) :> SetTree<'T> From 1475159796d695759ff390563dafd5c94c4407fc Mon Sep 17 00:00:00 2001 From: Victor Baybekov Date: Sun, 10 Jan 2021 03:49:21 +0100 Subject: [PATCH 06/15] Set: Optimize away `isinst` check: fix stack overflow --- src/fsharp/FSharp.Core/set.fs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/fsharp/FSharp.Core/set.fs b/src/fsharp/FSharp.Core/set.fs index 33720d7066a..29f6af81673 100644 --- a/src/fsharp/FSharp.Core/set.fs +++ b/src/fsharp/FSharp.Core/set.fs @@ -325,9 +325,9 @@ module internal SetTree = else if t1.Height = 1 then add comparer t1.Key t2 else - let t1n = asNode t1 if t2.Height = 1 then add comparer t2.Key t1 else + let t1n = asNode t1 let t2n = asNode t2 // (t1l < k < t1r) AND (t2l < k2 < t2r) // Divide and Conquer: // Suppose t1 is largest. @@ -541,7 +541,7 @@ module internal SetTree = else if t'.Height = 1 then t'.Key :: acc else - let tn = asNode t + let tn = asNode t' loop tn.Left (tn.Key :: loop tn.Right acc) loop t [] From d6ffe5cba32ba1e2abc58a9c67e0d4f05148fcd1 Mon Sep 17 00:00:00 2001 From: Victor Baybekov Date: Fri, 8 Jan 2021 13:32:45 +0100 Subject: [PATCH 07/15] Map: optimize comparer Inline primitive comparison, keep the rest the same. See Comparison/cmp comments on how and why this works. --- src/fsharp/FSharp.Core/map.fs | 261 +++++++++++++++++++++------------- 1 file changed, 165 insertions(+), 96 deletions(-) diff --git a/src/fsharp/FSharp.Core/map.fs b/src/fsharp/FSharp.Core/map.fs index 062bb1424da..049c63e9527 100644 --- a/src/fsharp/FSharp.Core/map.fs +++ b/src/fsharp/FSharp.Core/map.fs @@ -1,10 +1,12 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. - +#nowarn "1182" namespace Microsoft.FSharp.Collections open System open System.Collections.Generic open System.Diagnostics +open System.Numerics +open System.Reflection open System.Runtime.CompilerServices open System.Text open Microsoft.FSharp.Core @@ -25,13 +27,90 @@ type internal MapTreeNode<'Key, 'Value>(k:'Key, v:'Value, left:MapTree<'Key, 'Va inherit MapTree<'Key,'Value>(k, v, h) member _.Left = left member _.Right = right - - + [] module MapTree = let empty = null - + + type CompareHelper<'T when 'T : comparison>() = + static let c = LanguagePrimitives.FastGenericComparer + + static member private IsIComparableFunc() = + + match box(Unchecked.defaultof<'T>) with + | :? IComparable<'T> -> true + | _ -> false + + static member private CompareC<'U when 'U :> IComparable<'U>>(l:'U, r:'U):int = l.CompareTo(r) + static member val Comparer: IComparer<'T> = c + + static member val CompareToDlg = + let dlg = + try + if CompareHelper<'T>.IsIComparableFunc() then + let m = + typeof>.GetMethod("CompareC", BindingFlags.NonPublic ||| BindingFlags.Static) + .MakeGenericMethod([|typeof<'T>|]) + let dlg = Delegate.CreateDelegate(typeof>, m) :?> Func<'T,'T,int> + dlg + else + null + with _ -> null + dlg + with get + + // If backed by static readonly field that will be JIT-time constant (must ensure beforefieldinit) + static member val IsIComparable = not(isNull CompareHelper<'T>.CompareToDlg) with get + + static member Compare(l:'T, r:'T):int = + if CompareHelper<'T>.IsIComparable then + CompareHelper<'T>.CompareToDlg.Invoke(l,r) + else + c.Compare(l, r) + + // Constructors are not inlined by F#, but JIT could inline them. + // This is what we need here, because LanguagePrimitives.FastGenericComparer.Compare + // has a .tail prefix that breaks the typeof(T)==typeof(...) JIT optimization in cmp + // A struct with a single int field should be lowered by JIT. + [] + [] + type Comparison<'T when 'T : comparison> = + struct + val Value: int + [] + new(l:'T,r:'T) = { Value = CompareHelper<'T>.Compare(l, r) } + end + + [] + let cmp<'T when 'T : comparison> (l:'T) (r:'T) : int = + // See the pattern explanation: https://github.com/dotnet/runtime/blob/4b8d10154c39b1f56424d4ba2068a3150d90d475/src/libraries/System.Private.CoreLib/src/System/Numerics/Vector_1.cs#L14 + // All types that implement IComparable<'T> and are accessible here without additional dependencies should be in the list + if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + + else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + + else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + + else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + + else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + else if Type.op_Equality(typeof<'T>, typeof) then Unchecked.compare (unbox(box(l))) (unbox(box(r))) + + else Comparison(l,r).Value + let inline isEmpty (m:MapTree<'Key, 'Value>) = isNull m let inline private asNode(value:MapTree<'Key,'Value>) : MapTreeNode<'Key,'Value> = @@ -126,83 +205,83 @@ module MapTree = mk t1'.Left t1'.Key t1'.Value (mk t1'.Right k v t2) else mk t1 k v t2 - let rec add (comparer: IComparer<'Key>) k (v: 'Value) (m: MapTree<'Key, 'Value>) : MapTree<'Key, 'Value> = + let rec add k (v: 'Value) (m: MapTree<'Key, 'Value>) : MapTree<'Key, 'Value> = if isEmpty m then MapTree(k,v) else - let c = comparer.Compare(k,m.Key) + let c = cmp k m.Key if m.Height = 1 then if c < 0 then MapTreeNode (k,v,empty,m,2) :> MapTree<'Key, 'Value> elif c = 0 then MapTree(k,v) else MapTreeNode (k,v,m,empty,2) :> MapTree<'Key, 'Value> else let mn = asNode m - if c < 0 then rebalance (add comparer k v mn.Left) mn.Key mn.Value mn.Right + if c < 0 then rebalance (add k v mn.Left) mn.Key mn.Value mn.Right elif c = 0 then MapTreeNode(k,v,mn.Left,mn.Right,mn.Height) :> MapTree<'Key, 'Value> - else rebalance mn.Left mn.Key mn.Value (add comparer k v mn.Right) + else rebalance mn.Left mn.Key mn.Value (add k v mn.Right) - let rec tryGetValue (comparer: IComparer<'Key>) k (v: byref<'Value>) (m: MapTree<'Key, 'Value>) = + let rec tryGetValue k (v: byref<'Value>) (m: MapTree<'Key, 'Value>) = if isEmpty m then false else - let c = comparer.Compare(k, m.Key) + let c = cmp k m.Key if c = 0 then v <- m.Value; true else if m.Height = 1 then false else let mn = asNode m - tryGetValue comparer k &v (if c < 0 then mn.Left else mn.Right) + tryGetValue k &v (if c < 0 then mn.Left else mn.Right) [] let throwKeyNotFound() = raise (KeyNotFoundException()) [] - let find (comparer: IComparer<'Key>) k (m: MapTree<'Key, 'Value>) = + let find k (m: MapTree<'Key, 'Value>) = let mutable v = Unchecked.defaultof<'Value> - if tryGetValue comparer k &v m then + if tryGetValue k &v m then v else throwKeyNotFound() - let tryFind (comparer: IComparer<'Key>) k (m: MapTree<'Key, 'Value>) = + let tryFind k (m: MapTree<'Key, 'Value>) = let mutable v = Unchecked.defaultof<'Value> - if tryGetValue comparer k &v m then + if tryGetValue k &v m then Some v else None - 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 partition1 (f: OptimizedClosures.FSharpFunc<_, _, _>) k v (acc1, acc2) = + if f.Invoke (k, v) then (add k v acc1, acc2) else (acc1, add k v acc2) - let rec partitionAux (comparer: IComparer<'Key>) (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) acc = + let rec partitionAux (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) acc = if isEmpty m then acc else if m.Height = 1 then - partition1 comparer f m.Key m.Value acc + partition1 f m.Key m.Value acc else let mn = asNode m - let acc = partitionAux comparer f mn.Right acc - let acc = partition1 comparer f mn.Key mn.Value acc - partitionAux comparer f mn.Left acc + let acc = partitionAux f mn.Right acc + let acc = partition1 f mn.Key mn.Value acc + partitionAux f mn.Left acc - let partition (comparer: IComparer<'Key>) f m = - partitionAux comparer (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) m (empty, empty) + let partition f m = + partitionAux (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) m (empty, empty) - 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 filter1 (f: OptimizedClosures.FSharpFunc<_, _, _>) k v acc = + if f.Invoke (k, v) then add k v acc else acc - let rec filterAux (comparer: IComparer<'Key>) (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) acc = + let rec filterAux (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) acc = if isEmpty m then acc else if m.Height = 1 then - filter1 comparer f m.Key m.Value acc + filter1 f m.Key m.Value acc else let mn = asNode m - let acc = filterAux comparer f mn.Left acc - let acc = filter1 comparer f mn.Key mn.Value acc - filterAux comparer f mn.Right acc + let acc = filterAux f mn.Left acc + let acc = filter1 f mn.Key mn.Value acc + filterAux f mn.Right acc - let filter (comparer: IComparer<'Key>) f m = - filterAux comparer (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) m empty + let filter f m = + filterAux (OptimizedClosures.FSharpFunc<_, _, _>.Adapt f) m empty let rec spliceOutSuccessor (m: MapTree<'Key, 'Value>) = if isEmpty m then failwith "internal error: Map.spliceOutSuccessor" @@ -214,32 +293,32 @@ module MapTree = if isEmpty mn.Left then mn.Key, mn.Value, mn.Right else let k3, v3, l' = spliceOutSuccessor mn.Left in k3, v3, mk l' mn.Key mn.Value mn.Right - let rec remove (comparer: IComparer<'Key>) k (m: MapTree<'Key, 'Value>) = + let rec remove k (m: MapTree<'Key, 'Value>) = if isEmpty m then empty else - let c = comparer.Compare(k, m.Key) + let c = cmp k m.Key if m.Height = 1 then if c = 0 then empty else m else let mn = asNode m - if c < 0 then rebalance (remove comparer k mn.Left) mn.Key mn.Value mn.Right + if c < 0 then rebalance (remove k mn.Left) mn.Key mn.Value mn.Right elif c = 0 then if isEmpty mn.Left then mn.Right elif isEmpty mn.Right then mn.Left else let sk, sv, r' = spliceOutSuccessor mn.Right mk mn.Left sk sv r' - else rebalance mn.Left mn.Key mn.Value (remove comparer k mn.Right) + else rebalance mn.Left mn.Key mn.Value (remove k mn.Right) - let rec change (comparer: IComparer<'Key>) k (u: 'Value option -> 'Value option) (m: MapTree<'Key, 'Value>) : MapTree<'Key,'Value> = + let rec change k (u: 'Value option -> 'Value option) (m: MapTree<'Key, 'Value>) : MapTree<'Key,'Value> = if isEmpty m then match u None with | None -> m | Some v -> MapTree (k, v) else if m.Height = 1 then - let c = comparer.Compare(k, m.Key) + let c = cmp k m.Key if c < 0 then match u None with | None -> m @@ -254,9 +333,9 @@ module MapTree = | Some v -> MapTreeNode (k, v, m, empty, 2) :> MapTree<'Key,'Value> else let mn = asNode m - let c = comparer.Compare(k, mn.Key) + let c = cmp k mn.Key if c < 0 then - rebalance (change comparer k u mn.Left) mn.Key mn.Value mn.Right + rebalance (change k u mn.Left) mn.Key mn.Value mn.Right elif c = 0 then match u (Some mn.Value) with | None -> @@ -267,18 +346,18 @@ module MapTree = mk mn.Left sk sv r' | Some v -> MapTreeNode (k, v, mn.Left, mn.Right, mn.Height) :> MapTree<'Key,'Value> else - rebalance mn.Left mn.Key mn.Value (change comparer k u mn.Right) + rebalance mn.Left mn.Key mn.Value (change k u mn.Right) - let rec mem (comparer: IComparer<'Key>) k (m: MapTree<'Key, 'Value>) = + let rec mem k (m: MapTree<'Key, 'Value>) = if isEmpty m then false else - let c = comparer.Compare(k, m.Key) + let c = cmp k m.Key if m.Height = 1 then c = 0 else let mn = asNode m - if c < 0 then mem comparer k mn.Left - else (c = 0 || mem comparer k mn.Right) + if c < 0 then mem k mn.Left + else (c = 0 || mem k mn.Right) let rec iterOpt (f: OptimizedClosures.FSharpFunc<_, _, _>) (m: MapTree<'Key, 'Value>) = @@ -397,28 +476,28 @@ module MapTree = let fold f x m = foldOpt (OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt f) x m - let foldSectionOpt (comparer: IComparer<'Key>) lo hi (f: OptimizedClosures.FSharpFunc<_, _, _, _>) (m: MapTree<'Key, 'Value>) x = + let foldSectionOpt lo hi (f: OptimizedClosures.FSharpFunc<_, _, _, _>) (m: MapTree<'Key, 'Value>) x = let rec foldFromTo (f: OptimizedClosures.FSharpFunc<_, _, _, _>) (m: MapTree<'Key, 'Value>) x = if isEmpty m then x else if m.Height = 1 then - let cLoKey = comparer.Compare(lo, m.Key) - let cKeyHi = comparer.Compare(m.Key, hi) + let cLoKey = cmp lo m.Key + let cKeyHi = cmp m.Key hi let x = if cLoKey <= 0 && cKeyHi <= 0 then f.Invoke (m.Key, m.Value, x) else x x else let mn = asNode m - let cLoKey = comparer.Compare(lo, mn.Key) - let cKeyHi = comparer.Compare(mn.Key, hi) + let cLoKey = cmp lo mn.Key + let cKeyHi = cmp mn.Key hi let x = if cLoKey < 0 then foldFromTo f mn.Left x else x let x = if cLoKey <= 0 && cKeyHi <= 0 then f.Invoke (mn.Key, mn.Value, x) else x let x = if cKeyHi < 0 then foldFromTo f mn.Right x else x x - if comparer.Compare(lo, hi) = 1 then x else foldFromTo f m x + if cmp lo hi = 1 then x else foldFromTo f m x - let foldSection (comparer: IComparer<'Key>) lo hi f m x = - foldSectionOpt comparer lo hi (OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt f) m x + let foldSection lo hi f m x = + foldSectionOpt lo hi (OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt f) m x let toList (m: MapTree<'Key, 'Value>) = let rec loop (m: MapTree<'Key, 'Value>) acc = @@ -435,28 +514,28 @@ module MapTree = 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 l = + List.fold (fun acc (k, v) -> add k v acc) empty l - let rec mkFromEnumerator comparer acc (e : IEnumerator<_>) = + let rec mkFromEnumerator acc (e : IEnumerator<_>) = if e.MoveNext() then let (x, y) = e.Current - mkFromEnumerator comparer (add comparer x y acc) e + mkFromEnumerator (add x y acc) e else acc - let ofArray comparer (arr : array<'Key * 'Value>) = + let ofArray (arr : array<'Key * 'Value>) = let mutable res = empty for (x, y) in arr do - res <- add comparer x y res + res <- add x y res res - let ofSeq comparer (c : seq<'Key * 'T>) = + let ofSeq (c : seq<'Key * 'T>) = match c with - | :? array<'Key * 'T> as xs -> ofArray comparer xs - | :? list<'Key * 'T> as xs -> ofList comparer xs + | :? array<'Key * 'T> as xs -> ofArray xs + | :? list<'Key * 'T> as xs -> ofList xs | _ -> use ie = c.GetEnumerator() - mkFromEnumerator comparer empty ie + mkFromEnumerator empty ie let copyToArray m (arr: _[]) i = let mutable j = i @@ -542,12 +621,8 @@ module MapTree = [] [] [] -type Map<[]'Key, []'Value when 'Key : comparison >(comparer: IComparer<'Key>, tree: MapTree<'Key, 'Value>) = +type Map<[]'Key, []'Value when 'Key : comparison >(tree: MapTree<'Key, 'Value>) = - [] - // This type is logically immutable. This field is only mutated during deserialization. - let mutable comparer = comparer - [] // This type is logically immutable. This field is only mutated during deserialization. let mutable tree = tree @@ -561,8 +636,7 @@ type Map<[]'Key, [ - new Map<'Key, 'Value>(comparer, MapTree.empty) + new Map<'Key, 'Value>(MapTree.empty : MapTree<'Key, 'Value>) [] member _.OnSerializing(context: System.Runtime.Serialization.StreamingContext) = @@ -577,23 +651,20 @@ type Map<[]'Key, [] member _.OnDeserialized(context: System.Runtime.Serialization.StreamingContext) = ignore context - comparer <- LanguagePrimitives.FastGenericComparer<'Key> - tree <- serializedData |> Array.map (fun kvp -> kvp.Key, kvp.Value) |> MapTree.ofArray comparer + tree <- serializedData |> Array.map (fun kvp -> kvp.Key, kvp.Value) |> MapTree.ofArray serializedData <- null static member Empty : Map<'Key, 'Value> = empty static member Create(ie : IEnumerable<_>) : Map<'Key, 'Value> = - let comparer = LanguagePrimitives.FastGenericComparer<'Key> - new Map<_, _>(comparer, MapTree.ofSeq comparer ie) + Map<_, _>(MapTree.ofSeq ie) new (elements : seq<_>) = - let comparer = LanguagePrimitives.FastGenericComparer<'Key> - new Map<_, _>(comparer, MapTree.ofSeq comparer elements) + Map<_, _>(MapTree.ofSeq elements) [] - member internal m.Comparer = comparer + member internal m.Comparer = LanguagePrimitives.FastGenericComparer //[] member internal m.Tree = tree @@ -608,10 +679,10 @@ type Map<[]'Key, [(comparer, MapTree.add comparer key value tree) + new Map<'Key, 'Value>(MapTree.add key value tree) member m.Change(key, f) : Map<'Key, 'Value> = - new Map<'Key, 'Value>(comparer, MapTree.change comparer key f tree) + new Map<'Key, 'Value>(MapTree.change key f tree) [] member m.IsEmpty = MapTree.isEmpty tree @@ -623,7 +694,7 @@ type Map<[]'Key, []'Key, [(comparer, MapTree.filter comparer predicate tree) + new Map<'Key, 'Value>(MapTree.filter predicate tree) member m.ForAll predicate = MapTree.forall predicate tree @@ -641,20 +712,20 @@ type Map<[]'Key, ['Result) = - new Map<'Key, 'Result>(comparer, MapTree.map f tree) + new Map<'Key, 'Result>(MapTree.map f tree) member m.Map f = - new Map<'Key, 'b>(comparer, MapTree.mapi f tree) + new Map<'Key, 'b>(MapTree.mapi f tree) member m.Partition predicate : Map<'Key, 'Value> * Map<'Key, 'Value> = - let r1, r2 = MapTree.partition comparer predicate tree - new Map<'Key, 'Value>(comparer, r1), new Map<'Key, 'Value>(comparer, r2) + let r1, r2 = MapTree.partition predicate tree + new Map<'Key, 'Value>(r1), new Map<'Key, 'Value>(r2) member m.Count = MapTree.size tree @@ -665,13 +736,13 @@ type Map<[]'Key, [(comparer, MapTree.remove comparer key tree) + new Map<'Key, 'Value>(MapTree.remove key tree) member m.TryGetValue(key, [] value: byref<'Value>) = - MapTree.tryGetValue comparer key &value tree + MapTree.tryGetValue key &value tree member m.TryFind key = #if TRACE_SETS_AND_MAPS @@ -679,7 +750,7 @@ type Map<[]'Key, []'Key, [ = - let comparer = LanguagePrimitives.FastGenericComparer<'Key> - new Map<_, _>(comparer, MapTree.ofList comparer l) + Map<_, _>(MapTree.ofList l) member this.ComputeHashCode() = let combineHash x y = (x <<< 1) + y + 631 @@ -762,7 +832,7 @@ type Map<[]'Key, [ as m2-> Seq.compareWith (fun (kvp1 : KeyValuePair<_, _>) (kvp2 : KeyValuePair<_, _>)-> - let c = comparer.Compare(kvp1.Key, kvp2.Key) in + let c = MapTree.cmp kvp1.Key kvp2.Key in if c <> 0 then c else Unchecked.compare kvp1.Value kvp2.Value) m m2 | _ -> @@ -915,8 +985,7 @@ module Map = [] let ofArray (elements: ('Key * 'Value) array) = - let comparer = LanguagePrimitives.FastGenericComparer<'Key> - new Map<_, _>(comparer, MapTree.ofArray comparer elements) + Map<_, _>(MapTree.ofArray elements) [] let toList (table: Map<_, _>) = From 993ca9c543364c7b262ebf813b033cfb1692173e Mon Sep 17 00:00:00 2001 From: Victor Baybekov Date: Sat, 9 Jan 2021 21:51:04 +0100 Subject: [PATCH 08/15] Map: optimize comparer: add floats & IComparable support --- src/fsharp/FSharp.Core/map.fs | 68 +++++++++++++++++++++-------------- 1 file changed, 42 insertions(+), 26 deletions(-) diff --git a/src/fsharp/FSharp.Core/map.fs b/src/fsharp/FSharp.Core/map.fs index 049c63e9527..b8bcd2bc0fb 100644 --- a/src/fsharp/FSharp.Core/map.fs +++ b/src/fsharp/FSharp.Core/map.fs @@ -1,5 +1,4 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. -#nowarn "1182" namespace Microsoft.FSharp.Collections open System @@ -36,39 +35,42 @@ module MapTree = type CompareHelper<'T when 'T : comparison>() = static let c = LanguagePrimitives.FastGenericComparer - static member private IsIComparableFunc() = - - match box(Unchecked.defaultof<'T>) with - | :? IComparable<'T> -> true - | _ -> false - - static member private CompareC<'U when 'U :> IComparable<'U>>(l:'U, r:'U):int = l.CompareTo(r) - static member val Comparer: IComparer<'T> = c - - static member val CompareToDlg = + // A constrained call to IComparable<'T>.CompareTo + static member private CompareCG<'U when 'U :> IComparable<'U>>(l:'U, r:'U):int = l.CompareTo(r) + + // A call to IComparable.CompareTo + static member private CompareC<'U when 'U :> IComparable>(l:'U, r:'U):int = l.CompareTo(r) + + static member val CompareToDlg : Func<'T,'T,int> = let dlg = try - if CompareHelper<'T>.IsIComparableFunc() then + // See #816, IComparable<'T> actually does not satisfy comparison constraint, but it should be preferred + if typeof>.IsAssignableFrom(typeof<'T>) then + let m = + typeof>.GetMethod("CompareCG", BindingFlags.NonPublic ||| BindingFlags.Static) + .MakeGenericMethod([|typeof<'T>|]) + Delegate.CreateDelegate(typeof>, m) :?> Func<'T,'T,int> + elif typeof.IsAssignableFrom(typeof<'T>) then let m = typeof>.GetMethod("CompareC", BindingFlags.NonPublic ||| BindingFlags.Static) .MakeGenericMethod([|typeof<'T>|]) - let dlg = Delegate.CreateDelegate(typeof>, m) :?> Func<'T,'T,int> - dlg - else - null + Delegate.CreateDelegate(typeof>, m) :?> Func<'T,'T,int> + else null with _ -> null dlg with get - // If backed by static readonly field that will be JIT-time constant (must ensure beforefieldinit) + // If backed by static readonly field that will be JIT-time constant static member val IsIComparable = not(isNull CompareHelper<'T>.CompareToDlg) with get + [] static member Compare(l:'T, r:'T):int = - if CompareHelper<'T>.IsIComparable then - CompareHelper<'T>.CompareToDlg.Invoke(l,r) - else + // Should use IsIComparable when it's backed by static readonly field + if isNull CompareHelper<'T>.CompareToDlg then c.Compare(l, r) - + else + CompareHelper<'T>.CompareToDlg.Invoke(l,r) + // Constructors are not inlined by F#, but JIT could inline them. // This is what we need here, because LanguagePrimitives.FastGenericComparer.Compare // has a .tail prefix that breaks the typeof(T)==typeof(...) JIT optimization in cmp @@ -90,24 +92,38 @@ module MapTree = else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) - else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) - + else if Type.op_Equality(typeof<'T>, typeof) then if (# "clt" l r : bool #) then (-1) else (# "cgt" l r : int #) + else if Type.op_Equality(typeof<'T>, typeof) then if (# "clt" l r : bool #) then (-1) else (# "cgt" l r : int #) else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) - else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) - else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + // F# rules for floats + else if Type.op_Equality(typeof<'T>, typeof) then + if (# "clt" l r : bool #) then (-1) + elif (# "cgt" l r : bool #) then (1) + elif (# "ceq" l r : bool #) then (0) + elif (# "ceq" r r : bool #) then (-1) + else (# "ceq" l l : int #) + else if Type.op_Equality(typeof<'T>, typeof) then + if (# "clt" l r : bool #) then (-1) + elif (# "cgt" l r : bool #) then (1) + elif (# "ceq" l r : bool #) then (0) + elif (# "ceq" r r : bool #) then (-1) + else (# "ceq" l l : int #) else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) - else if Type.op_Equality(typeof<'T>, typeof) then Unchecked.compare (unbox(box(l))) (unbox(box(r))) + + else if Type.op_Equality(typeof<'T>, typeof) then + // same as in GenericComparisonFast + String.CompareOrdinal(unbox(box(l)),(unbox(box(r)))) else Comparison(l,r).Value From 64dc698749c587b5536606c3fe34d2ad6e6d3598 Mon Sep 17 00:00:00 2001 From: Victor Baybekov Date: Sat, 9 Jan 2021 22:34:20 +0100 Subject: [PATCH 09/15] Map: optimize comparer: replace embedded IL with verifiable operations --- src/fsharp/FSharp.Core/map.fs | 32 ++++++++++++++++++++------------ 1 file changed, 20 insertions(+), 12 deletions(-) diff --git a/src/fsharp/FSharp.Core/map.fs b/src/fsharp/FSharp.Core/map.fs index b8bcd2bc0fb..202b747d877 100644 --- a/src/fsharp/FSharp.Core/map.fs +++ b/src/fsharp/FSharp.Core/map.fs @@ -96,24 +96,32 @@ module MapTree = else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) - else if Type.op_Equality(typeof<'T>, typeof) then if (# "clt" l r : bool #) then (-1) else (# "cgt" l r : int #) - else if Type.op_Equality(typeof<'T>, typeof) then if (# "clt" l r : bool #) then (-1) else (# "cgt" l r : int #) + else if Type.op_Equality(typeof<'T>, typeof) then + unbox(box(l)).ToInt64().CompareTo( (unbox(box(r))).ToInt64()) + else if Type.op_Equality(typeof<'T>, typeof) then + unbox(box(l)).ToUInt64().CompareTo( (unbox(box(r))).ToUInt64()) else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) // F# rules for floats else if Type.op_Equality(typeof<'T>, typeof) then - if (# "clt" l r : bool #) then (-1) - elif (# "cgt" l r : bool #) then (1) - elif (# "ceq" l r : bool #) then (0) - elif (# "ceq" r r : bool #) then (-1) - else (# "ceq" l l : int #) + let l = unbox(box(l)) + let r = unbox(box(r)) + if l < r then (-1) + elif l > r then (1) + elif l = r then (0) + elif r = r then (-1) + elif l = l then (1) + else 0 else if Type.op_Equality(typeof<'T>, typeof) then - if (# "clt" l r : bool #) then (-1) - elif (# "cgt" l r : bool #) then (1) - elif (# "ceq" l r : bool #) then (0) - elif (# "ceq" r r : bool #) then (-1) - else (# "ceq" l l : int #) + let l = unbox(box(l)) + let r = unbox(box(r)) + if l < r then (-1) + elif l > r then (1) + elif l = r then (0) + elif r = r then (-1) + elif l = l then (1) + else 0 else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) From 2a21940e4d9ca31315063951cdd6f1c59709e1b3 Mon Sep 17 00:00:00 2001 From: Victor Baybekov Date: Sat, 9 Jan 2021 22:53:25 +0100 Subject: [PATCH 10/15] Map: optimize comparer: CI was fine without IComparable --- 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 202b747d877..102f711ff02 100644 --- a/src/fsharp/FSharp.Core/map.fs +++ b/src/fsharp/FSharp.Core/map.fs @@ -39,7 +39,7 @@ module MapTree = static member private CompareCG<'U when 'U :> IComparable<'U>>(l:'U, r:'U):int = l.CompareTo(r) // A call to IComparable.CompareTo - static member private CompareC<'U when 'U :> IComparable>(l:'U, r:'U):int = l.CompareTo(r) +// static member private CompareC<'U when 'U :> IComparable>(l:'U, r:'U):int = l.CompareTo(r) static member val CompareToDlg : Func<'T,'T,int> = let dlg = @@ -50,11 +50,11 @@ module MapTree = typeof>.GetMethod("CompareCG", BindingFlags.NonPublic ||| BindingFlags.Static) .MakeGenericMethod([|typeof<'T>|]) Delegate.CreateDelegate(typeof>, m) :?> Func<'T,'T,int> - elif typeof.IsAssignableFrom(typeof<'T>) then - let m = - typeof>.GetMethod("CompareC", BindingFlags.NonPublic ||| BindingFlags.Static) - .MakeGenericMethod([|typeof<'T>|]) - Delegate.CreateDelegate(typeof>, m) :?> Func<'T,'T,int> +// elif typeof.IsAssignableFrom(typeof<'T>) then +// let m = +// typeof>.GetMethod("CompareC", BindingFlags.NonPublic ||| BindingFlags.Static) +// .MakeGenericMethod([|typeof<'T>|]) +// Delegate.CreateDelegate(typeof>, m) :?> Func<'T,'T,int> else null with _ -> null dlg From e9e22b410eb767d07a5ef47bca76453dc3dc1c46 Mon Sep 17 00:00:00 2001 From: Victor Baybekov Date: Sun, 10 Jan 2021 00:49:26 +0100 Subject: [PATCH 11/15] Map: optimize comparer: limit types to optimize for IComparable Arrays and structural comparison may cause problems Maybe should just copy the snippet from #9348 --- src/fsharp/FSharp.Core/map.fs | 35 ++++++++++++++++++++++------------- 1 file changed, 22 insertions(+), 13 deletions(-) diff --git a/src/fsharp/FSharp.Core/map.fs b/src/fsharp/FSharp.Core/map.fs index 102f711ff02..872cf58bb48 100644 --- a/src/fsharp/FSharp.Core/map.fs +++ b/src/fsharp/FSharp.Core/map.fs @@ -2,6 +2,7 @@ namespace Microsoft.FSharp.Collections open System +open System.Collections open System.Collections.Generic open System.Diagnostics open System.Numerics @@ -39,22 +40,29 @@ module MapTree = static member private CompareCG<'U when 'U :> IComparable<'U>>(l:'U, r:'U):int = l.CompareTo(r) // A call to IComparable.CompareTo -// static member private CompareC<'U when 'U :> IComparable>(l:'U, r:'U):int = l.CompareTo(r) + static member private CompareC<'U when 'U :> IComparable>(l:'U, r:'U):int = l.CompareTo(r) static member val CompareToDlg : Func<'T,'T,int> = let dlg = - try - // See #816, IComparable<'T> actually does not satisfy comparison constraint, but it should be preferred - if typeof>.IsAssignableFrom(typeof<'T>) then - let m = - typeof>.GetMethod("CompareCG", BindingFlags.NonPublic ||| BindingFlags.Static) - .MakeGenericMethod([|typeof<'T>|]) - Delegate.CreateDelegate(typeof>, m) :?> Func<'T,'T,int> -// elif typeof.IsAssignableFrom(typeof<'T>) then -// let m = -// typeof>.GetMethod("CompareC", BindingFlags.NonPublic ||| BindingFlags.Static) -// .MakeGenericMethod([|typeof<'T>|]) -// Delegate.CreateDelegate(typeof>, m) :?> Func<'T,'T,int> + let ty = typeof<'T> + try + if not (typeof.IsAssignableFrom(ty)) + && isNull (Attribute.GetCustomAttribute(ty, typeof)) + && isNull (Attribute.GetCustomAttribute(ty, typeof)) + && not (ty.IsArray) then + + // See #816, IComparable<'T> actually does not satisfy comparison constraint, but it should be preferred + if typeof>.IsAssignableFrom(ty) then + let m = + typeof>.GetMethod("CompareCG", BindingFlags.NonPublic ||| BindingFlags.Static) + .MakeGenericMethod([|ty|]) + Delegate.CreateDelegate(typeof>, m) :?> Func<'T,'T,int> + elif typeof.IsAssignableFrom(ty) then + let m = + typeof>.GetMethod("CompareC", BindingFlags.NonPublic ||| BindingFlags.Static) + .MakeGenericMethod([|typeof<'T>|]) + Delegate.CreateDelegate(typeof>, m) :?> Func<'T,'T,int> + else null else null with _ -> null dlg @@ -128,6 +136,7 @@ module MapTree = else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) else if Type.op_Equality(typeof<'T>, typeof) then // same as in GenericComparisonFast From 5885b54e6fcc27e6e81a7b6bfc39961586e5c0d2 Mon Sep 17 00:00:00 2001 From: Victor Baybekov Date: Sun, 10 Jan 2021 01:04:03 +0100 Subject: [PATCH 12/15] Map: optimize comparer: IComparable should always be used when available It's unambiguous. If it does something different than other ways to compare then it's very weird. F# records implement IComparable that works as expected. --- src/fsharp/FSharp.Core/map.fs | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/src/fsharp/FSharp.Core/map.fs b/src/fsharp/FSharp.Core/map.fs index 872cf58bb48..1b8f9ec073e 100644 --- a/src/fsharp/FSharp.Core/map.fs +++ b/src/fsharp/FSharp.Core/map.fs @@ -46,23 +46,23 @@ module MapTree = let dlg = let ty = typeof<'T> try - if not (typeof.IsAssignableFrom(ty)) - && isNull (Attribute.GetCustomAttribute(ty, typeof)) - && isNull (Attribute.GetCustomAttribute(ty, typeof)) - && not (ty.IsArray) then - - // See #816, IComparable<'T> actually does not satisfy comparison constraint, but it should be preferred - if typeof>.IsAssignableFrom(ty) then - let m = - typeof>.GetMethod("CompareCG", BindingFlags.NonPublic ||| BindingFlags.Static) - .MakeGenericMethod([|ty|]) - Delegate.CreateDelegate(typeof>, m) :?> Func<'T,'T,int> - elif typeof.IsAssignableFrom(ty) then - let m = - typeof>.GetMethod("CompareC", BindingFlags.NonPublic ||| BindingFlags.Static) - .MakeGenericMethod([|typeof<'T>|]) - Delegate.CreateDelegate(typeof>, m) :?> Func<'T,'T,int> - else null + let normalCmp = + not (typeof.IsAssignableFrom(ty)) + && isNull (Attribute.GetCustomAttribute(ty, typeof)) + && isNull (Attribute.GetCustomAttribute(ty, typeof)) + && not (ty.IsArray) + + // See #816, IComparable<'T> actually does not satisfy comparison constraint, but it should be preferred + if typeof>.IsAssignableFrom(ty) then + let m = + typeof>.GetMethod("CompareCG", BindingFlags.NonPublic ||| BindingFlags.Static) + .MakeGenericMethod([|ty|]) + Delegate.CreateDelegate(typeof>, m) :?> Func<'T,'T,int> + elif typeof.IsAssignableFrom(ty) && normalCmp then + let m = + typeof>.GetMethod("CompareC", BindingFlags.NonPublic ||| BindingFlags.Static) + .MakeGenericMethod([|typeof<'T>|]) + Delegate.CreateDelegate(typeof>, m) :?> Func<'T,'T,int> else null with _ -> null dlg From b09e5a230e4b42a7bac87090c3704d75913c0d7f Mon Sep 17 00:00:00 2001 From: Victor Baybekov Date: Sun, 10 Jan 2021 01:51:07 +0100 Subject: [PATCH 13/15] Map: optimize comparer: move default compare logic to a separate file to share later with Set --- src/fsharp/FSharp.Core/FSharp.Core.fsproj | 3 + src/fsharp/FSharp.Core/map.fs | 117 +-------------------- src/fsharp/FSharp.Core/mapsetcmp.fs | 122 ++++++++++++++++++++++ 3 files changed, 127 insertions(+), 115 deletions(-) create mode 100644 src/fsharp/FSharp.Core/mapsetcmp.fs diff --git a/src/fsharp/FSharp.Core/FSharp.Core.fsproj b/src/fsharp/FSharp.Core/FSharp.Core.fsproj index f7267fe0d84..305b1f30da2 100644 --- a/src/fsharp/FSharp.Core/FSharp.Core.fsproj +++ b/src/fsharp/FSharp.Core/FSharp.Core.fsproj @@ -108,6 +108,9 @@ Collections/array3.fs + + Collections/mapsetcmp.fs + Collections/map.fsi diff --git a/src/fsharp/FSharp.Core/map.fs b/src/fsharp/FSharp.Core/map.fs index 1b8f9ec073e..1345dcee9b8 100644 --- a/src/fsharp/FSharp.Core/map.fs +++ b/src/fsharp/FSharp.Core/map.fs @@ -2,11 +2,8 @@ namespace Microsoft.FSharp.Collections open System -open System.Collections open System.Collections.Generic open System.Diagnostics -open System.Numerics -open System.Reflection open System.Runtime.CompilerServices open System.Text open Microsoft.FSharp.Core @@ -30,120 +27,10 @@ type internal MapTreeNode<'Key, 'Value>(k:'Key, v:'Value, left:MapTree<'Key, 'Va [] module MapTree = + open MapSetDefaultComparison let empty = null - type CompareHelper<'T when 'T : comparison>() = - static let c = LanguagePrimitives.FastGenericComparer - - // A constrained call to IComparable<'T>.CompareTo - static member private CompareCG<'U when 'U :> IComparable<'U>>(l:'U, r:'U):int = l.CompareTo(r) - - // A call to IComparable.CompareTo - static member private CompareC<'U when 'U :> IComparable>(l:'U, r:'U):int = l.CompareTo(r) - - static member val CompareToDlg : Func<'T,'T,int> = - let dlg = - let ty = typeof<'T> - try - let normalCmp = - not (typeof.IsAssignableFrom(ty)) - && isNull (Attribute.GetCustomAttribute(ty, typeof)) - && isNull (Attribute.GetCustomAttribute(ty, typeof)) - && not (ty.IsArray) - - // See #816, IComparable<'T> actually does not satisfy comparison constraint, but it should be preferred - if typeof>.IsAssignableFrom(ty) then - let m = - typeof>.GetMethod("CompareCG", BindingFlags.NonPublic ||| BindingFlags.Static) - .MakeGenericMethod([|ty|]) - Delegate.CreateDelegate(typeof>, m) :?> Func<'T,'T,int> - elif typeof.IsAssignableFrom(ty) && normalCmp then - let m = - typeof>.GetMethod("CompareC", BindingFlags.NonPublic ||| BindingFlags.Static) - .MakeGenericMethod([|typeof<'T>|]) - Delegate.CreateDelegate(typeof>, m) :?> Func<'T,'T,int> - else null - with _ -> null - dlg - with get - - // If backed by static readonly field that will be JIT-time constant - static member val IsIComparable = not(isNull CompareHelper<'T>.CompareToDlg) with get - - [] - static member Compare(l:'T, r:'T):int = - // Should use IsIComparable when it's backed by static readonly field - if isNull CompareHelper<'T>.CompareToDlg then - c.Compare(l, r) - else - CompareHelper<'T>.CompareToDlg.Invoke(l,r) - - // Constructors are not inlined by F#, but JIT could inline them. - // This is what we need here, because LanguagePrimitives.FastGenericComparer.Compare - // has a .tail prefix that breaks the typeof(T)==typeof(...) JIT optimization in cmp - // A struct with a single int field should be lowered by JIT. - [] - [] - type Comparison<'T when 'T : comparison> = - struct - val Value: int - [] - new(l:'T,r:'T) = { Value = CompareHelper<'T>.Compare(l, r) } - end - - [] - let cmp<'T when 'T : comparison> (l:'T) (r:'T) : int = - // See the pattern explanation: https://github.com/dotnet/runtime/blob/4b8d10154c39b1f56424d4ba2068a3150d90d475/src/libraries/System.Private.CoreLib/src/System/Numerics/Vector_1.cs#L14 - // All types that implement IComparable<'T> and are accessible here without additional dependencies should be in the list - if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) - else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) - else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) - else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) - else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) - else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) - else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) - else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) - else if Type.op_Equality(typeof<'T>, typeof) then - unbox(box(l)).ToInt64().CompareTo( (unbox(box(r))).ToInt64()) - else if Type.op_Equality(typeof<'T>, typeof) then - unbox(box(l)).ToUInt64().CompareTo( (unbox(box(r))).ToUInt64()) - else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) - else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) - - // F# rules for floats - else if Type.op_Equality(typeof<'T>, typeof) then - let l = unbox(box(l)) - let r = unbox(box(r)) - if l < r then (-1) - elif l > r then (1) - elif l = r then (0) - elif r = r then (-1) - elif l = l then (1) - else 0 - else if Type.op_Equality(typeof<'T>, typeof) then - let l = unbox(box(l)) - let r = unbox(box(r)) - if l < r then (-1) - elif l > r then (1) - elif l = r then (0) - elif r = r then (-1) - elif l = l then (1) - else 0 - else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) - else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) - else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) - else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) - - else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) - else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) - - else if Type.op_Equality(typeof<'T>, typeof) then - // same as in GenericComparisonFast - String.CompareOrdinal(unbox(box(l)),(unbox(box(r)))) - - else Comparison(l,r).Value - let inline isEmpty (m:MapTree<'Key, 'Value>) = isNull m let inline private asNode(value:MapTree<'Key,'Value>) : MapTreeNode<'Key,'Value> = @@ -865,7 +752,7 @@ type Map<[]'Key, [ as m2-> Seq.compareWith (fun (kvp1 : KeyValuePair<_, _>) (kvp2 : KeyValuePair<_, _>)-> - let c = MapTree.cmp kvp1.Key kvp2.Key in + let c = MapSetDefaultComparison.cmp kvp1.Key kvp2.Key in if c <> 0 then c else Unchecked.compare kvp1.Value kvp2.Value) m m2 | _ -> diff --git a/src/fsharp/FSharp.Core/mapsetcmp.fs b/src/fsharp/FSharp.Core/mapsetcmp.fs new file mode 100644 index 00000000000..d05f73ab337 --- /dev/null +++ b/src/fsharp/FSharp.Core/mapsetcmp.fs @@ -0,0 +1,122 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. +namespace Microsoft.FSharp.Collections + +open System +open System.Collections +open System.Numerics +open System.Reflection +open System.Runtime.CompilerServices +open Microsoft.FSharp.Core +open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators + +module internal MapSetDefaultComparison = + type CompareHelper<'T when 'T : comparison>() = + static let c = LanguagePrimitives.FastGenericComparer + + // A constrained call to IComparable<'T>.CompareTo + static member private CompareCG<'U when 'U :> IComparable<'U>>(l:'U, r:'U):int = l.CompareTo(r) + + // A call to IComparable.CompareTo + static member private CompareC<'U when 'U :> IComparable>(l:'U, r:'U):int = l.CompareTo(r) + + static member val CompareToDlg : Func<'T,'T,int> = + let dlg = + let ty = typeof<'T> + try + let normalCmp = + not (typeof.IsAssignableFrom(ty)) + && isNull (Attribute.GetCustomAttribute(ty, typeof)) + && isNull (Attribute.GetCustomAttribute(ty, typeof)) + && not (ty.IsArray) + + // See #816, IComparable<'T> actually does not satisfy comparison constraint, but it should be preferred + if typeof>.IsAssignableFrom(ty) then + let m = + typeof>.GetMethod("CompareCG", BindingFlags.NonPublic ||| BindingFlags.Static) + .MakeGenericMethod([|ty|]) + Delegate.CreateDelegate(typeof>, m) :?> Func<'T,'T,int> + elif typeof.IsAssignableFrom(ty) && normalCmp then + let m = + typeof>.GetMethod("CompareC", BindingFlags.NonPublic ||| BindingFlags.Static) + .MakeGenericMethod([|typeof<'T>|]) + Delegate.CreateDelegate(typeof>, m) :?> Func<'T,'T,int> + else null + with _ -> null + dlg + with get + + // If backed by static readonly field that will be JIT-time constant + static member val IsIComparable = not(isNull CompareHelper<'T>.CompareToDlg) with get + + [] + static member Compare(l:'T, r:'T):int = + // Should use IsIComparable when it's backed by static readonly field + if isNull CompareHelper<'T>.CompareToDlg then + c.Compare(l, r) + else + CompareHelper<'T>.CompareToDlg.Invoke(l,r) + + // Constructors are not inlined by F#, but JIT could inline them. + // This is what we need here, because LanguagePrimitives.FastGenericComparer.Compare + // has a .tail prefix that breaks the typeof(T)==typeof(...) JIT optimization in cmp + // A struct with a single int field should be lowered by JIT. + [] + [] + type Comparison<'T when 'T : comparison> = + struct + val Value: int + [] + new(l:'T,r:'T) = { Value = CompareHelper<'T>.Compare(l, r) } + end + + [] + let cmp<'T when 'T : comparison> (l:'T) (r:'T) : int = + // See the pattern explanation: https://github.com/dotnet/runtime/blob/4b8d10154c39b1f56424d4ba2068a3150d90d475/src/libraries/System.Private.CoreLib/src/System/Numerics/Vector_1.cs#L14 + // All types that implement IComparable<'T> and are accessible here without additional dependencies should be in the list + if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + else if Type.op_Equality(typeof<'T>, typeof) then + unbox(box(l)).ToInt64().CompareTo( (unbox(box(r))).ToInt64()) + else if Type.op_Equality(typeof<'T>, typeof) then + unbox(box(l)).ToUInt64().CompareTo( (unbox(box(r))).ToUInt64()) + else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + + // F# rules for floats + else if Type.op_Equality(typeof<'T>, typeof) then + let l = unbox(box(l)) + let r = unbox(box(r)) + if l < r then (-1) + elif l > r then (1) + elif l = r then (0) + elif r = r then (-1) + elif l = l then (1) + else 0 + else if Type.op_Equality(typeof<'T>, typeof) then + let l = unbox(box(l)) + let r = unbox(box(r)) + if l < r then (-1) + elif l > r then (1) + elif l = r then (0) + elif r = r then (-1) + elif l = l then (1) + else 0 + else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + + else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + else if Type.op_Equality(typeof<'T>, typeof) then unbox(box(l)).CompareTo(unbox(box(r))) + + else if Type.op_Equality(typeof<'T>, typeof) then + // same as in GenericComparisonFast + String.CompareOrdinal(unbox(box(l)),(unbox(box(r)))) + + else Comparison(l,r).Value \ No newline at end of file From 3386a333a50435d5e137bf132731e52b48fe1032 Mon Sep 17 00:00:00 2001 From: Victor Baybekov Date: Sun, 10 Jan 2021 03:01:53 +0100 Subject: [PATCH 14/15] Set: optimize comparer Same as #10855 --- src/fsharp/FSharp.Core/set.fs | 226 ++++++++++++++++------------------ 1 file changed, 109 insertions(+), 117 deletions(-) diff --git a/src/fsharp/FSharp.Core/set.fs b/src/fsharp/FSharp.Core/set.fs index 29f6af81673..26e17ba9845 100644 --- a/src/fsharp/FSharp.Core/set.fs +++ b/src/fsharp/FSharp.Core/set.fs @@ -31,6 +31,7 @@ type internal SetTreeNode<'T>(v:'T, left:SetTree<'T>, right: SetTree<'T>, h: int [] module internal SetTree = + open MapSetDefaultComparison let empty = null @@ -139,10 +140,10 @@ module internal SetTree = mk t1'.Left t1'.Key (mk t1'.Right v t2) else mk t1 v t2 - let rec add (comparer: IComparer<'T>) k (t:SetTree<'T>) : SetTree<'T> = + let rec add k (t:SetTree<'T>) : SetTree<'T> = if isEmpty t then SetTree k else - let c = comparer.Compare(k, t.Key) + let c = cmp k t.Key if t.Height = 1 then // nb. no check for rebalance needed for small trees, also be sure to reuse node already allocated if c < 0 then SetTreeNode (k, empty, t, 2) :> SetTree<'T> @@ -150,21 +151,21 @@ module internal SetTree = else SetTreeNode (k, t, empty, 2) :> SetTree<'T> else let tn = asNode t - if c < 0 then rebalance (add comparer k tn.Left) tn.Key tn.Right + if c < 0 then rebalance (add k tn.Left) tn.Key tn.Right elif c = 0 then t - else rebalance tn.Left tn.Key (add comparer k tn.Right) + else rebalance tn.Left tn.Key (add k tn.Right) - let rec balance comparer (t1:SetTree<'T>) k (t2:SetTree<'T>) = + let rec balance (t1:SetTree<'T>) k (t2:SetTree<'T>) = // 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" - if isEmpty t1 then add comparer k t2 // drop t1 = empty - elif isEmpty t2 then add comparer k t1 // drop t2 = empty + if isEmpty t1 then add k t2 // drop t1 = empty + elif isEmpty t2 then add k t1 // drop t2 = empty else - if t1.Height = 1 then add comparer k (add comparer t1.Key t2) + if t1.Height = 1 then add k (add t1.Key t2) else let t1n = asNode t1 - if t2.Height = 1 then add comparer k (add comparer t2.Key t1) + if t2.Height = 1 then add k (add t2.Key t1) else let t2n = asNode t2 // Have: (t1l < k1 < t1r) < k < (t2l < k2 < t2r) @@ -174,36 +175,36 @@ module internal SetTree = if t1n.Height + tolerance < t2n.Height 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 t2n.Left) t2n.Key t2n.Right + rebalance (balance t1 k t2n.Left) t2n.Key t2n.Right elif t2n.Height + tolerance < t1n.Height then // case: c, h2 too small // push t2 into high side of t1, may increase height by 1 so rebalance - rebalance t1n.Left t1n.Key (balance comparer t1n.Right k t2) + rebalance t1n.Left t1n.Key (balance t1n.Right k t2) else // case: a, h1 and h2 meet balance requirement mk t1 k t2 - let rec split (comparer: IComparer<'T>) pivot (t:SetTree<'T>) = + let rec split pivot (t:SetTree<'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 } if isEmpty t then empty, false, empty else if t.Height = 1 then - let c = comparer.Compare(t.Key, pivot) + let c = cmp t.Key pivot if c < 0 then t, false, empty // singleton under pivot elif c = 0 then empty, true, empty // singleton is pivot else empty, false, t // singleton over pivot else let tn = asNode t - let c = comparer.Compare(pivot, tn.Key) + let c = cmp pivot tn.Key if c < 0 then // pivot t1 - let t11Lo, havePivot, t11Hi = split comparer pivot tn.Left - t11Lo, havePivot, balance comparer t11Hi tn.Key tn.Right + let t11Lo, havePivot, t11Hi = split pivot tn.Left + t11Lo, havePivot, balance t11Hi tn.Key tn.Right elif c = 0 then // pivot is k1 tn.Left, true, tn.Right else // pivot t2 - let t12Lo, havePivot, t12Hi = split comparer pivot tn.Right - balance comparer tn.Left tn.Key t12Lo, havePivot, t12Hi + let t12Lo, havePivot, t12Hi = split pivot tn.Right + balance tn.Left tn.Key t12Lo, havePivot, t12Hi let rec spliceOutSuccessor (t:SetTree<'T>) = if isEmpty t then failwith "internal error: Set.spliceOutSuccessor" @@ -214,33 +215,33 @@ module internal SetTree = if isEmpty tn.Left then tn.Key, tn.Right else let k3, l' = spliceOutSuccessor tn.Left in k3, mk l' tn.Key tn.Right - let rec remove (comparer: IComparer<'T>) k (t:SetTree<'T>) = + let rec remove k (t:SetTree<'T>) = if isEmpty t then t else - let c = comparer.Compare(k, t.Key) + let c = cmp k t.Key if t.Height = 1 then if c = 0 then empty else t else let tn = asNode t - if c < 0 then rebalance (remove comparer k tn.Left) tn.Key tn.Right + if c < 0 then rebalance (remove k tn.Left) tn.Key tn.Right elif c = 0 then if isEmpty tn.Left then tn.Right elif isEmpty tn.Right then tn.Left else let sk, r' = spliceOutSuccessor tn.Right mk tn.Left sk r' - else rebalance tn.Left tn.Key (remove comparer k tn.Right) + else rebalance tn.Left tn.Key (remove k tn.Right) - let rec mem (comparer: IComparer<'T>) k (t:SetTree<'T>) = + let rec mem k (t:SetTree<'T>) = if isEmpty t then false else - let c = comparer.Compare(k, t.Key) + let c = cmp k t.Key if t.Height = 1 then (c = 0) else let tn = asNode t - if c < 0 then mem comparer k tn.Left + if c < 0 then mem k tn.Left elif c = 0 then true - else mem comparer k tn.Right + else mem k tn.Right let rec iter f (t:SetTree<'T>) = if isEmpty t then () @@ -288,44 +289,44 @@ module internal SetTree = let tn = asNode t f tn.Key || exists f tn.Left || exists f tn.Right - let subset comparer a b = - forall (fun x -> mem comparer x b) a + let subset a b = + forall (fun x -> mem x b) a - let properSubset comparer a b = - forall (fun x -> mem comparer x b) a && exists (fun x -> not (mem comparer x a)) b + let properSubset a b = + forall (fun x -> mem x b) a && exists (fun x -> not (mem x a)) b - let rec filterAux comparer f (t:SetTree<'T>) acc = + let rec filterAux f (t:SetTree<'T>) acc = if isEmpty t then acc else if t.Height = 1 then - if f t.Key then add comparer t.Key acc else acc + if f t.Key then add t.Key acc else acc else let tn = asNode t - let acc = if f tn.Key then add comparer tn.Key acc else acc - filterAux comparer f tn.Left (filterAux comparer f tn.Right acc) + let acc = if f tn.Key then add tn.Key acc else acc + filterAux f tn.Left (filterAux f tn.Right acc) - let filter comparer f s = filterAux comparer f s empty + let filter f s = filterAux f s empty - let rec diffAux comparer (t:SetTree<'T>) acc = + let rec diffAux (t:SetTree<'T>) acc = if isEmpty acc then acc else if isEmpty t then acc else - if t.Height = 1 then remove comparer t.Key acc + if t.Height = 1 then remove t.Key acc else let tn = asNode t - diffAux comparer tn.Left (diffAux comparer tn.Right (remove comparer tn.Key acc)) + diffAux tn.Left (diffAux tn.Right (remove tn.Key acc)) - let diff comparer a b = diffAux comparer b a + let diff a b = diffAux b a - let rec union comparer (t1:SetTree<'T>) (t2:SetTree<'T>) = + let rec union (t1:SetTree<'T>) (t2:SetTree<'T>) = // Perf: tried bruteForce for low heights, but nothing significant if isEmpty t1 then t2 elif isEmpty t2 then t1 else - if t1.Height = 1 then add comparer t1.Key t2 + if t1.Height = 1 then add t1.Key t2 else - if t2.Height = 1 then add comparer t2.Key t1 + if t2.Height = 1 then add t2.Key t1 else let t1n = asNode t1 let t2n = asNode t2 // (t1l < k < t1r) AND (t2l < k2 < t2r) @@ -334,38 +335,38 @@ module internal SetTree = // Split t2 using pivot k1 into lo and hi. // Union disjoint subproblems and then combine. if t1n.Height > t2n.Height then - let lo, _, hi = split comparer t1n.Key t2 in - balance comparer (union comparer t1n.Left lo) t1n.Key (union comparer t1n.Right hi) + let lo, _, hi = split t1n.Key t2 in + balance (union t1n.Left lo) t1n.Key (union t1n.Right hi) else - let lo, _, hi = split comparer t2n.Key t1 in - balance comparer (union comparer t2n.Left lo) t2n.Key (union comparer t2n.Right hi) + let lo, _, hi = split t2n.Key t1 in + balance (union t2n.Left lo) t2n.Key (union t2n.Right hi) - let rec intersectionAux comparer b (t:SetTree<'T>) acc = + let rec intersectionAux b (t:SetTree<'T>) acc = if isEmpty t then acc else if t.Height = 1 then - if mem comparer t.Key b then add comparer t.Key acc else acc + if mem t.Key b then add t.Key acc else acc else let tn = asNode t - let acc = intersectionAux comparer b tn.Right acc - let acc = if mem comparer tn.Key b then add comparer tn.Key acc else acc - intersectionAux comparer b tn.Left acc + let acc = intersectionAux b tn.Right acc + let acc = if mem tn.Key b then add tn.Key acc else acc + intersectionAux b tn.Left acc - let intersection comparer a b = intersectionAux comparer b a empty + let intersection a b = intersectionAux 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 partition1 f k (acc1, acc2) = if f k then (add k acc1, acc2) else (acc1, add k acc2) - let rec partitionAux comparer f (t:SetTree<'T>) acc = + let rec partitionAux f (t:SetTree<'T>) acc = if isEmpty t then acc else - if t.Height = 1 then partition1 comparer f t.Key acc + if t.Height = 1 then partition1 f t.Key acc else let tn = asNode t - let acc = partitionAux comparer f tn.Right acc - let acc = partition1 comparer f tn.Key acc - partitionAux comparer f tn.Left acc + let acc = partitionAux f tn.Right acc + let acc = partition1 f tn.Key acc + partitionAux f tn.Left acc - let partition comparer f s = partitionAux comparer f s (empty, empty) + let partition f s = partitionAux f s (empty, empty) let rec minimumElementAux (t:SetTree<'T>) n = if isEmpty t then n @@ -473,21 +474,21 @@ module internal SetTree = member _.Dispose() = () } /// Set comparison. Note this can be expensive. - let rec compareStacks (comparer: IComparer<'T>) (l1:SetTree<'T> list) (l2:SetTree<'T> list) : int = + let rec compareStacks (l1:SetTree<'T> list) (l2:SetTree<'T> list) : int = let cont() = match l1, l2 with | (x1 :: t1), _ when not (isEmpty x1) -> if x1.Height = 1 then - compareStacks comparer (empty :: SetTree x1.Key :: t1) l2 + compareStacks (empty :: SetTree x1.Key :: t1) l2 else let x1n = asNode x1 - compareStacks comparer (x1n.Left :: (SetTreeNode (x1n.Key, empty, x1n.Right, 0) :> SetTree<'T>) :: t1) l2 + compareStacks (x1n.Left :: (SetTreeNode (x1n.Key, empty, x1n.Right, 0) :> SetTree<'T>) :: t1) l2 | _, (x2 :: t2) when not (isEmpty x2) -> if x2.Height = 1 then - compareStacks comparer l1 (empty :: SetTree x2.Key :: t2) + compareStacks l1 (empty :: SetTree x2.Key :: t2) else let x2n = asNode x2 - compareStacks comparer l1 (x2n.Left :: (SetTreeNode (x2n.Key, empty, x2n.Right, 0) :> SetTree<'T> ) :: t2) + compareStacks l1 (x2n.Left :: (SetTreeNode (x2n.Key, empty, x2n.Right, 0) :> SetTree<'T> ) :: t2) | _ -> unexpectedstateInSetTreeCompareStacks() match l1, l2 with @@ -496,41 +497,41 @@ module internal SetTree = | _, [] -> 1 | (x1 :: t1), (x2 :: t2) -> if isEmpty x1 then - if isEmpty x2 then compareStacks comparer t1 t2 + if isEmpty x2 then compareStacks t1 t2 else cont() elif isEmpty x2 then cont() else if x1.Height = 1 then if x2.Height = 1 then - let c = comparer.Compare(x1.Key, x2.Key) - if c <> 0 then c else compareStacks comparer t1 t2 + let c = cmp x1.Key x2.Key + if c <> 0 then c else compareStacks t1 t2 else let x2n = asNode x2 if isEmpty x2n.Left then - let c = comparer.Compare(x1.Key, x2n.Key) - if c <> 0 then c else compareStacks comparer (empty :: t1) (x2n.Right :: t2) + let c = cmp x1.Key x2n.Key + if c <> 0 then c else compareStacks (empty :: t1) (x2n.Right :: t2) else cont() else let x1n = asNode x1 if isEmpty x1n.Left then if x2.Height = 1 then - let c = comparer.Compare(x1n.Key, x2.Key) - if c <> 0 then c else compareStacks comparer (x1n.Right :: t1) (empty :: t2) + let c = cmp x1n.Key x2.Key + if c <> 0 then c else compareStacks (x1n.Right :: t1) (empty :: t2) else let x2n = asNode x2 if isEmpty x2n.Left then - let c = comparer.Compare(x1n.Key, x2n.Key) - if c <> 0 then c else compareStacks comparer (x1n.Right :: t1) (x2n.Right :: t2) + let c = cmp x1n.Key x2n.Key + if c <> 0 then c else compareStacks (x1n.Right :: t1) (x2n.Right :: t2) else cont() else cont() - let compare comparer (t1:SetTree<'T>) (t2:SetTree<'T>) = + let compare (t1:SetTree<'T>) (t2:SetTree<'T>) = if isEmpty t1 then if isEmpty t2 then 0 else -1 else if isEmpty t2 then 1 - else compareStacks comparer [t1] [t2] + else compareStacks [t1] [t2] let choose s = minimumElement s @@ -555,28 +556,24 @@ module internal SetTree = copyToArray s res 0 res - let rec mkFromEnumerator comparer acc (e: IEnumerator<_>) = + let rec mkFromEnumerator acc (e: IEnumerator<_>) = if e.MoveNext() then - mkFromEnumerator comparer (add comparer e.Current acc) e + mkFromEnumerator (add e.Current acc) e else acc - let ofSeq comparer (c: IEnumerable<_>) = + let ofSeq (c: IEnumerable<_>) = use ie = c.GetEnumerator() - mkFromEnumerator comparer empty ie + mkFromEnumerator empty ie - let ofArray comparer l = - Array.fold (fun acc k -> add comparer k acc) empty l + let ofArray l = + Array.fold (fun acc k -> add k acc) empty l [] [] [>)>] [] [] -type Set<[]'T when 'T: comparison >(comparer:IComparer<'T>, tree: SetTree<'T>) = - - [] - // NOTE: This type is logically immutable. This field is only mutated during deserialization. - let mutable comparer = comparer +type Set<[]'T when 'T: comparison >(tree: SetTree<'T>) = [] // NOTE: This type is logically immutable. This field is only mutated during deserialization. @@ -591,8 +588,7 @@ type Set<[]'T when 'T: comparison >(comparer:IComparer<'T // set (it is just a lookup into a .NET table of type-instantiation-indexed static fields). static let empty: Set<'T> = - let comparer = LanguagePrimitives.FastGenericComparer<'T> - Set<'T>(comparer, SetTree.empty) + Set<'T>(SetTree.empty:SetTree<'T>) [] member _.OnSerializing(context: System.Runtime.Serialization.StreamingContext) = @@ -607,12 +603,11 @@ type Set<[]'T when 'T: comparison >(comparer:IComparer<'T [] member _.OnDeserialized(context: System.Runtime.Serialization.StreamingContext) = ignore context - comparer <- LanguagePrimitives.FastGenericComparer<'T> - tree <- SetTree.ofArray comparer serializedData + tree <- SetTree.ofArray serializedData serializedData <- null [] - member internal set.Comparer = comparer + member internal set.Comparer = LanguagePrimitives.FastGenericComparer member internal set.Tree: SetTree<'T> = tree @@ -625,14 +620,14 @@ type Set<[]'T when 'T: comparison >(comparer:IComparer<'T SetTree.numAdds <- SetTree.numAdds + 1 SetTree.totalSizeOnSetAdd <- SetTree.totalSizeOnSetAdd + float (SetTree.count s.Tree) #endif - Set<'T>(s.Comparer, SetTree.add s.Comparer value s.Tree ) + Set<'T>(SetTree.add value s.Tree) member s.Remove value: Set<'T> = #if TRACE_SETS_AND_MAPS SetTree.report() SetTree.numRemoves <- SetTree.numRemoves + 1 #endif - Set<'T>(s.Comparer, SetTree.remove s.Comparer value s.Tree) + Set<'T>(SetTree.remove value s.Tree) member s.Count = SetTree.count s.Tree @@ -643,7 +638,7 @@ type Set<[]'T when 'T: comparison >(comparer:IComparer<'T SetTree.numLookups <- SetTree.numLookups + 1 SetTree.totalSizeOnSetLookup <- SetTree.totalSizeOnSetLookup + float (SetTree.count s.Tree) #endif - SetTree.mem s.Comparer value s.Tree + SetTree.mem value s.Tree member s.Iterate x = SetTree.iter x s.Tree @@ -659,16 +654,15 @@ type Set<[]'T when 'T: comparison >(comparer:IComparer<'T member s.Partition f : Set<'T> * Set<'T> = if SetTree.isEmpty s.Tree then s,s else - let t1, t2 = SetTree.partition s.Comparer f s.Tree in Set(s.Comparer, t1), Set(s.Comparer, t2) + let t1, t2 = SetTree.partition f s.Tree in Set(t1), Set(t2) member s.Filter f : Set<'T> = if SetTree.isEmpty s.Tree then s else - Set(s.Comparer, SetTree.filter s.Comparer f s.Tree) + Set(SetTree.filter 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.empty) s.Tree) + Set(SetTree.fold (fun acc k -> SetTree.add (f k) acc) (SetTree.empty) s.Tree) member s.Exists f = SetTree.exists f s.Tree @@ -681,7 +675,7 @@ type Set<[]'T when 'T: comparison >(comparer:IComparer<'T if SetTree.isEmpty set1.Tree then set1 (* 0 - B = 0 *) else if SetTree.isEmpty set2.Tree then set1 (* A - 0 = A *) - else Set(set1.Comparer, SetTree.diff set1.Comparer set1.Tree set2.Tree) + else Set(SetTree.diff set1.Tree set2.Tree) [] static member (+) (set1: Set<'T>, set2: Set<'T>) = @@ -692,13 +686,13 @@ type Set<[]'T when 'T: comparison >(comparer:IComparer<'T if SetTree.isEmpty set2.Tree then set1 (* A U 0 = A *) else if SetTree.isEmpty set1.Tree then set2 (* 0 U B = B *) - else Set(set1.Comparer, SetTree.union set1.Comparer set1.Tree set2.Tree) + else Set(SetTree.union set1.Tree set2.Tree) static member Intersection(a: Set<'T>, b: Set<'T>) : Set<'T> = if SetTree.isEmpty b.Tree then b (* A INTER 0 = 0 *) else if SetTree.isEmpty a.Tree then a (* 0 INTER B = 0 *) - else Set(a.Comparer, SetTree.intersection a.Comparer a.Tree b.Tree) + else Set(SetTree.intersection a.Tree b.Tree) static member Union(sets:seq>) : Set<'T> = Seq.fold (fun s1 s2 -> s1 + s2) Set<'T>.Empty sets @@ -707,10 +701,10 @@ type Set<[]'T when 'T: comparison >(comparer:IComparer<'T Seq.reduce (fun s1 s2 -> Set.Intersection(s1, s2)) sets static member Equality(a: Set<'T>, b: Set<'T>) = - (SetTree.compare a.Comparer a.Tree b.Tree = 0) + (SetTree.compare a.Tree b.Tree = 0) static member Compare(a: Set<'T>, b: Set<'T>) = - SetTree.compare a.Comparer a.Tree b.Tree + SetTree.compare a.Tree b.Tree [] member x.Choose = SetTree.choose x.Tree @@ -722,16 +716,16 @@ type Set<[]'T when 'T: comparison >(comparer:IComparer<'T member x.MaximumElement = SetTree.maximumElement x.Tree member x.IsSubsetOf(otherSet: Set<'T>) = - SetTree.subset x.Comparer x.Tree otherSet.Tree + SetTree.subset x.Tree otherSet.Tree member x.IsSupersetOf(otherSet: Set<'T>) = - SetTree.subset x.Comparer otherSet.Tree x.Tree + SetTree.subset otherSet.Tree x.Tree member x.IsProperSubsetOf(otherSet: Set<'T>) = - SetTree.properSubset x.Comparer x.Tree otherSet.Tree + SetTree.properSubset x.Tree otherSet.Tree member x.IsProperSupersetOf(otherSet: Set<'T>) = - SetTree.properSubset x.Comparer otherSet.Tree x.Tree + SetTree.properSubset otherSet.Tree x.Tree member x.ToList () = SetTree.toList x.Tree @@ -759,7 +753,7 @@ type Set<[]'T when 'T: comparison >(comparer:IComparer<'T | _ -> false interface System.IComparable with - member this.CompareTo(that: obj) = SetTree.compare this.Comparer this.Tree ((that :?> Set<'T>).Tree) + member this.CompareTo(that: obj) = SetTree.compare this.Tree ((that :?> Set<'T>).Tree) interface ICollection<'T> with member s.Add x = ignore x; raise (new System.NotSupportedException("ReadOnlyCollection")) @@ -768,7 +762,7 @@ type Set<[]'T when 'T: comparison >(comparer:IComparer<'T member s.Remove x = ignore x; raise (new System.NotSupportedException("ReadOnlyCollection")) - member s.Contains x = SetTree.mem s.Comparer x s.Tree + member s.Contains x = SetTree.mem x s.Tree member s.CopyTo(arr, i) = SetTree.copyToArray s.Tree arr i @@ -788,14 +782,12 @@ type Set<[]'T when 'T: comparison >(comparer:IComparer<'T static member Singleton(x:'T) : Set<'T> = Set<'T>.Empty.Add x new (elements : seq<'T>) = - let comparer = LanguagePrimitives.FastGenericComparer<'T> - Set(comparer, SetTree.ofSeq comparer elements) + Set(SetTree.ofSeq elements) static member Create(elements : seq<'T>) = Set<'T>(elements) static member FromArray(arr : 'T array) : Set<'T> = - let comparer = LanguagePrimitives.FastGenericComparer<'T> - Set(comparer, SetTree.ofArray comparer arr) + Set(SetTree.ofArray arr) override x.ToString() = match List.ofSeq (Seq.truncate 4 x) with @@ -908,16 +900,16 @@ module Set = let difference (set1: Set<'T>) (set2: Set<'T>) = set1 - set2 [] - let isSubset (set1:Set<'T>) (set2: Set<'T>) = SetTree.subset set1.Comparer set1.Tree set2.Tree + let isSubset (set1:Set<'T>) (set2: Set<'T>) = SetTree.subset set1.Tree set2.Tree [] - let isSuperset (set1:Set<'T>) (set2: Set<'T>) = SetTree.subset set1.Comparer set2.Tree set1.Tree + let isSuperset (set1:Set<'T>) (set2: Set<'T>) = SetTree.subset set2.Tree set1.Tree [] - let isProperSubset (set1:Set<'T>) (set2: Set<'T>) = SetTree.properSubset set1.Comparer set1.Tree set2.Tree + let isProperSubset (set1:Set<'T>) (set2: Set<'T>) = SetTree.properSubset set1.Tree set2.Tree [] - let isProperSuperset (set1:Set<'T>) (set2: Set<'T>) = SetTree.properSubset set1.Comparer set2.Tree set1.Tree + let isProperSuperset (set1:Set<'T>) (set2: Set<'T>) = SetTree.properSubset set2.Tree set1.Tree [] let minElement (set: Set<'T>) = set.MinimumElement From 0900934739d8194c42b967f5cb46f7a759c89187 Mon Sep 17 00:00:00 2001 From: Victor Baybekov Date: Sun, 10 Jan 2021 12:08:49 +0100 Subject: [PATCH 15/15] Set: optimize comparer: Set.Compare returns only [-1,0,1] --- src/fsharp/FSharp.Core/set.fs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/fsharp/FSharp.Core/set.fs b/src/fsharp/FSharp.Core/set.fs index 26e17ba9845..7d1b85c1f89 100644 --- a/src/fsharp/FSharp.Core/set.fs +++ b/src/fsharp/FSharp.Core/set.fs @@ -531,7 +531,9 @@ module internal SetTree = else -1 else if isEmpty t2 then 1 - else compareStacks [t1] [t2] + else + let c = compareStacks [t1] [t2] + if c > 0 then 1 else if c = 0 then 0 else -1 let choose s = minimumElement s