Memoization with time to live

timeToLive.fsx

#r @"C:\Projects\FSharpx\Build\FSharpx.Core.dll"
#r @"C:\Projects\FSharpx\Build\FSharpx.Collections.Experimental.dll"
#r @"C:\Projects\ExtCore\ExtCore\bin\release\ExtCore.dll"
#r @"C:\Users\dgrenier\desktop\System.Collections.Immutable.dll"

open System
module Queue = FSharpx.Collections.Queue
module IntMap = FSharpx.Collections.Experimental.IntMap
module HashMap = ExtCore.Collections.HashMap

type Dictionair = System.Collections.Immutable.ImmutableDictionary

module CAS =
    open System.Threading
 
    let create (value: 'T) =
        let cell = ref value
 
        let get () = !cell
 
        let rec swap f =
            let before = get()
            let newValue = f before
            match Interlocked.CompareExchange<'T>(cell, newValue, before) with
            | result when obj.ReferenceEquals(before, result) ->
                Some newValue
            | _ ->
                swap f
 
        get, swap
 
module Mutable =
    let timeToLiveFor evict f =
        let dict = System.Collections.Concurrent.ConcurrentDictionary HashIdentity.Structural
 
        fun key ->
            let key' = Some key
            match dict.TryGetValue key' with
            | true, value -> value
            | _ ->
                let value = f key
                dict.TryAdd(key', value) |> ignore
                evict (fun () -> dict.TryRemove key' |> ignore)
                value
 
module Memoization =
    let timeToLiveFor evict f =
        let get, swap = CAS.create Map.empty
        let removeKey key () = swap (Map.remove key) |> ignore
 
        fun key ->
            let key' = Some key
            match get().TryFind key' with
            | Some value -> value
            | None ->
                let value = f key
                swap (Map.add key' value) |> ignore
                evict (removeKey key')
                value
                
    let patriciaToLiveFor evict f =
        let get, swap = CAS.create HashMap.empty
        let removeKey key () = swap (HashMap.remove key) |> ignore
 
        fun key ->
            let key' = Some key
            match get() |> HashMap.tryFind key' with
            | Some value -> value
            | None ->
                let value = f key
                swap (HashMap.add key' value) |> ignore
                evict (removeKey key')
                value
                
    let dictToLiveFor evict f =
        let get, swap = CAS.create (Dictionair.Create<_,_> HashIdentity.Structural)
        let removeKey key () = swap (fun dict -> dict.Remove key) |> ignore
 
        fun key ->
            let key' = Some key
            match get().TryGetValue key' with
            | true, value -> value
            | _ ->
                let value = f key
                swap (fun dict -> dict.Add(key', value)) |> ignore
                evict (removeKey key')
                value
                
    let intMapToLiveFor evict f =
        let get, swap = CAS.create IntMap.empty
        let removeKey key () = swap (IntMap.delete key) |> ignore
 
        fun key ->
            match get() |> IntMap.tryFind key with
            | Some value -> value
            | None ->
                let value = f key
                swap (IntMap.insert key value) |> ignore
                evict (removeKey key)
                value

module Eviction =
    let asynk millis removeKey =
        async {
            do! Async.Sleep millis
            removeKey()
        } |> Async.Start

    let cas millis =
        let get, swap = CAS.create Queue.empty

        async {
            while true do
                match get().TryUncons with
                | None ->
                    do! Async.Sleep 10
                | Some ((_, sleepUntil), _) ->
                    let sleepTime =
                        (sleepUntil - DateTime.Now).TotalMilliseconds
                        |> int |> max 0
 
                    do! Async.Sleep sleepTime

                    swap(fun queue ->
                        let (removeKey, _), rest = Queue.uncons queue

                        removeKey()

                        rest
                    ) |> ignore
        } |> Async.Start

        fun removeKey ->
            swap (Queue.conj (removeKey, DateTime.Now.AddMilliseconds (float millis)))
            |> ignore

    let queue millis =
        let queue = System.Collections.Concurrent.ConcurrentQueue()

        async {
            while true do
                let result = ref (id, DateTime.Now)
                match queue.TryDequeue result with
                | false ->
                    do! Async.Sleep 10
                | true ->
                    let removeKey, sleepUntil = !result
                    let sleepTime =
                        (sleepUntil - DateTime.Now).TotalMilliseconds
                        |> int |> max 0
 
                    do! Async.Sleep sleepTime

                    removeKey()
        } |> Async.Start

        fun removeKey -> queue.Enqueue(removeKey, DateTime.Now.AddMilliseconds (float millis))

    let agent millis =
        let mb =
            MailboxProcessor.Start(fun inbox ->
                async {
                    while true do
                        let! (removeKey, until) = inbox.Receive()
                        let sleepTime =
                            (until - DateTime.Now).TotalMilliseconds
                            |> int |> max 0
 
                        do! Async.Sleep sleepTime
                        
                        removeKey()
                }
            )
        fun removeKey -> mb.Post(removeKey, DateTime.Now.AddMilliseconds (float millis))
 
type Test =
    {
        Hello: int
        Word: string
    }

#time
let bench f =
    let rnd = System.Random().Next
    let f = f (fun { Hello = n } -> System.Threading.Thread.Sleep 5; n + 1)
//    let f = f (fun n -> System.Threading.Thread.Sleep 5; n + 1)
    for x = 0 to 100000 do
        f ({ Hello = rnd 20; Word = "test" }) |> ignore
//        f (rnd 20) |> ignore

let liveFor = 150
bench (Memoization.timeToLiveFor (Eviction.asynk liveFor))
bench (Memoization.timeToLiveFor (Eviction.cas liveFor))
bench (Memoization.timeToLiveFor (Eviction.agent liveFor))

bench (Mutable.timeToLiveFor (Eviction.agent liveFor))
bench (Mutable.timeToLiveFor (Eviction.queue liveFor))

bench (Memoization.patriciaToLiveFor (Eviction.cas liveFor))
bench (Memoization.patriciaToLiveFor (Eviction.agent liveFor))
bench (Memoization.intMapToLiveFor (Eviction.cas liveFor))
bench (Memoization.dictToLiveFor (Eviction.agent liveFor))