3 people like it.

Thread local & portable dependency injection

This is a pattern I knocked together to address the issue of global mutable state in the F# compiler.

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21: 
22: 
23: 
24: 
25: 
26: 
27: 
28: 
29: 
30: 
31: 
32: 
33: 
34: 
35: 
36: 
37: 
38: 
39: 
40: 
41: 
42: 
43: 
44: 
45: 
46: 
47: 
48: 
49: 
50: 
51: 
52: 
53: 
54: 
55: 
56: 
57: 
58: 
59: 
60: 
61: 
62: 
63: 
64: 
65: 
66: 
67: 
68: 
69: 
70: 
71: 
72: 
73: 
74: 
75: 
76: 
77: 
78: 
79: 
80: 
81: 
82: 
83: 
84: 
85: 
86: 
open System
open System.Threading
open System.Collections.Generic
open System.Collections.Concurrent


type IResource<'T> = abstract ThreadLocalValue : 'T

/// Thread-local portable dependency injection
type ThreadContext private () =

    static let factoryCount = ref 0
    static let resourceFactories = new ConcurrentDictionary<int, unit -> obj> () :> IDictionary<_,_>
    static let threadLocalState = new ThreadLocal<ThreadContext option ref>(fun () -> ref None)

    let resourceContainer = new ConcurrentDictionary<int, obj> ()

    member private __.GetResource<'T> (id : int) =
        let ok, value = resourceContainer.TryGetValue id
        if ok then value :?> 'T
        else
            // resource not installed in context, perform installation now
            let ok, factory = resourceFactories.TryGetValue id
            if ok then
                resourceContainer.AddOrUpdate(id, (fun _ -> factory ()), (fun _ value -> value)) :?> 'T
            else
                failwithf "ThreadContext: no factory for resource of type '%O' has been installed." typeof<'T>

    static member private GetResource<'T> id =
        match threadLocalState.Value.Value with
        | None -> failwith "ThreadContext: no context is installed on current thread."
        | Some ctx -> ctx.GetResource<'T> id

    /// installs given context to the current thread.
    member ctx.InstallContextToCurrentThread () : IDisposable =
        let state = threadLocalState.Value
        match state.Value with
        | Some _ -> invalidOp "ThreadContext: a context is already installed on this thread."
        | None ->
            state := Some ctx
            let isDisposed = ref 0
            { 
                new IDisposable with 
                    member __.Dispose () =
                        if Interlocked.CompareExchange(isDisposed, 1, 0) = 0 then
                            state := None
            }

    /// defines a new global resource
    static member InstallResourceFactory(f : unit -> 'T) =
        let id = Interlocked.Increment(factoryCount)
        resourceFactories.Add(id, fun () -> f () :> obj)
        { new IResource<'T> with member __.ThreadLocalValue = ThreadContext.GetResource<'T>(id) }

    static member Create () = new ThreadContext ()


// example

/// install a global resource
let globalMutableString = ThreadContext.InstallResourceFactory(fun () -> ref "")

// initialize a collection of contexts
let ctxs = Array.init 10 (fun _ -> ThreadContext.Create())

async {
    let store (value : int) (ctx : ThreadContext) = async {
        // 'use' binding keeps context installed only within lexical scope
        use uninstaller = ctx.InstallContextToCurrentThread()
        globalMutableString.ThreadLocalValue := string value
    }

    do! ctxs |> Array.mapi store |> Async.Parallel |> Async.Ignore
    
    // uncomment to cause exception
    //printfn "%s" globalMutableString.ThreadLocalValue.Value

    let read (ctx : ThreadContext) = async {
        use uninstaller = ctx.InstallContextToCurrentThread()
        return globalMutableString.ThreadLocalValue.Value
    }

    // output should maintain order of indices
    return! ctxs |> Array.map read |> Async.Parallel

} |> Async.RunSynchronously
namespace System
namespace System.Threading
namespace System.Collections
namespace System.Collections.Generic
namespace System.Collections.Concurrent
type IResource<'T> =
  interface
    abstract member ThreadLocalValue : 'T
  end

Full name: Script.IResource<_>
abstract member IResource.ThreadLocalValue : 'T

Full name: Script.IResource`1.ThreadLocalValue
Multiple items
type ThreadContext =
  private new : unit -> ThreadContext
  member private GetResource : id:int -> 'T
  member InstallContextToCurrentThread : unit -> IDisposable
  static member Create : unit -> ThreadContext
  static member private GetResource : id:int -> 'T
  static member InstallResourceFactory : f:(unit -> 'T) -> IResource<'T>

Full name: Script.ThreadContext


 Thread-local portable dependency injection


--------------------
private new : unit -> ThreadContext
val factoryCount : int ref
Multiple items
val ref : value:'T -> 'T ref

Full name: Microsoft.FSharp.Core.Operators.ref

--------------------
type 'T ref = Ref<'T>

Full name: Microsoft.FSharp.Core.ref<_>
val resourceFactories : IDictionary<int,(unit -> obj)>
Multiple items
type ConcurrentDictionary<'TKey,'TValue> =
  new : unit -> ConcurrentDictionary<'TKey, 'TValue> + 6 overloads
  member AddOrUpdate : key:'TKey * addValueFactory:Func<'TKey, 'TValue> * updateValueFactory:Func<'TKey, 'TValue, 'TValue> -> 'TValue + 1 overload
  member Clear : unit -> unit
  member ContainsKey : key:'TKey -> bool
  member Count : int
  member GetEnumerator : unit -> IEnumerator<KeyValuePair<'TKey, 'TValue>>
  member GetOrAdd : key:'TKey * valueFactory:Func<'TKey, 'TValue> -> 'TValue + 1 overload
  member IsEmpty : bool
  member Item : 'TKey -> 'TValue with get, set
  member Keys : ICollection<'TKey>
  ...

Full name: System.Collections.Concurrent.ConcurrentDictionary<_,_>

--------------------
ConcurrentDictionary() : unit
ConcurrentDictionary(collection: IEnumerable<KeyValuePair<'TKey,'TValue>>) : unit
ConcurrentDictionary(comparer: IEqualityComparer<'TKey>) : unit
ConcurrentDictionary(concurrencyLevel: int, capacity: int) : unit
ConcurrentDictionary(collection: IEnumerable<KeyValuePair<'TKey,'TValue>>, comparer: IEqualityComparer<'TKey>) : unit
ConcurrentDictionary(concurrencyLevel: int, collection: IEnumerable<KeyValuePair<'TKey,'TValue>>, comparer: IEqualityComparer<'TKey>) : unit
ConcurrentDictionary(concurrencyLevel: int, capacity: int, comparer: IEqualityComparer<'TKey>) : unit
Multiple items
val int : value:'T -> int (requires member op_Explicit)

Full name: Microsoft.FSharp.Core.Operators.int

--------------------
type int = int32

Full name: Microsoft.FSharp.Core.int

--------------------
type int<'Measure> = int

Full name: Microsoft.FSharp.Core.int<_>
type unit = Unit

Full name: Microsoft.FSharp.Core.unit
type obj = Object

Full name: Microsoft.FSharp.Core.obj
type IDictionary<'TKey,'TValue> =
  member Add : key:'TKey * value:'TValue -> unit
  member ContainsKey : key:'TKey -> bool
  member Item : 'TKey -> 'TValue with get, set
  member Keys : ICollection<'TKey>
  member Remove : key:'TKey -> bool
  member TryGetValue : key:'TKey * value:'TValue -> bool
  member Values : ICollection<'TValue>

Full name: System.Collections.Generic.IDictionary<_,_>
val threadLocalState : ThreadLocal<ThreadContext option ref>
Multiple items
type ThreadLocal<'T> =
  new : unit -> ThreadLocal<'T> + 1 overload
  member Dispose : unit -> unit
  member IsValueCreated : bool
  member ToString : unit -> string
  member Value : 'T with get, set

Full name: System.Threading.ThreadLocal<_>

--------------------
ThreadLocal() : unit
ThreadLocal(valueFactory: Func<'T>) : unit
type 'T option = Option<'T>

Full name: Microsoft.FSharp.Core.option<_>
union case Option.None: Option<'T>
val resourceContainer : ConcurrentDictionary<int,obj>
member private ThreadContext.GetResource : id:int -> 'T

Full name: Script.ThreadContext.GetResource
val id : int
val ok : bool
val value : obj
ConcurrentDictionary.TryGetValue(key: int, value: byref<obj>) : bool
val factory : (unit -> obj)
IDictionary.TryGetValue(key: int, value: byref<(unit -> obj)>) : bool
ConcurrentDictionary.AddOrUpdate(key: int, addValue: obj, updateValueFactory: Func<int,obj,obj>) : obj
ConcurrentDictionary.AddOrUpdate(key: int, addValueFactory: Func<int,obj>, updateValueFactory: Func<int,obj,obj>) : obj
val failwithf : format:Printf.StringFormat<'T,'Result> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.failwithf
val typeof<'T> : Type

Full name: Microsoft.FSharp.Core.Operators.typeof
static member private ThreadContext.GetResource : id:int -> 'T

Full name: Script.ThreadContext.GetResource
property ThreadLocal.Value: ThreadContext option ref
property Ref.Value: ThreadContext option
val failwith : message:string -> 'T

Full name: Microsoft.FSharp.Core.Operators.failwith
union case Option.Some: Value: 'T -> Option<'T>
val ctx : ThreadContext
member private ThreadContext.GetResource : id:int -> 'T
member ThreadContext.InstallContextToCurrentThread : unit -> IDisposable

Full name: Script.ThreadContext.InstallContextToCurrentThread


 installs given context to the current thread.
type IDisposable =
  member Dispose : unit -> unit

Full name: System.IDisposable
val state : ThreadContext option ref
val invalidOp : message:string -> 'T

Full name: Microsoft.FSharp.Core.Operators.invalidOp
val isDisposed : int ref
type Interlocked =
  static member Add : location1:int * value:int -> int + 1 overload
  static member CompareExchange : location1:int * value:int * comparand:int -> int + 6 overloads
  static member Decrement : location:int -> int + 1 overload
  static member Exchange : location1:int * value:int -> int + 6 overloads
  static member Increment : location:int -> int + 1 overload
  static member Read : location:int64 -> int64

Full name: System.Threading.Interlocked
Interlocked.CompareExchange<'T (requires reference type)>(location1: byref<'T>, value: 'T, comparand: 'T) : 'T
Interlocked.CompareExchange(location1: byref<nativeint>, value: nativeint, comparand: nativeint) : nativeint
Interlocked.CompareExchange(location1: byref<obj>, value: obj, comparand: obj) : obj
Interlocked.CompareExchange(location1: byref<float>, value: float, comparand: float) : float
Interlocked.CompareExchange(location1: byref<float32>, value: float32, comparand: float32) : float32
Interlocked.CompareExchange(location1: byref<int64>, value: int64, comparand: int64) : int64
Interlocked.CompareExchange(location1: byref<int>, value: int, comparand: int) : int
static member ThreadContext.InstallResourceFactory : f:(unit -> 'T) -> IResource<'T>

Full name: Script.ThreadContext.InstallResourceFactory


 defines a new global resource
val f : (unit -> 'T)
Interlocked.Increment(location: byref<int64>) : int64
Interlocked.Increment(location: byref<int>) : int
ICollection.Add(item: KeyValuePair<int,(unit -> obj)>) : unit
IDictionary.Add(key: int, value: unit -> obj) : unit
static member private ThreadContext.GetResource : id:int -> 'T
static member ThreadContext.Create : unit -> ThreadContext

Full name: Script.ThreadContext.Create
val globalMutableString : IResource<string ref>

Full name: Script.globalMutableString


 install a global resource
type ThreadContext =
  private new : unit -> ThreadContext
  member private GetResource : id:int -> 'T
  member InstallContextToCurrentThread : unit -> IDisposable
  static member Create : unit -> ThreadContext
  static member private GetResource : id:int -> 'T
  static member InstallResourceFactory : f:(unit -> 'T) -> IResource<'T>

Full name: Script.ThreadContext


 Thread-local portable dependency injection
static member ThreadContext.InstallResourceFactory : f:(unit -> 'T) -> IResource<'T>


 defines a new global resource
val ctxs : ThreadContext []

Full name: Script.ctxs
type Array =
  member Clone : unit -> obj
  member CopyTo : array:Array * index:int -> unit + 1 overload
  member GetEnumerator : unit -> IEnumerator
  member GetLength : dimension:int -> int
  member GetLongLength : dimension:int -> int64
  member GetLowerBound : dimension:int -> int
  member GetUpperBound : dimension:int -> int
  member GetValue : [<ParamArray>] indices:int[] -> obj + 7 overloads
  member Initialize : unit -> unit
  member IsFixedSize : bool
  ...

Full name: System.Array
val init : count:int -> initializer:(int -> 'T) -> 'T []

Full name: Microsoft.FSharp.Collections.Array.init
static member ThreadContext.Create : unit -> ThreadContext
val async : AsyncBuilder

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.async
val store : (int -> ThreadContext -> Async<unit>)
val value : int
val uninstaller : IDisposable
member ThreadContext.InstallContextToCurrentThread : unit -> IDisposable


 installs given context to the current thread.
property IResource.ThreadLocalValue: string ref
Multiple items
val string : value:'T -> string

Full name: Microsoft.FSharp.Core.Operators.string

--------------------
type string = String

Full name: Microsoft.FSharp.Core.string
val mapi : mapping:(int -> 'T -> 'U) -> array:'T [] -> 'U []

Full name: Microsoft.FSharp.Collections.Array.mapi
Multiple items
type Async
static member AsBeginEnd : computation:('Arg -> Async<'T>) -> ('Arg * AsyncCallback * obj -> IAsyncResult) * (IAsyncResult -> 'T) * (IAsyncResult -> unit)
static member AwaitEvent : event:IEvent<'Del,'T> * ?cancelAction:(unit -> unit) -> Async<'T> (requires delegate and 'Del :> Delegate)
static member AwaitIAsyncResult : iar:IAsyncResult * ?millisecondsTimeout:int -> Async<bool>
static member AwaitTask : task:Task<'T> -> Async<'T>
static member AwaitWaitHandle : waitHandle:WaitHandle * ?millisecondsTimeout:int -> Async<bool>
static member CancelDefaultToken : unit -> unit
static member Catch : computation:Async<'T> -> Async<Choice<'T,exn>>
static member FromBeginEnd : beginAction:(AsyncCallback * obj -> IAsyncResult) * endAction:(IAsyncResult -> 'T) * ?cancelAction:(unit -> unit) -> Async<'T>
static member FromBeginEnd : arg:'Arg1 * beginAction:('Arg1 * AsyncCallback * obj -> IAsyncResult) * endAction:(IAsyncResult -> 'T) * ?cancelAction:(unit -> unit) -> Async<'T>
static member FromBeginEnd : arg1:'Arg1 * arg2:'Arg2 * beginAction:('Arg1 * 'Arg2 * AsyncCallback * obj -> IAsyncResult) * endAction:(IAsyncResult -> 'T) * ?cancelAction:(unit -> unit) -> Async<'T>
static member FromBeginEnd : arg1:'Arg1 * arg2:'Arg2 * arg3:'Arg3 * beginAction:('Arg1 * 'Arg2 * 'Arg3 * AsyncCallback * obj -> IAsyncResult) * endAction:(IAsyncResult -> 'T) * ?cancelAction:(unit -> unit) -> Async<'T>
static member FromContinuations : callback:(('T -> unit) * (exn -> unit) * (OperationCanceledException -> unit) -> unit) -> Async<'T>
static member Ignore : computation:Async<'T> -> Async<unit>
static member OnCancel : interruption:(unit -> unit) -> Async<IDisposable>
static member Parallel : computations:seq<Async<'T>> -> Async<'T []>
static member RunSynchronously : computation:Async<'T> * ?timeout:int * ?cancellationToken:CancellationToken -> 'T
static member Sleep : millisecondsDueTime:int -> Async<unit>
static member Start : computation:Async<unit> * ?cancellationToken:CancellationToken -> unit
static member StartAsTask : computation:Async<'T> * ?taskCreationOptions:TaskCreationOptions * ?cancellationToken:CancellationToken -> Task<'T>
static member StartChild : computation:Async<'T> * ?millisecondsTimeout:int -> Async<Async<'T>>
static member StartChildAsTask : computation:Async<'T> * ?taskCreationOptions:TaskCreationOptions -> Async<Task<'T>>
static member StartImmediate : computation:Async<unit> * ?cancellationToken:CancellationToken -> unit
static member StartWithContinuations : computation:Async<'T> * continuation:('T -> unit) * exceptionContinuation:(exn -> unit) * cancellationContinuation:(OperationCanceledException -> unit) * ?cancellationToken:CancellationToken -> unit
static member SwitchToContext : syncContext:SynchronizationContext -> Async<unit>
static member SwitchToNewThread : unit -> Async<unit>
static member SwitchToThreadPool : unit -> Async<unit>
static member TryCancelled : computation:Async<'T> * compensation:(OperationCanceledException -> unit) -> Async<'T>
static member CancellationToken : Async<CancellationToken>
static member DefaultCancellationToken : CancellationToken

Full name: Microsoft.FSharp.Control.Async

--------------------
type Async<'T>

Full name: Microsoft.FSharp.Control.Async<_>
static member Async.Parallel : computations:seq<Async<'T>> -> Async<'T []>
static member Async.Ignore : computation:Async<'T> -> Async<unit>
val read : (ThreadContext -> Async<string>)
property Ref.Value: string
val map : mapping:('T -> 'U) -> array:'T [] -> 'U []

Full name: Microsoft.FSharp.Collections.Array.map
static member Async.RunSynchronously : computation:Async<'T> * ?timeout:int * ?cancellationToken:CancellationToken -> 'T
Raw view Test code New version

More information

Link:http://fssnip.net/lo
Posted:10 years ago
Author:Eirik Tsarpalis
Tags: dependency injection , thread safety , global state