Last active
January 28, 2018 12:26
-
-
Save mrange/7243047519ce081ba2e448ddbbc57b57 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#if STACK_VARIANT1 | |
module MutableStack = | |
type Stack<'T> (size :int ) = | |
class | |
let mutable vs : 'T [] = Array.zeroCreate size | |
let mutable last = -1 | |
member x.IsEmpty = last < 0 | |
member x.IsNotEmpty = last >= 0 | |
member x.Count = last + 1 | |
member x.Pop () : 'T = | |
let v = vs.[last] | |
last <- last - 1 | |
v | |
member x.Push (v: 'T) : unit = | |
let l = last + 1 | |
if l < vs.Length then | |
vs.[l] <- v | |
last <- l | |
else | |
System.Array.Resize (&vs, vs.Length <<< 1) | |
vs.[l] <- v | |
last <- l | |
end | |
module Stack = | |
let inline count (stack : Stack<'T>) : int = | |
stack.Count | |
let inline isEmpty (stack : Stack<'T>) : bool = | |
stack.IsEmpty | |
let inline isNotEmpty (stack : Stack<'T>) : bool = | |
stack.IsNotEmpty | |
let inline init (size : int) : Stack<'T> = | |
Stack size | |
let inline push (stack : Stack<'T>) v : unit = | |
stack.Push v | |
let inline pop (stack : Stack<'T>) : 'T = | |
stack.Pop () | |
#else | |
module MutableStack = | |
type Stack<'T> = System.Collections.Generic.Stack<'T> | |
module Stack = | |
let inline count (stack : Stack<'T>) : int = | |
stack.Count | |
let inline isEmpty (stack : Stack<'T>) : bool = | |
stack.Count = 0 | |
let inline isNotEmpty (stack : Stack<'T>) : bool = | |
stack.Count > 0 | |
let inline init (size : int) : Stack<'T> = | |
Stack size | |
let inline push (stack : Stack<'T>) v : unit = | |
stack.Push v | |
let inline pop (stack : Stack<'T>) : 'T = | |
stack.Pop () | |
#endif | |
module CT0 = | |
type [<RequireQualifiedAccess>] ConcatTree<'T> = | |
| Empty | |
| Leaf of 'T | |
| Fork of ConcatTree<'T>*ConcatTree<'T> | |
module ConcatTree = | |
module Details = | |
module Loops = | |
let rec fold (f : OptimizedClosures.FSharpFunc<_, _, _>) s t = | |
match t with | |
| ConcatTree.Empty -> | |
s | |
| ConcatTree.Leaf v -> | |
f.Invoke (s, v) | |
| ConcatTree.Fork (l, r) -> | |
let s = fold f s l | |
fold f s r | |
open Details | |
[<GeneralizableValue>] | |
let empty = ConcatTree.Empty | |
let inline leaf v = ConcatTree.Leaf v | |
let inline concat (l : ConcatTree<'T>) (r : ConcatTree<'T>) : ConcatTree<'T> = | |
match l, r with | |
| ConcatTree.Empty , _ -> r | |
| _ , ConcatTree.Empty -> l | |
| _ , _ -> ConcatTree.Fork (l, r) | |
let inline fold (f : 'S -> 'T -> 'S) (z : 'S) (t : ConcatTree<'T>) : 'S = | |
let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt f | |
Loops.fold f z t | |
let toArray (t : ConcatTree<'T>) : 'T [] = | |
let ra = ResizeArray 16 | |
fold (fun _ v -> ra.Add v) () t | |
ra.ToArray () | |
let toList (t : ConcatTree<'T>) : 'T list = | |
fold (fun s v -> v::s) [] t |> List.rev | |
let ofArray (vs : 'T []) : ConcatTree<'T> = | |
let rec loop b e = | |
if b = e then | |
empty | |
elif b + 1 = e then | |
leaf (vs.[b]) | |
else | |
let m = (b + e) / 2 | |
concat (loop b m) (loop m e) | |
loop 0 vs.Length | |
module Test = | |
type Properties = | |
static member ``ofArray/to*`` (vs : int []) = | |
let ea = vs | |
let aa = vs |> ConcatTree.ofArray |> ConcatTree.toArray | |
let el = vs |> Array.toList | |
let al = vs |> ConcatTree.ofArray |> ConcatTree.toList | |
ea = aa && el = al | |
open FsCheck | |
let run () = | |
let config = { Config.Quick with MaxTest = 1000; MaxRejected = 1000 } | |
Check.All<Properties> config | |
module CT1 = | |
type [<RequireQualifiedAccess>] ConcatTree<'T> = | |
| Empty | |
| Leaf of 'T | |
| Fork of ConcatTree<'T>*ConcatTree<'T> | |
module ConcatTree = | |
open MutableStack | |
module Details = | |
module Loops = | |
let rec fold (stack : Stack<_>) (f : OptimizedClosures.FSharpFunc<_, _, _>) s t = | |
match t with | |
| ConcatTree.Empty -> | |
if Stack.isNotEmpty stack then | |
fold stack f s (Stack.pop stack) | |
else | |
s | |
| ConcatTree.Leaf v -> | |
let s = f.Invoke (s, v) | |
if Stack.isNotEmpty stack then | |
fold stack f s (Stack.pop stack) | |
else | |
s | |
| ConcatTree.Fork (l, r) -> | |
Stack.push stack r | |
fold stack f s l | |
open Details | |
[<GeneralizableValue>] | |
let empty = ConcatTree.Empty | |
let inline leaf v = ConcatTree.Leaf v | |
let inline concat (l : ConcatTree<'T>) (r : ConcatTree<'T>) : ConcatTree<'T> = | |
match l, r with | |
| ConcatTree.Empty , _ -> r | |
| _ , ConcatTree.Empty -> l | |
| _ , _ -> ConcatTree.Fork (l, r) | |
let inline fold (f : 'S -> 'T -> 'S) (z : 'S) (t : ConcatTree<'T>) : 'S = | |
let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt f | |
Loops.fold (Stack 16) f z t | |
let toArray (t : ConcatTree<'T>) : 'T [] = | |
let ra = ResizeArray 16 | |
fold (fun _ v -> ra.Add v) () t | |
ra.ToArray () | |
let toList (t : ConcatTree<'T>) : 'T list = | |
fold (fun s v -> v::s) [] t |> List.rev | |
let ofArray (vs : 'T []) : ConcatTree<'T> = | |
let rec loop b e = | |
if b = e then | |
empty | |
elif b + 1 = e then | |
leaf (vs.[b]) | |
else | |
let m = (b + e) / 2 | |
concat (loop b m) (loop m e) | |
loop 0 vs.Length | |
module Test = | |
type Properties = | |
static member ``ofArray/to*`` (vs : int []) = | |
let ea = vs | |
let aa = vs |> ConcatTree.ofArray |> ConcatTree.toArray | |
let el = vs |> Array.toList | |
let al = vs |> ConcatTree.ofArray |> ConcatTree.toList | |
ea = aa && el = al | |
open FsCheck | |
let run () = | |
let config = { Config.Quick with MaxTest = 1000; MaxRejected = 1000 } | |
Check.All<Properties> config | |
module CT2 = | |
open MutableStack | |
type [<AbstractClass>] ConcatTree<'T> (isEmpty : bool) = | |
class | |
member x.IsEmpty = isEmpty | |
member x.Fold (f : 'S -> 'T -> 'S) (z : 'S) : 'S = | |
let stack = Stack<_> 16 | |
x.FoldImpl stack f z | |
abstract FoldImpl: Stack<ConcatTree<'T>> -> ('S -> 'T -> 'S) -> 'S -> 'S | |
end | |
module ConcatTree = | |
type [<Sealed>] Empty<'T> () = | |
class | |
inherit ConcatTree<'T> true | |
override x.FoldImpl stack f s = | |
if Stack.isNotEmpty stack then | |
let t = Stack.pop stack | |
t.FoldImpl stack f s | |
else | |
s | |
end | |
type [<Sealed>] Leaf<'T> (v : 'T) = | |
class | |
inherit ConcatTree<'T> false | |
override x.FoldImpl stack f s = | |
let s = f s v | |
if Stack.isNotEmpty stack then | |
let t = Stack.pop stack | |
t.FoldImpl stack f s | |
else | |
s | |
end | |
type [<Sealed>] Fork<'T> (l : ConcatTree<'T>, r : ConcatTree<'T>) = | |
class | |
inherit ConcatTree<'T> false | |
override x.FoldImpl stack f s = | |
Stack.push stack r | |
l.FoldImpl stack f s | |
end | |
[<GeneralizableValue>] | |
let empty<'T> : ConcatTree<'T> = upcast Empty<'T> () | |
let inline leaf v : ConcatTree<'T> = upcast Leaf v | |
let inline concat (l : ConcatTree<'T>) (r : ConcatTree<'T>) : ConcatTree<'T> = | |
if l.IsEmpty then | |
r | |
elif r.IsEmpty then | |
l | |
else | |
upcast Fork (l, r) | |
let inline fold (f : 'S -> 'T -> 'S) (z : 'S) (t : ConcatTree<'T>) : 'S = | |
t.Fold f z | |
let toArray (t : ConcatTree<'T>) : 'T [] = | |
let ra = ResizeArray 16 | |
fold (fun _ v -> ra.Add v) () t | |
ra.ToArray () | |
let toList (t : ConcatTree<'T>) : 'T list = | |
fold (fun s v -> v::s) [] t |> List.rev | |
let ofArray (vs : 'T []) : ConcatTree<'T> = | |
let rec loop b e = | |
if b = e then | |
empty | |
elif b + 1 = e then | |
leaf (vs.[b]) | |
else | |
let m = (b + e) / 2 | |
concat (loop b m) (loop m e) | |
loop 0 vs.Length | |
module Test = | |
type Properties = | |
static member ``ofArray/to*`` (vs : int []) = | |
let ea = vs | |
let aa = vs |> ConcatTree.ofArray |> ConcatTree.toArray | |
let el = vs |> Array.toList | |
let al = vs |> ConcatTree.ofArray |> ConcatTree.toList | |
ea = aa && el = al | |
open FsCheck | |
let run () = | |
let config = { Config.Quick with MaxTest = 1000; MaxRejected = 1000 } | |
Check.All<Properties> config | |
module CT3 = | |
type [<AbstractClass>] ConcatTree<'T> (nodeType : int) = | |
class | |
member x.IsEmpty = nodeType = 0 | |
member x.IsLeaf = nodeType = 1 | |
member x.IsFork = nodeType = 2 | |
abstract LeafValue : 'T | |
abstract ForkValue : struct (ConcatTree<'T>*ConcatTree<'T>) | |
end | |
module ConcatTree = | |
type [<Sealed>] Empty<'T> () = | |
class | |
inherit ConcatTree<'T> 0 | |
override x.LeafValue = failwith "Not a leaf" | |
override x.ForkValue = failwith "Not a node" | |
end | |
type [<Sealed>] Leaf<'T> (v : 'T) = | |
class | |
inherit ConcatTree<'T> 1 | |
override x.LeafValue = v | |
override x.ForkValue = failwith "Not a node" | |
end | |
type [<Sealed>] Fork<'T> (l : ConcatTree<'T>, r : ConcatTree<'T>) = | |
class | |
inherit ConcatTree<'T> 2 | |
override x.LeafValue = failwith "Not a leaf" | |
override x.ForkValue = struct (l, r) | |
end | |
open MutableStack | |
module Details = | |
module Loops = | |
let rec fold (stack : Stack<_>) (f : OptimizedClosures.FSharpFunc<_, _, _>) s (t : ConcatTree<_>) = | |
if t.IsFork then | |
let struct (l, r) = t.ForkValue | |
Stack.push stack r | |
fold stack f s l | |
elif t.IsLeaf then | |
let s = f.Invoke (s, t.LeafValue) | |
if Stack.isNotEmpty stack then | |
fold stack f s (Stack.pop stack) | |
else | |
s | |
else | |
if Stack.isNotEmpty stack then | |
fold stack f s (Stack.pop stack) | |
else | |
s | |
open Details | |
[<GeneralizableValue>] | |
let empty<'T> : ConcatTree<'T> = upcast Empty<'T> () | |
let inline leaf v : ConcatTree<'T> = upcast Leaf v | |
let inline concat (l : ConcatTree<'T>) (r : ConcatTree<'T>) : ConcatTree<'T> = | |
if l.IsEmpty then | |
r | |
elif r.IsEmpty then | |
l | |
else | |
upcast Fork (l, r) | |
let inline fold (f : 'S -> 'T -> 'S) (z : 'S) (t : ConcatTree<'T>) : 'S = | |
let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt f | |
Loops.fold (Stack 16) f z t | |
let toArray (t : ConcatTree<'T>) : 'T [] = | |
let ra = ResizeArray 16 | |
fold (fun _ v -> ra.Add v) () t | |
ra.ToArray () | |
let toList (t : ConcatTree<'T>) : 'T list = | |
fold (fun s v -> v::s) [] t |> List.rev | |
let ofArray (vs : 'T []) : ConcatTree<'T> = | |
let rec loop b e = | |
if b = e then | |
empty | |
elif b + 1 = e then | |
leaf (vs.[b]) | |
else | |
let m = (b + e) / 2 | |
concat (loop b m) (loop m e) | |
loop 0 vs.Length | |
module Test = | |
type Properties = | |
static member ``ofArray/to*`` (vs : int []) = | |
let ea = vs | |
let aa = vs |> ConcatTree.ofArray |> ConcatTree.toArray | |
let el = vs |> Array.toList | |
let al = vs |> ConcatTree.ofArray |> ConcatTree.toList | |
ea = aa && el = al | |
open FsCheck | |
let run () = | |
let config = { Config.Quick with MaxTest = 1000; MaxRejected = 1000 } | |
Check.All<Properties> config | |
module PerformanceTests = | |
open FSharp.Core.Printf | |
open System | |
open System.Collections | |
open System.Diagnostics | |
open System.IO | |
open System.Text | |
// now () returns current time in milliseconds since start | |
let now : unit -> int64 = | |
let sw = System.Diagnostics.Stopwatch () | |
sw.Start () | |
fun () -> sw.ElapsedMilliseconds | |
// time estimates the time 'action' repeated a number of times | |
let time repeat action = | |
let inline cc i = System.GC.CollectionCount i | |
let v = action () | |
System.GC.Collect (2, System.GCCollectionMode.Forced, true) | |
let bcc0, bcc1, bcc2 = cc 0, cc 1, cc 2 | |
let b = now () | |
for i in 1..repeat do | |
action () |> ignore | |
let e = now () | |
let ecc0, ecc1, ecc2 = cc 0, cc 1, cc 2 | |
v, e - b, ecc0 - bcc0, ecc1 - bcc1, ecc2 - bcc2 | |
type [<Struct>] QueueState = QueueState of obj | |
type ValueType = int | |
let valueCreator (v : int) = int v | |
module CT0Run = | |
open CT0 | |
let run (vs : ValueType []) = | |
vs |> ConcatTree.ofArray |> ConcatTree.toArray |> ignore | |
module CT1Run = | |
open CT1 | |
let run (vs : ValueType []) = | |
vs |> ConcatTree.ofArray |> ConcatTree.toArray |> ignore | |
module CT2Run = | |
open CT2 | |
let run (vs : ValueType []) = | |
vs |> ConcatTree.ofArray |> ConcatTree.toArray |> ignore | |
module CT3Run = | |
open CT3 | |
let run (vs : ValueType []) = | |
vs |> ConcatTree.ofArray |> ConcatTree.toArray |> ignore | |
type TestResult = TestResult of string*string*string*int64*int*int*int | |
let testResult t y x tm cc0 cc1 cc2 = TestResult (t, y, x, tm, cc0, cc1, cc2) | |
let testClass (TestResult (t, _, _, _, _, _, _)) = t | |
let testY (TestResult (_, y, _, _, _, _, _)) = y | |
let testX (TestResult (_, _, x, _, _, _, _)) = x | |
let run () = | |
use log = System.IO.File.CreateText "log.txt" | |
let trace (l : string) = | |
log.WriteLine l | |
System.Console.WriteLine l | |
let tracef f = kprintf trace f | |
let total = 10000000 | |
let inners = [| 100; 10000; 1000000|] | |
let tests = | |
let maxSize = Int32.MaxValue | |
[| | |
"ct0" , maxSize, CT0Run.run | |
"ct1" , maxSize, CT1Run.run | |
"ct2" , 10000 , CT2Run.run | |
"ct3" , maxSize, CT3Run.run | |
|] | |
let results = ResizeArray 16 | |
for inner in inners do | |
let outer = total / inner | |
let vs = Array.init inner valueCreator | |
let testClass = "run" | |
let x = sprintf "%d" inner | |
for (name, maxSize, run) in tests do | |
if inner > maxSize then | |
tracef "Skipping - %s - total:%d (outer:%d - inner:%d) " name (outer*inner) outer inner | |
else | |
tracef "Running - %s - total:%d (outer:%d - inner:%d) " name (outer*inner) outer inner | |
let _, ms, cc0, cc1, cc2 = time outer (fun () -> run vs) | |
results.Add <| testResult testClass name x ms cc0 cc1 cc2 | |
tracef " the result is %d ms (%d, %d, %d) cc" ms cc0 cc1 cc2 | |
let results = results.ToArray () | |
let testClasses = results |> Array.groupBy testClass | |
for name, results in testClasses do | |
let testXs = results |> Array.groupBy testX |> Array.map fst | |
let testYs = results |> Array.groupBy testY | |
let header = "'Name" + (testXs |> Array.map (fun i -> ",'" + string i) |> Array.reduce (+)) | |
use perf = new StreamWriter ("perf_" + name + ".csv") | |
use cc = new StreamWriter ("cc_" + name + ".csv") | |
let line sw l = (sw : StreamWriter).WriteLine (l : string) | |
let linef sw f= kprintf (line sw) f | |
line perf header | |
line cc header | |
for name, result in testYs do | |
let write sb s = (sb : StringBuilder).Append (s : string) |> ignore | |
let field sb s = (sb : StringBuilder).Append ',' |> ignore; write sb s | |
let fieldf sb f = kprintf (field sb) f | |
let psb = StringBuilder 16 | |
let csb = StringBuilder 16 | |
write psb name | |
write csb name | |
let m = result |> Array.map (fun tc -> testX tc, tc) |> Map.ofArray | |
for testInner in testXs do | |
match m.TryFind testInner with | |
| None -> | |
field psb "" | |
field csb "" | |
| Some tr -> | |
let (TestResult (_, _, _, tm, cc0, cc1, cc2)) = tr | |
// TODO: Bah this doesn't work. Want to visualize as different dimensions | |
let cc = | |
if cc2 > 0 then | |
100000*cc2 | |
elif cc1 > 0 then | |
1000*cc1 | |
else | |
cc0 | |
fieldf psb "%d" tm | |
fieldf csb "%d" cc | |
line perf <| psb.ToString () | |
line cc <| csb.ToString () | |
[<EntryPoint>] | |
let main argv = | |
#if DEBUG | |
CT0.Test.run () | |
CT1.Test.run () | |
CT2.Test.run () | |
CT3.Test.run () | |
#else | |
PerformanceTests.run () | |
#endif | |
0 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment