Fast entanglement detection based on entanglement candidates (suspects)

basis-library/mlton/HM.sig

@@ -10,8 +10,8 @@ sig
   val registerQueue: Word32.word * 'a array -> unit
   val registerQueueTop: Word32.word * Word64.word ref -> unit
   val registerQueueBot: Word32.word * Word32.word ref -> unit
-  val arrayUpdateNoBarrier : 'a array * SeqIndex.int * 'a -> unit
+  val arrayUpdateNoBarrier : 'a array * int * 'a -> unit
   val refAssignNoBarrier : 'a ref * 'a -> unit
-  val arraySubNoBarrier : 'a array * SeqIndex.int -> 'a
+  val arraySubNoBarrier : 'a array * int -> 'a
   val refDerefNoBarrier : 'a ref -> 'a
 end

basis-library/mlton/HM.sml

@@ -13,9 +13,13 @@ struct
   val registerQueueTop: Word32.word * Word64.word ref -> unit = PrimHM.registerQueueTop
   val registerQueueBot: Word32.word * Word32.word ref -> unit = PrimHM.registerQueueBot
 
-  val arrayUpdateNoBarrier = PrimHM.arrayUpdateNoBarrier
+  fun arrayUpdateNoBarrier (a, i, x) =
+    PrimHM.arrayUpdateNoBarrier (a, SeqIndex.fromInt i, x)
+
   val refAssignNoBarrier = PrimHM.refAssignNoBarrier
 
-  val arraySubNoBarrier = PrimHM.arraySubNoBarrier
+  fun arraySubNoBarrier (a, i) =
+    PrimHM.arraySubNoBarrier (a, SeqIndex.fromInt i)
+
   val refDerefNoBarrier = PrimHM.refDerefNoBarrier
 end

basis-library/mpl/gc.sig

@@ -21,6 +21,9 @@ sig
    *)
   val numberEntanglementsDetected: unit -> IntInf.int
 
+  val numberSuspectsMarked: unit -> IntInf.int
+  val numberSuspectsCleared: unit -> IntInf.int
+
   (* The following are all cumulative statistics (initially 0, and only
    * increase throughout execution).
    *

basis-library/mpl/gc.sml

@@ -42,6 +42,12 @@ struct
 
     fun numberEntanglementsDetected () =
       C_UIntmax.toLargeInt (GC.numberEntanglementsDetected (gcState ()))
+
+    fun numberSuspectsMarked () =
+      C_UIntmax.toLargeInt (GC.numberSuspectsMarked (gcState ()))
+
+    fun numberSuspectsCleared () =
+      C_UIntmax.toLargeInt (GC.numberSuspectsCleared (gcState ()))
   end
 
   exception NotYetImplemented of string

basis-library/primitive/prim-mlton.sml

@@ -167,6 +167,10 @@ structure GC =
       val numberDisentanglementChecks = _import "GC_numDisentanglementChecks" runtime private: GCState.t -> C_UIntmax.t;
 
       val numberEntanglementsDetected = _import "GC_numEntanglementsDetected" runtime private: GCState.t -> C_UIntmax.t;
+
+      val numberSuspectsMarked = _import "GC_numSuspectsMarked" runtime private: GCState.t -> C_UIntmax.t;
+
+      val numberSuspectsCleared = _import "GC_numSuspectsCleared" runtime private: GCState.t -> C_UIntmax.t;
    end
 
 structure HM =

basis-library/schedulers/shh/Scheduler.sml

@@ -156,8 +156,8 @@ struct
   local
     val amOriginal = ref true
     val taskBoxes = Array.array (P, NONE)
-    fun upd i x = HM.arrayUpdateNoBarrier (taskBoxes, Int64.fromInt i, x)
-    fun sub i = HM.arraySubNoBarrier (taskBoxes, Int64.fromInt i)
+    fun upd i x = HM.arrayUpdateNoBarrier (taskBoxes, i, x)
+    fun sub i = HM.arraySubNoBarrier (taskBoxes, i)
   in
   val _ = Thread.copyCurrent ()
   val prototypeThread : Thread.p =

basis-library/schedulers/shh/queue/DequeABP.sml

@@ -97,7 +97,7 @@ struct
   exception Full
 
   fun for (i, j) f = if i = j then () else (f i; for (i+1, j) f)
-  fun arrayUpdate (a, i, x) = MLton.HM.arrayUpdateNoBarrier (a, Int64.fromInt i, x)
+  fun arrayUpdate (a, i, x) = MLton.HM.arrayUpdateNoBarrier (a, i, x)
   fun cas r (x, y) = MLton.Parallel.compareAndSwap r (x, y)
 
   fun cas32 b (x, y) = cas b (Word32.fromInt x, Word32.fromInt y)

mlton/backend/ssa2-to-rssa.fun

@@ -688,6 +688,28 @@ datatype z = datatype Transfer.t
 
 structure PackedRepresentation = PackedRepresentation (structure Rssa = Rssa
                                                        structure Ssa2 = Ssa2)
+structure Statement =
+   struct
+      open Statement
+
+      local
+         fun make prim (z1: Operand.t, z2: Operand.t) =
+            let
+               val ty = Operand.ty z1
+               val tmp = Var.newNoname ()
+            in
+               (PrimApp {args = Vector.new2 (z1, z2),
+                         dst = SOME (tmp, ty),
+                         prim = prim (WordSize.fromBits (Type.width ty))},
+                Var {ty = ty, var = tmp})
+            end
+      in
+         val andb = make Prim.Word_andb
+         val lshift = make Prim.Word_lshift
+         val orb = make Prim.Word_orb
+         val rshift = make (fn s => Prim.Word_rshift (s, {signed = false}))
+      end
+   end
 
 structure Type =
    struct
@@ -1768,7 +1790,8 @@ fun convert (program as S.Program.T {functions, globals, main, ...},
                                               baseTy = varType (Base.object base),
                                               dst = (var, ty),
                                               offset = offset})
-                                         else let
+                                         else
+                                         let
                                             val baseOp = Base.map (base, varOp)
                                             val baseTy = varType (Base.object base)
                                             val ss' = select
@@ -1781,38 +1804,65 @@ fun convert (program as S.Program.T {functions, globals, main, ...},
                                               case List.splitLast ss' of
                                                 (ss'', Bind stuff) => (ss'', stuff)
                                               | _ => Error.bug "SsaToRssa.translateStatementsTransfer: Select with read barrier: no final Bind statement"
-
-                                            (* the read barrier returns a result
-                                             * that we'll put into this tmpVar,
-                                             * then finally create one more
-                                             * statement to move into the
-                                             * original destination. *)
-                                            val tmpVar = Var.newNoname ()
-                                            val theBind =
-                                              Bind {dst = finalDst,
-                                                    pinned = pinned,
-                                                    src = Operand.Var
-                                                      {var = tmpVar,
-                                                       ty = ty}}
-
-                                            val args = Vector.new3
-                                               (GCState,
-                                                Base.object baseOp,
-                                                Operand.Address field)
+                                            (* optimistically perform the read first *)
+                                            val optVar = Var.newNoname ()
+                                            val optVarOp = Operand.Var {var = optVar, ty = ty}
+                                            val optRead = Bind {dst=(optVar, ty), pinned = pinned, src=field}
+                                            (* then check if the entanglement suspect bit is set,
+                                             * if its not set, then proceed with the value in optVar without any readBarrier
+                                             * However, if its set, then we need to call the readBarrier
+                                             *)
+                                            fun uint_operand n = Operand.word (WordX.fromInt (n, WordSize.shiftArg))
+                                            (* val shift = Operand.word (WordX.one WordSize.shiftArg) *)
+                                            val smask = 0wx40000000
+                                            val smaskint = Word.toInt smask
+                                            val smaskintInf = IntInf.fromInt smaskint
+                                            val mask = Operand.word (WordX.fromIntInf (smaskintInf, WordSize.shiftArg))
+                                            val (crs, ctag) =
+                                             Statement.andb (Offset {base = varOp(Base.object base),
+                                               offset = Runtime.headerOffset (),
+                                               ty = Type.objptrHeader ()}, mask)
+                                            val (crs2, ctag2) = Statement.rshift (ctag, uint_operand 30)
+                                            val cont_block =
+                                             newBlock {args = Vector.new1 finalDst,
+                                                kind = Kind.Jump,
+                                                statements = Vector.fromList ss,
+                                                transfer = t
+                                             }
+                                            val fastBlock =
+                                             newBlock {args = Vector.new0 (),
+                                                kind = Kind.Jump,
+                                                statements = Vector.new0(),
+                                                transfer = Transfer.Goto {dst = cont_block, args = Vector.new1 optVarOp}}
                                             val func = CFunction.readBarrier
                                                {return = ty,
                                                 obj = Operand.ty (Base.object baseOp),
                                                 field = Operand.ty (Operand.Address field)}
-                                            val formals = Vector.new1 (tmpVar, ty)
-                                         in
-                                            split
-                                            (formals, Kind.CReturn {func = func}, theBind :: ss,
-                                             fn l =>
-                                             (ss'',
-                                              Transfer.CCall {args = args,
+                                            val func_args = Vector.new3
+                                               (GCState,
+                                                Base.object baseOp,
+                                                Operand.Address field)
+                                            val slowVar = Var.newNoname ()
+                                            val slowVarOp = Operand.Var {var = slowVar, ty = ty}
+                                            val formals = Vector.new1 (slowVar, ty)
+                                            val slowBlock = newBlock {args = formals,
+                                                kind = Kind.CReturn {func = func},
+                                                statements = Vector.new0 (),
+                                                transfer = Transfer.Goto {dst = cont_block, args = Vector.new1 slowVarOp}}
+                                            val slowBlockCall =
+                                             newBlock {args = Vector.new0 (),
+                                                kind = Kind.Jump,
+                                                statements = Vector.new0 (),
+                                                transfer = Transfer.CCall {args = func_args,
                                                               func = func,
-                                                              return = SOME l}))
-                                         end))
+                                                              return = SOME slowBlock}}
+                                            val new_transfer = Transfer.ifBoolE (ctag2, SOME false, {falsee = fastBlock, truee = slowBlockCall})
+                                            val new_ss = ss'' @ [optRead, crs, crs2]
+                                         in
+                                            loop (i - 1, new_ss, new_transfer)
+                                         end
+                                  )
+                           )
                       | S.Exp.Sequence {args} =>
                            (case toRtype ty of
                                NONE => none ()

runtime/gc.c

@@ -54,6 +54,7 @@ extern C_Pthread_Key_t gcstate_key;
 #include "gc/controls.c"
 #include "gc/copy-thread.c"
 #include "gc/current.c"
+#include "gc/entanglement-suspects.c"
 #include "gc/termination.c"
 #include "gc/local-scope.c"
 #include "gc/done.c"

runtime/gc.h

@@ -85,6 +85,7 @@ typedef GC_state GCState_t;
 #include "gc/hierarchical-heap.h"
 #include "gc/hierarchical-heap-ebr.h"
 #include "gc/hierarchical-heap-collection.h"
+#include "gc/entanglement-suspects.h"
 #include "gc/local-scope.h"
 #include "gc/local-heap.h"
 #include "gc/assign.h"

runtime/gc/assign.c

@@ -6,19 +6,17 @@
  * MLton is released under a HPND-style license.
  * See the file MLton-LICENSE for details.
  */
-
 void Assignable_decheckObjptr(objptr op)
 {
   GC_state s = pthread_getspecific(gcstate_key);
   s->cumulativeStatistics->numDisentanglementChecks++;
   decheckRead(s, op);
 }
 
-
 objptr Assignable_readBarrier(
   GC_state s,
   ARG_USED_FOR_ASSERT objptr obj,
-  objptr* field)
+  objptr *field)
 {
 
 #if ASSERT
@@ -53,10 +51,11 @@ objptr Assignable_readBarrier(
     obj,
     (size_t)(objend - objp));
 #endif
-
+  assert(ES_contains(NULL, obj));
   s->cumulativeStatistics->numDisentanglementChecks++;
   objptr ptr = *field;
   decheckRead(s, ptr);
+
   return ptr;
 }
 
@@ -116,8 +115,9 @@ void Assignable_writeBarrier(
 
   /* If src does not reference an object, then no need to check for
    * down-pointers. */
-  if (!isObjptr(src))
+  if (!isObjptr(src)){
     return;
+  }
 
   /* deque down-pointers are handled separately during collection. */
   if (dst == s->wsQueue)
@@ -187,20 +187,32 @@ void Assignable_writeBarrier(
     // }
     return;
   }
+  /** Otherwise, its a down-pointer, so
+    *  (i) make dst a suspect for entanglement, i.e., mark the suspect bit of dst's header
+    *      (see pin.h for header-layout).
+    *      the compiler checks this suspect bit and calls the read-barrier
+    *      only when the bit is set.
+    *  (ii) pin the src object
+    *  (iii) remember the down pointer
+    */
 
-  /* Otherwise, remember the pointer! */
+  /* make dst a suspect for entanglement */
+  uint32_t dd = dstHH->depth;
+  GC_thread thread = getThreadCurrent(s);
+  if (dd > 0 && !ES_contains(NULL, dst)) {
+    HM_HierarchicalHeap dhh = HM_HH_getHeapAtDepth(s, thread, dd);
+    ES_add(s, HM_HH_getSuspects(dhh), dst);
+  }
 
-  bool success = pinObject(src, dstHH->depth);
+  bool success = pinObject(src, dd);
 
   // any concurrent pin can only decrease unpinDepth
   uint32_t unpinDepth = unpinDepthOf(src);
-  assert(unpinDepth <= dstHH->depth);
+  assert(unpinDepth <= dd);
 
-  if (success || dstHH->depth == unpinDepth)
+  if (success || dd == unpinDepth)
   {
-    uint32_t d = srcHH->depth;
-    GC_thread thread = getThreadCurrent(s);
-
+    uint32_t sd = srcHH->depth;
 #if 0
     /** Fix a silly issue where, when we are dealing with entanglement, the
       * lower object is actually deeper than the current thread (which is
@@ -211,10 +223,10 @@ void Assignable_writeBarrier(
       d = thread->currentDepth;
 #endif
 
-    HM_HierarchicalHeap hh = HM_HH_getHeapAtDepth(s, thread, d);
-    assert(NULL != hh);
-    assert(HM_HH_getConcurrentPack(hh)->ccstate == CC_UNREG);
-    HM_rememberAtLevel(hh, remElem);
+    HM_HierarchicalHeap shh = HM_HH_getHeapAtDepth(s, thread, sd);
+    assert(NULL != shh);
+    assert(HM_HH_getConcurrentPack(shh)->ccstate == CC_UNREG);
+    HM_rememberAtLevel(shh, remElem);
 
     LOG(LM_HH_PROMOTION, LL_INFO,
       "remembered downptr %"PRIu32"->%"PRIu32" from "FMTOBJPTR" to "FMTOBJPTR,