Re-add dynamic shader caches

This commit adds / fixes dynamic shader caches removed in a previous commit.
Checking F# functions for equality is undefined behavior, caching is based on the
surface itself instead.

See: 6f9944f

src/Aardvark.Rendering.GL/Core/ShaderCache.fs

@@ -5,6 +5,8 @@ open Aardvark.Rendering
 
 open System
 open System.Collections.Concurrent
+open System.Collections.Generic
+open System.Runtime.CompilerServices
 
 [<AutoOpen>]
 module internal ShaderCacheKeys =
@@ -45,6 +47,7 @@ type internal ShaderCacheEntry(surface : IBackendSurface, destroy : unit -> unit
 type internal ShaderCache() =
     let codeCache = ConcurrentDictionary<CodeCacheKey, Error<ShaderCacheEntry>>()
     let effectCache = ConcurrentDictionary<EffectCacheKey, Error<ShaderCacheEntry>>()
+    let dynamicCache = ConditionalWeakTable<obj, obj>()
 
     static let box (destroy : 'T -> unit) (value : Error<'T>) : Error<ShaderCacheEntry> =
         match value with
@@ -62,6 +65,19 @@ type internal ShaderCache() =
     member x.GetOrAdd<'T when 'T :> IBackendSurface>(key : EffectCacheKey, create : EffectCacheKey -> Error<'T>, destroy : 'T -> unit) : Error<'T> =
         effectCache.GetOrAdd(key, create >> box destroy) |> unbox
 
+    member x.GetOrAdd(key: obj, signature: IFramebufferSignature, create: unit -> Error<'T>) : Error<'T> =
+        lock dynamicCache (fun _ ->
+            let perLayout =
+                match dynamicCache.TryGetValue key with
+                | (true, d) -> FSharp.Core.Operators.unbox d
+                | _ ->
+                    let d = Dictionary<FramebufferLayout, Error<'T>>()
+                    dynamicCache.Add(key, d)
+                    d
+
+            perLayout.GetCreate(signature.Layout, ignore >> create)
+        )
+
     member x.Entries =
         [ codeCache.Values; effectCache.Values ]
         |> Seq.concat

src/Aardvark.Rendering.GL/Resources/Program.fs

@@ -943,33 +943,35 @@ module ProgramExtensions =
                 | Error err -> Error err
 
             | Surface.FShade create ->
-                let (inputLayout,b) = create (signature.EffectConfig(Range1d(-1.0, 1.0), false))
+                // Use surface reference as key rather than create, since equality is undefined behavior for F# functions
+                // See F# specification: 6.9.24 Values with Underspecified Object Identity and Type Identity
+                x.ShaderCache.GetOrAdd(surface, signature, fun _ ->
+                    let (inputLayout, module_) = create (signature.EffectConfig(Range1d(-1.0, 1.0), false))
 
-                let initial = AVal.force b
-                let layoutHash = inputLayout.ComputeHash()
+                    let initial = AVal.force module_
+                    let layoutHash = inputLayout.ComputeHash()
 
-                let compile (m : Module) =
-                    try
-                        ModuleCompiler.compileGLSL x.FShadeBackend m
-                    with exn ->
-                        Log.error "%s" exn.Message
-                        reraise()
+                    let compile (m : Module) =
+                        try
+                            ModuleCompiler.compileGLSL x.FShadeBackend m
+                        with exn ->
+                            Log.error "%s" exn.Message
+                            reraise()
 
-                let iface =
                     match x.TryCompileProgram(initial.Hash + layoutHash, signature, lazy (compile initial)) with
-                    | Success prog -> prog.Interface
-                    | Error e ->
-                        failf "shader compiler returned errors: %s" e
-
-                let changeableProgram =
-                    b |> AVal.map (fun m ->
-                        match x.TryCompileProgram(m.Hash + layoutHash, signature, lazy (compile m)) with
-                        | Success p -> p
-                        | Error e ->
-                            failf "shader compiler returned errors: %s" e
-                    )
+                    | Success prog ->
+                        let changeableProgram =
+                            module_ |> AVal.map (fun m ->
+                                match x.TryCompileProgram(m.Hash + layoutHash, signature, lazy (compile m)) with
+                                | Success p -> p
+                                | Error e ->
+                                    failf "shader compiler returned errors: %s" e
+                            )
+
+                        Success (prog.Interface, changeableProgram)
 
-                Success (iface, changeableProgram)
+                    | Error e -> Error e
+                )
 
             | Surface.None ->
                 Error "[GL] empty shader"

src/Aardvark.Rendering.Vulkan/Management/ResourceManager.fs

@@ -1913,9 +1913,9 @@ type ResourceManager(device : Device) =
 
         program.PipelineLayout, resource
 
-    member private x.CreateDynamicShaderProgram(pass : RenderPass, compile : FShade.EffectConfig -> FShade.EffectInputLayout * aval<FShade.Imperative.Module>) =
+    member private x.CreateDynamicShaderProgram(key : obj, pass : RenderPass, compile : FShade.EffectConfig -> FShade.EffectInputLayout * aval<FShade.Imperative.Module>) =
         dynamicProgramCache.GetOrCreate(
-            [pass.Layout :> obj; compile :> obj],
+            [key; pass.Layout :> obj],
             fun cache key ->
                 let effectConfig = pass.EffectConfig(FShadeConfig.depthRange, false)
 
@@ -1934,7 +1934,9 @@ type ResourceManager(device : Device) =
             x.CreateShaderProgram(pass, effect, top)
 
         | Surface.FShade compile ->
-            let program = x.CreateDynamicShaderProgram(pass, compile)
+            // Use surface itself as key rather than compile function, since equality is undefined behavior for F# functions.
+            // See F# specification: 6.9.24 Values with Underspecified Object Identity and Type Identity
+            let program = x.CreateDynamicShaderProgram(data, pass, compile)
             program.Layout, program
 
         | Surface.Backend surface ->

src/Aardvark.Rendering/Surfaces/Surface.fs

@@ -12,7 +12,7 @@ type IBackendSurface =
     inherit IDisposable
     abstract member Handle : obj
 
-[<RequireQualifiedAccess>]
+[<RequireQualifiedAccess; ReferenceEquality>]
 type Surface =
     | FShadeSimple of Effect
     | FShade of (EffectConfig -> EffectInputLayout * aval<Imperative.Module>)