From 0f62dd31c5c07e688e335768901d7c7aa92c50b0 Mon Sep 17 00:00:00 2001 From: Christian Luksch Date: Wed, 9 Oct 2024 11:20:22 +0200 Subject: [PATCH] using SortedSetExt value option methods cleanup FreeList --- .../Core/Utilities/Common.fs | 1 + .../Runtime/RenderTasks.fs | 12 +- src/Aardvark.Rendering.Vulkan/Core/Device.fs | 50 ++- src/Aardvark.Rendering/Utilities/Memory.fs | 83 ++-- src/Aardvark.Rendering/Utilities/Trie.fs | 30 +- src/Demo/Examples/Program.fs | 384 +----------------- 6 files changed, 110 insertions(+), 450 deletions(-) diff --git a/src/Aardvark.Rendering.GL/Core/Utilities/Common.fs b/src/Aardvark.Rendering.GL/Core/Utilities/Common.fs index 3e2046345..08ebdf380 100644 --- a/src/Aardvark.Rendering.GL/Core/Utilities/Common.fs +++ b/src/Aardvark.Rendering.GL/Core/Utilities/Common.fs @@ -170,6 +170,7 @@ module Driver = module MemoryManagementUtilities = open System.Collections.Generic + [] type FreeList<'k, 'v when 'k : comparison>() = static let comparer = { new IComparer<'k * HashSet<'v>> with member x.Compare((l,_), (r,_)) = compare l r } let sortedSet = SortedSetExt comparer diff --git a/src/Aardvark.Rendering.GL/Runtime/RenderTasks.fs b/src/Aardvark.Rendering.GL/Runtime/RenderTasks.fs index da6201296..8f7a7d371 100644 --- a/src/Aardvark.Rendering.GL/Runtime/RenderTasks.fs +++ b/src/Aardvark.Rendering.GL/Runtime/RenderTasks.fs @@ -250,17 +250,17 @@ module RenderTasks = for op in ops do match op with | Add(_, cmd) -> - let (l, s, _r) = state.FindNeighbours((cmd, null)) - if s.HasValue then + let (struct(hasL, hasV, _), l, _, _) = state.FindNeighboursV((cmd, null)) + if hasV then Log.warn "[NativeRenderProgram] duplicate add of: %A" cmd else - let l = if l.HasValue then snd l.Value else null + let l = if hasL then snd l else null let self = program.InsertAfter(l, cmd) state.Add((cmd, self)) |> ignore | Rem(_, cmd) -> - let (_, s, _) = state.FindNeighbours((cmd, null)) - if s.HasValue then - let _, f = s.Value + let (hasValue, value) = state.FindValue((cmd, null)) + if hasValue then + let _, f = value f.Dispose() state.Remove(cmd, null) |> ignore else diff --git a/src/Aardvark.Rendering.Vulkan/Core/Device.fs b/src/Aardvark.Rendering.Vulkan/Core/Device.fs index 5ab603287..f4424df54 100644 --- a/src/Aardvark.Rendering.Vulkan/Core/Device.fs +++ b/src/Aardvark.Rendering.Vulkan/Core/Device.fs @@ -2094,24 +2094,44 @@ and DeviceFreeList() = else store + [] member x.TryGetAligned(align : int64, size : int64, [] export : bool) = let min = new DeviceBlock(Unchecked.defaultof<_>, Unchecked.defaultof<_>, -1L, size, false, null, null) let store = getStore export let view = store.GetViewBetween(min, null) - let res = - view |> Seq.tryFind (fun b -> - let o = next align b.Offset - let s = b.Size - (o - b.Offset) - s >= size - ) + let mutable foundSlot = false + let mutable e = view.GetEnumerator() + while not foundSlot && e.MoveNext() do + let b = e.Current + let o = next align b.Offset + let s = b.Size - (o - b.Offset) + foundSlot <- s >= size + + if foundSlot then + store.Remove e.Current |> ignore + Some e.Current + else + None - match res with - | Some res -> - store.Remove res |> ignore - Some res - | None -> - None + member x.TryGetAlignedV(align : int64, size : int64, [] export : bool) = + let min = new DeviceBlock(Unchecked.defaultof<_>, Unchecked.defaultof<_>, -1L, size, false, null, null) + let store = getStore export + let view = store.GetViewBetween(min, null) + + let mutable foundSlot = false + let mutable e = view.GetEnumerator() + while not foundSlot && e.MoveNext() do + let b = e.Current + let o = next align b.Offset + let s = b.Size - (o - b.Offset) + foundSlot <- s >= size + + if foundSlot then + store.Remove e.Current |> ignore + ValueSome e.Current + else + ValueNone member x.Insert(b : DeviceBlock) = let store = getStore b.Memory.IsExported @@ -2163,8 +2183,8 @@ and DeviceMemoryManager internal(heap : DeviceHeap, blockSize : int64, keepReser else lock free (fun () -> - match free.TryGetAligned(align, size, export) with - | Some b -> + match free.TryGetAlignedV(align, size, export) with + | ValueSome b -> let alignedOffset = next align b.Offset let alignedSize = b.Size - (alignedOffset - b.Offset) if alignedOffset > b.Offset then @@ -2189,7 +2209,7 @@ and DeviceMemoryManager internal(heap : DeviceHeap, blockSize : int64, keepReser b.IsFree <- false b :> DevicePtr - | None -> + | ValueNone -> addBlock x export x.Alloc(align, size, export) ) diff --git a/src/Aardvark.Rendering/Utilities/Memory.fs b/src/Aardvark.Rendering/Utilities/Memory.fs index 7a7b37111..1b7904abc 100644 --- a/src/Aardvark.Rendering/Utilities/Memory.fs +++ b/src/Aardvark.Rendering/Utilities/Memory.fs @@ -134,34 +134,61 @@ module Management = if v % align = 0n then v else v + (align - v % align) - + [] member x.TryGetGreaterOrEqual(size : nativeint) = let query = Block(Unchecked.defaultof<_>, Unchecked.defaultof<_>, -1n, size, true) - let (_, _, r) = store.FindNeighbours(query) - if r.HasValue then - let r = r.Value + let (struct(_, _, hasR), _, _, r) = store.FindNeighboursV(query) + if hasR then store.Remove r |> ignore Some r else None + member x.TryGetGreaterOrEqualV(size : nativeint) = + let query = Block(Unchecked.defaultof<_>, Unchecked.defaultof<_>, -1n, size, true) + let (struct(_, _, hasR), _, _, r) = store.FindNeighboursV(query) + if hasR then + store.Remove r |> ignore + ValueSome r + else + ValueNone + + [] member x.TryGetAligned(align : nativeint, size : nativeint) = let min = Block(Unchecked.defaultof<_>, Unchecked.defaultof<_>, -1n, size, true) let view = store.GetViewBetween(min, null) - let res = - view |> Seq.tryFind (fun b -> - let o = next align b.Offset - let s = b.Size - (o - b.Offset) - s >= size - ) + let mutable foundSlot = false + let mutable e = view.GetEnumerator() + while not foundSlot && e.MoveNext() do + let b = e.Current + let o = next align b.Offset + let s = b.Size - (o - b.Offset) + foundSlot <- s >= size + + if foundSlot then + store.Remove e.Current |> ignore + Some e.Current + else + None + + member x.TryGetAlignedV(align : nativeint, size : nativeint) = + let min = Block(Unchecked.defaultof<_>, Unchecked.defaultof<_>, -1n, size, true) + let view = store.GetViewBetween(min, null) - match res with - | Some res -> - store.Remove res |> ignore - Some res - | None -> - None + let mutable foundSlot = false + let mutable e = view.GetEnumerator() + while not foundSlot && e.MoveNext() do + let b = e.Current + let o = next align b.Offset + let s = b.Size - (o - b.Offset) + foundSlot <- s >= size + + if foundSlot then + store.Remove e.Current |> ignore + ValueSome e.Current + else + ValueNone member x.Insert(b : Block<'a>) = store.Add b |> ignore @@ -239,8 +266,8 @@ module Management = Block<'a>(x, store, 0n, 0n, true, null, null) else lock free (fun () -> - match free.TryGetAligned(align, size) with - | Some b -> + match free.TryGetAlignedV(align, size) with + | ValueSome b -> let alignedOffset = next align b.Offset let alignedSize = b.Size - (alignedOffset - b.Offset) if alignedOffset > b.Offset then @@ -262,7 +289,7 @@ module Management = b.IsFree <- false b - | None -> + | ValueNone -> grow size x.Alloc(align, size) @@ -273,8 +300,8 @@ module Management = Block<'a>(x, store, 0n, 0n, true, null, null) else lock free (fun () -> - match free.TryGetGreaterOrEqual size with - | Some b -> + match free.TryGetGreaterOrEqualV size with + | ValueSome b -> if b.Size > size then let rest = Block<'a>(x, store, b.Offset + size, b.Size - size, true, b, b.Next) @@ -287,7 +314,7 @@ module Management = b.IsFree <- false b - | None -> + | ValueNone -> grow size x.Alloc size ) @@ -481,8 +508,8 @@ module Management = empty else lock free (fun () -> - match free.TryGetAligned(align, size) with - | Some b -> + match free.TryGetAlignedV(align, size) with + | ValueSome b -> let alignedOffset = next align b.Offset let alignedSize = b.Size - (alignedOffset - b.Offset) if alignedOffset > b.Offset then @@ -502,7 +529,7 @@ module Management = b.IsFree <- false b - | None -> + | ValueNone -> grow size x.Alloc(align, size) @@ -513,8 +540,8 @@ module Management = empty else lock free (fun () -> - match free.TryGetGreaterOrEqual size with - | Some b -> + match free.TryGetGreaterOrEqualV size with + | ValueSome b -> if b.Size > size then let rest = Block<'a>(x, b.Memory, b.Offset + size, b.Size - size, true, b, b.Next) @@ -526,7 +553,7 @@ module Management = b.IsFree <- false b - | None -> + | ValueNone -> grow size x.Alloc size ) diff --git a/src/Aardvark.Rendering/Utilities/Trie.fs b/src/Aardvark.Rendering/Utilities/Trie.fs index 0d15b986e..ba88e6dd7 100644 --- a/src/Aardvark.Rendering/Utilities/Trie.fs +++ b/src/Aardvark.Rendering/Utilities/Trie.fs @@ -9,10 +9,7 @@ type ILinked<'a when 'a :> ILinked<'a>> = [] module private TrieDictionaryImplementation = - open System.Runtime.CompilerServices open System.Runtime.InteropServices - open System.Collections.Generic - open System [] type TrieDictionary<'k, 'v>() = abstract AlterWithNeighbours : key : 'k * action : (voption<'v> -> voption<'v> -> voption<'v> -> voption<'v>) -> voption<'v> * voption<'v> * voption<'v> @@ -30,31 +27,26 @@ module private TrieDictionaryImplementation = } member x.Find(k : 'k) = - let mutable l = Unchecked.defaultof<_> - let mutable s = Unchecked.defaultof<_> - let mutable r = Unchecked.defaultof<_> - store.FindNeighbours (struct(k, Unchecked.defaultof<'v>), &l, &s, &r) + let (struct(hasL, hasV, hasR), l, v, r) = store.FindNeighboursV (struct(k, Unchecked.defaultof<'v>)) let l = - if l.HasValue then - let struct(_, v) = l.Value - ValueSome v + if hasL then + ValueSome (sndv l) else ValueNone - let s = - if s.HasValue then - let struct(_, v) = s.Value - ValueSome v + let v = + if hasV then + ValueSome (sndv v) else ValueNone let r = - if r.HasValue then - let struct(_, v) = r.Value - ValueSome v - else ValueNone + if hasR then + ValueSome (sndv r) + else + ValueNone - struct (l, s, r) + struct (l, v, r) override x.Count = store.Count diff --git a/src/Demo/Examples/Program.fs b/src/Demo/Examples/Program.fs index 81ee5480c..2f131febf 100644 --- a/src/Demo/Examples/Program.fs +++ b/src/Demo/Examples/Program.fs @@ -10,6 +10,7 @@ open System.Threading open Microsoft.FSharp.NativeInterop open Aardvark.Base open Aardvark.Rendering +open Aardvark.Rendering.Management open Aardvark.SceneGraph open FSharp.Data.Traceable open FSharp.Data.Adaptive @@ -125,389 +126,8 @@ let colorLockTest() = open Aardvark.Rendering.Interactive -module Management = +module MemoryManagerTest = - type Memory<'a> = - { - malloc : nativeint -> 'a - mfree : 'a -> nativeint -> unit - mcopy : 'a -> nativeint -> 'a -> nativeint -> nativeint -> unit - mrealloc : 'a -> nativeint -> nativeint -> 'a - } - - [] - module Memory = - open System.IO.MemoryMappedFiles - - let hglobal = - { - malloc = Marshal.AllocHGlobal - mfree = fun ptr _ -> Marshal.FreeHGlobal ptr - mcopy = fun src srcOff dst dstOff size -> Marshal.Copy(src + srcOff, dst + dstOff, size) - mrealloc = fun ptr _ n -> Marshal.ReAllocHGlobal(ptr, n) - } - - let cotask = - { - malloc = fun s -> Marshal.AllocCoTaskMem(int s) - mfree = fun ptr _ -> Marshal.FreeCoTaskMem ptr - mcopy = fun src srcOff dst dstOff size -> Marshal.Copy(src + srcOff, dst + dstOff, size) - mrealloc = fun ptr _ n -> Marshal.ReAllocCoTaskMem(ptr, int n) - } - - let array<'a> = - { - malloc = fun s -> Array.zeroCreate<'a> (int s) - - mfree = fun a s -> - () - - mcopy = fun src srcOff dst dstOff size -> - Array.Copy(src, int64 srcOff, dst, int64 dstOff, int64 size) - - mrealloc = fun ptr o n -> - let mutable ptr = ptr - Array.Resize(&ptr, int n) - ptr - } - - let nop = - { - malloc = fun _ -> () - mfree = fun _ _ -> () - mrealloc = fun _ _ _ -> () - mcopy = fun _ _ _ _ _ -> () - } - - - [] - type Block<'a> = - class - val mutable public Parent : MemoryManager<'a> - val mutable public Next : Block<'a> - val mutable public Prev : Block<'a> - val mutable public Offset : nativeint - val mutable public Size : nativeint - val mutable public IsFree : bool - - override x.ToString() = - sprintf "[%d,%d)" x.Offset (x.Offset + x.Size) - - new(parent, o, s, f, p, n) = { Parent = parent; Offset = o; Size = s; IsFree = f; Prev = p; Next = n } - new(parent, o, s, f) = { Parent = parent; Offset = o; Size = s; IsFree = f; Prev = null; Next = null } - - end - - and FreeList<'a>() = - static let comparer = - { new System.Collections.Generic.IComparer> with - member x.Compare(l : Block<'a>, r : Block<'a>) = - if isNull l then - if isNull r then 0 - else 1 - elif isNull r then - -1 - else - let c = compare l.Size r.Size - if c <> 0 then c - else compare l.Offset r.Offset - } - - let store = SortedSetExt>(Seq.empty, comparer) - - static let next (align : nativeint) (v : nativeint) = - if v % align = 0n then v - else v + (align - v % align) - - - member x.TryGetGreaterOrEqual(size : nativeint) = - let query = Block(Unchecked.defaultof<_>, -1n, size, true) - let (_, _, r) = store.FindNeighbours(query) - if r.HasValue then - let r = r.Value - store.Remove r |> ignore - Some r - else - None - - member x.TryGetAligned(align : nativeint, size : nativeint) = - let min = Block(Unchecked.defaultof<_>, -1n, size, true) - let view = store.GetViewBetween(min, null) - - let res = - view |> Seq.tryFind (fun b -> - let o = next align b.Offset - let s = b.Size - (o - b.Offset) - s >= size - ) - - match res with - | Some res -> - store.Remove res |> ignore - Some res - | None -> - None - - member x.Insert(b : Block<'a>) = - store.Add b |> ignore - - member x.Remove(b : Block<'a>) = - store.Remove b |> ignore - - member x.Clear() = - store.Clear() - - and MemoryManager<'a>(mem : Memory<'a>, initialCapacity : nativeint) as this = - - let free = FreeList<'a>() - - let mutable store = mem.malloc initialCapacity - let mutable capacity = initialCapacity - let mutable first = Block<'a>(this, 0n, initialCapacity, true) - let mutable last = first - do free.Insert(first) - - static let next (align : nativeint) (v : nativeint) = - if v % align = 0n then v - else v + (align - v % align) - - let rw = new ReaderWriterLockSlim() - - let changeCapacity (newCapacity : nativeint) = - let oldCapacity = capacity - if newCapacity <> oldCapacity then - ReaderWriterLock.write rw (fun () -> - let o = store - let n = mem.mrealloc o oldCapacity newCapacity - store <- n - capacity <- newCapacity - let o = () - - let additional = newCapacity - oldCapacity - if additional > 0n then - if last.IsFree then - free.Remove(last) |> ignore - last.Size <- last.Size + additional - free.Insert(last) - else - let newFree = Block<'a>(this, oldCapacity, additional, true, last, null) - last.Next <- newFree - free.Insert(newFree) - else (* additional < 0 *) - let freed = -additional - if not last.IsFree || last.Size < freed then - failwith "invalid memory manager state" - - if last.Size > freed then - free.Remove(last) |> ignore - last.Size <- last.Size - freed - free.Insert(last) - else (* last.Size = freed *) - free.Remove(last) |> ignore - let l = last - if isNull l.Prev then first <- null - else l.Prev.Next <- null - last <- l.Prev - ) - - let grow (additional : nativeint) = - let newCapacity = Fun.NextPowerOfTwo(int64 (capacity + additional)) |> nativeint - changeCapacity newCapacity - - member x.Alloc(align : nativeint, size : nativeint) = - lock free (fun () -> - match free.TryGetAligned(align, size) with - | Some b -> - let alignedOffset = next align b.Offset - let alignedSize = b.Size - (alignedOffset - b.Offset) - if alignedOffset > b.Offset then - let l = Block<'a>(x, b.Offset, alignedOffset - b.Offset, true, b.Prev, b) - if isNull l.Prev then first <- l - else l.Prev.Next <- l - b.Prev <- l - free.Insert(l) - b.Offset <- alignedOffset - b.Size <- alignedSize - - if alignedSize > size then - let r = Block<'a>(x, alignedOffset + size, alignedSize - size, true, b, b.Next) - if isNull r.Next then last <- r - else r.Next.Prev <- r - b.Next <- r - free.Insert(r) - b.Size <- size - - b.IsFree <- false - b - | None -> - grow size - x.Alloc(align, size) - - ) - - member x.Alloc(size : nativeint) = - lock free (fun () -> - match free.TryGetGreaterOrEqual size with - | Some b -> - if b.Size > size then - let rest = Block<'a>(x, b.Offset + size, b.Size - size, true, b, b.Next) - - if isNull rest.Next then last <- rest - else rest.Next.Prev <- rest - b.Next <- rest - - free.Insert(rest) - b.Size <- size - - b.IsFree <- false - b - | None -> - grow size - x.Alloc size - ) - - member x.Free(b : Block<'a>) = - if not b.IsFree then - lock free (fun () -> - let old = b - - let b = Block(x, b.Offset, b.Size, b.IsFree, b.Prev, b.Next) - if isNull b.Prev then first <- b - else b.Prev.Next <- b - - if isNull b.Next then last <- b - else b.Next.Prev <- b - - old.Next <- null - old.Prev <- null - old.IsFree <- true - old.Offset <- -1n - old.Size <- 0n - - - let prev = b.Prev - let next = b.Next - if not (isNull prev) && prev.IsFree then - free.Remove(prev) |> ignore - - b.Prev <- prev.Prev - if isNull prev.Prev then first <- b - else prev.Prev.Next <- b - - b.Offset <- prev.Offset - b.Size <- b.Size + prev.Size - - if not (isNull next) && next.IsFree then - free.Remove(next) |> ignore - b.Next <- next.Next - if isNull next.Next then last <- b - else next.Next.Prev <- b - b.Next <- next.Next - - b.Size <- b.Size + next.Size - - - b.IsFree <- true - free.Insert(b) - - if last.IsFree then - let c = Fun.NextPowerOfTwo (int64 last.Offset) |> nativeint - changeCapacity c - - ) - - member x.Realloc(b : Block<'a>, align : nativeint, size : nativeint) = - if b.Size <> size then - lock free (fun () -> - if b.IsFree then - let n = x.Alloc(align, size) - - b.Prev <- n.Prev - b.Next <- n.Next - b.Size <- n.Size - b.Offset <- n.Offset - b.IsFree <- false - - if isNull b.Prev then first <- b - else b.Prev.Next <- b - if isNull b.Next then last <- b - else b.Next.Prev <- b - - elif b.Size > size then - if size = 0n then - x.Free(b) - else - let r = Block(x, b.Offset + size, b.Size - size, false, b, b.Next) - b.Next <- r - if isNull r.Next then last <- r - else r.Next.Prev <- r - x.Free(r) - - elif b.Size < size then - let next = b.Next - let missing = size - b.Size - if not (isNull next) && next.IsFree && next.Size >= missing then - free.Remove next |> ignore - - if missing < next.Size then - next.Offset <- next.Offset + missing - next.Size <- next.Size - missing - b.Size <- size - free.Insert(next) - - else - b.Next <- next.Next - if isNull b.Next then last <- b - else b.Next.Prev <- b - b.Size <- size - - - else - let n = x.Alloc(align, size) - mem.mcopy store b.Offset store n.Offset b.Size - x.Free b - - b.Prev <- n.Prev - b.Next <- n.Next - b.Size <- n.Size - b.Offset <- n.Offset - b.IsFree <- false - - if isNull b.Prev then first <- b - else b.Prev.Next <- b - if isNull b.Next then last <- b - else b.Next.Prev <- b - - ) - - member x.Realloc(b : Block<'a>, size : nativeint) = - x.Realloc(b, 1n, size) - - member x.Capactiy = lock free (fun () -> capacity) - - member x.Use(b : Block<'a>, action : 'a -> nativeint -> nativeint -> 'r) = - if b.IsFree then failwith "cannot use free block" - ReaderWriterLock.read rw (fun () -> - action store b.Offset b.Size - ) - - member x.Dispose() = - rw.Dispose() - mem.mfree store capacity - first <- null - last <- null - free.Clear() - capacity <- -1n - - interface IDisposable with - member x.Dispose() = x.Dispose() - - - [] - module MemoryManager = - let createNop() = new MemoryManager<_>(Memory.nop, 16n) - - let testMem<'a> : Memory<'a[]> = { malloc = fun s ->