Simple worked examples

For anyone who is interested, I recently published an article about my
implementation of the Very Concurrent Garbage Collector (VCGC) in F#:

http://fsharpnews.blogspot.com/2012/02/very-concurrent-garbage-collector.htm
l

The idea of prototyping GCs using high-level languages this way seems to be
quite novel. I adopted an allocationless style of programming where the
(preallocated) heap is represented as a value type array so it is completely
unboxed and, consequently, the results will be much more representative of a
production GC implementation. Note that the heap is specialized for the
n-queens solver but the GC algorithm itself is generic.

Regarding the algorithm, the complete VCGC implementation is under 300 lines
of F# code and it achieves submillisecond pause times and throughput
comparable to .NET itself. I instrumented the code with time stamping in
order to visualize the phases the mutator and GC thread were going through,
which proved invaluable when debugging performance issues.

The exchange of information between the mutator and GC threads proved
interesting. My first solutions used message passing but this proved to be
too inefficient. So I replaced this with pairs of collections and the
exchange at barriers would swap over collections in each pair. For example,
there are two free lists with the mutator popping heap blocks off one while
the GC pushes heap blocks onto the other. There are two newly-allocated
collections that the mutator pushes freshly allocated heap blocks onto one
while the GC copies heap blocks from the other newly-allocated collection
(obtained from the mutator at the last synchronization) to its local
collection of allocated heap blocks. Now, the only collection that gets
copied at synchronization is the stack and performance is great.

Here is the source code for the GC:

module VCGC

let timer = System.Diagnostics.Stopwatch.StartNew()

 [<Struct>]
type Coord =
  val x : int
  val y : int
  new(x, y) = {x=x; y=y}

[<Measure>] type IsRefn

type Refn = int<IsRefn>

let Null = -1<IsRefn>

let isNull r =
  r = -1<IsRefn>

let derefn (n: Refn) = int n

let refn (n: int) : Refn = 1<_> * n

[<Struct>]
type HeapBlock =
  val x : Coord
  val xs : Refn
  new (x, xs) = {x=x; xs=xs}

type Refns() =
  let mutable n = 0
  let mutable xs : Refn [] = Array.zeroCreate 1000000

  member __.Item
    with get i = xs.[i]

  member this.CopyFrom (ys: Refn []) m =
    if n+m < xs.Length then
      for i=0 to m-1 do
        xs.[n+i] <- ys.[i]
      n <- n + m
    else
      for i=0 to m-1 do
        this.Push ys.[i]

  member private this.SetIndexAndCopyFrom (epoch: sbyte<_> []) age (ys: Refn
[]) m =
    if n+m < xs.Length then
      for i=0 to m-1 do
        let y = ys.[i]
        epoch.[derefn y] <- age
        xs.[n+i] <- y
      n <- n + m
    else
      for i=0 to m-1 do
        let y = ys.[i]
        epoch.[derefn y] <- age
        this.Push y

  member this.SetIndexAndMoveTo epoch age (ys: Refns) =
    ys.SetIndexAndCopyFrom epoch age xs n
    this.Count <- 0

  static member Range(i0, i1) =
    let xs = Refns()
    for i=i0 to i1-1 do
      xs.Push (refn i)
    xs

  member this.Push x =
    if n=xs.Length then
      xs <- Array.append xs xs
    xs.[n] <- x
    n <- n + 1

  member __.Pop() =
    if n = 0 then failwith "Attempt to pop from empty extensible array"
    n <- n - 1
    xs.[n]

  member __.Count
    with get() = n
    and set n' = n <- n'

  member __.SetIndex (ys: int []) y =
    for i=0 to n-1 do
      ys.[derefn xs.[i]] <- y

  member this.FilterTo (epoch: sbyte<_> []) dead (freeList: Refns) =
    let rec loop src dst =
      if src = n then
        n <- dst
      else
        let x = xs.[src]
        if epoch.[derefn x] = dead then
          freeList.Push x
          loop (src+1) dst
        else
          xs.[dst] <- x
          loop (src+1) (dst+1)
    loop 0 0

[<Struct>]
type MutatorToGC =
  val stack : Refns
  val newlyAllocated : Refns
  new(stack, newlyAllocated) =
    {stack=stack; newlyAllocated=newlyAllocated}

[<Struct>]
type GCToMutator =
  val freeList : Refns
  new(freeList) = {freeList=freeList}

[<Measure>]
type Epoch

type age = sbyte<Epoch>

type Heap() =
  let mutable quota = 1000

  let gcMarkAndYoungify (heap: HeapBlock []) young (stack: Refns) (epoch:
age []) =
    let old = young - 1y<Epoch>
    let rec mark (blk: Refn) =
      if epoch.[derefn blk] = old then
        epoch.[derefn blk] <- young // Youngify as we mark
        let blk = heap.[derefn blk].xs
        if not(isNull blk) then mark blk
    for i=0 to stack.Count - 1 do
      let blk = stack.[i]
      if not(isNull blk) then mark blk

  let gcSweep young (allocated: Refns) (gcFreeList: Refns) (epoch: age []) =
    let dead = young - 2y<Epoch>
    allocated.FilterTo epoch dead gcFreeList

  let heapSize = 1000000
  let mutable mutatorToGC = MutatorToGC(Refns(), Refns())
  let mkGCFreeList() = Refns.Range(heapSize/2, heapSize)
  let mutable mutatorFreeList = Refns.Range(0, heapSize/2)

  let gcSend oldFreeList =
    let newFreeList = mutatorFreeList
    mutatorFreeList <- oldFreeList
    newFreeList

  let gcReceive young (allocated: Refns) (epoch: age []) =
    let old = young - 1y<Epoch>
    mutatorToGC.newlyAllocated.SetIndexAndMoveTo epoch old allocated
    if mutatorToGC.newlyAllocated.Count>0 then
      printfn "%d" mutatorToGC.newlyAllocated.Count
    mutatorToGC.stack

  let startBarrier = new System.Threading.Barrier(2)
  let finishBarrier = new System.Threading.Barrier(2)
  let heap = Array.create heapSize Unchecked.defaultof<HeapBlock>

  let rec gcLoop young (allocated: Refns) (freeList: Refns) (epoch: sbyte<_>
[]) () =
    gcPhase GCWaiting
    startBarrier.SignalAndWait()
    gcPhase GCPreparing
    let freeList = gcSend freeList
    let young = young + 1y<Epoch>
    finishBarrier.SignalAndWait()
    let stack = gcReceive young allocated epoch
    gcPhase GCMarking
    gcMarkAndYoungify heap young stack epoch
    gcPhase GCSweeping
    let oldHeapSize = allocated.Count
    gcSweep young allocated freeList epoch
    quota <- oldHeapSize - allocated.Count |> max 1000 |> min 1000
    gcLoop young allocated freeList epoch ()

  let gcThread =
    let allocated = Refns()
    let epoch = Array.create heap.Length 0y<Epoch>
    System.Threading.Thread(gcLoop 2y<Epoch> allocated (mkGCFreeList())
epoch)

  do
    gcThread.IsBackground <- true
    gcThread.Start()

  let mutatorSend (stack: Refn []) sp (newlyAllocated: Refns) =
    mutatorToGC.stack.Count <- 0
    mutatorToGC.stack.CopyFrom stack sp
    let msg = MutatorToGC(mutatorToGC.stack, newlyAllocated)
    let newlyAllocated = mutatorToGC.newlyAllocated
    mutatorToGC <- msg
    newlyAllocated

  let mutable mutatorNewlyAllocated = Refns()

  member __.Item
    with get i = heap.[derefn i]

  member __.Alloc(h, t) =
    let blk = mutatorFreeList.Pop()
    heap.[derefn blk] <- HeapBlock(h, t)
    mutatorNewlyAllocated.Push blk
    blk

  member __.GCReady =
    mutatorNewlyAllocated.Count > quota

  member __.GC (stack: Refn []) (sp: int) =
    mutatorPhase MutatorWaiting
    startBarrier.SignalAndWait()
    mutatorPhase MutatorSnapshotting
    mutatorNewlyAllocated <- mutatorSend stack sp mutatorNewlyAllocated
    finishBarrier.SignalAndWait()
    mutatorPhase MutatorRunning

let heap = Heap()

let stack = Array.create 1000 Null

let mutable sp = 0

module List =
  let empty = Null

  let cons x xs : Refn =
    heap.Alloc(x, xs)

  let isEmpty xs = xs=empty

let safe (q0: Coord) (q1: Coord) =
  q0.x<>q1.x && q0.y<>q1.y && q0.x-q0.y<>q1.x-q1.y && q0.x+q0.y<>q1.x+q1.y

let rec filter q xs =
  if List.isEmpty xs then List.empty else
    let blk = heap.[xs]
    if safe q blk.x then List.cons blk.x (filter q blk.xs) else filter q
blk.xs

let rec search n nqs qs ps a =
  if List.isEmpty ps then
    if nqs=n then a+1 else a
  else
    let osp = sp
    stack.[sp] <- qs
    stack.[sp+1] <- ps
    sp <- sp + 2
    if heap.GCReady then heap.GC stack sp
    let blk = heap.[ps]
    let q, ps = blk.x, blk.xs
    let qs' = List.cons q qs
    let ps' = filter q ps
    let a = search n (nqs+1) qs' ps' a
    sp <- osp
    search n nqs qs ps a

let ps n =
  let mutable list = List.empty
  for i in 1..n do
    for j in 1..n do
      list <- List.cons (Coord(i, j)) list
  list

let solve n =
  let sols = search n 0 List.empty (ps n) 0
  heap.GC [||] 0
  heap.GC [||] 0
  sols

let main n =
  printfn "Very Concurrent Garbage Collector"
  printfn "Warming up..."
  for i=1 to 1000 do
    heap.GC [||] 0
  printfn "Running..."
  printfn "%d gen-0, %d gen-1, %d gen-2"
    (System.GC.CollectionCount 0) (System.GC.CollectionCount 1)
(System.GC.CollectionCount 2)
  let timer = System.Diagnostics.Stopwatch.StartNew()
  try
    printfn "%d solutions to the %d-queens problem" (solve n) n
  with _ ->
    printfn "ERROR"
  printfn "Took %fs" timer.Elapsed.TotalSeconds
  printfn "%d gen-0, %d gen-1, %d gen-2"
    (System.GC.CollectionCount 0) (System.GC.CollectionCount 1)
(System.GC.CollectionCount 2)
  mutatorTimes, gcTimes

-- 
Dr Jon Harrop, Flying Frog Consultancy Ltd.
http://www.ffconsultancy.com