correctly account for cycle starts

src/execution_context.mli

@@ -25,5 +25,6 @@ val create_like
 val find_local : t -> 'a Univ_map.Key.t -> 'a option
 val with_local : t -> 'a Univ_map.Key.t -> 'a option -> t
 val with_tid : t -> int -> t
+
 val record_backtrace : t -> t
 

src/job_queue.ml

@@ -133,38 +133,56 @@ let run_external_jobs t (scheduler : Scheduler.t) =
 let run_jobs (type a) t scheduler =
   (* We do the [try-with] outside of the [while] because it is cheaper than doing a
      [try-with] for each job. *)
-  try
-    (* [run_external_jobs] before entering the loop, since it might enqueue a job,
-       changing [t.length]. *)
-    run_external_jobs t scheduler;
-    while can_run_a_job t do
-      let this_job = offset t 0 in
-      let execution_context =
-        (Obj.obj (A.unsafe_get t.jobs this_job) : Execution_context.t)
-      in
-      let f = (Obj.obj (A.unsafe_get t.jobs (this_job + 1)) : a -> unit) in
-      let a = (Obj.obj (A.unsafe_get t.jobs (this_job + 2)) : a        ) in
-      (* We clear out the job right now so that it isn't live at the next minor
-         collection.  We tried not doing this and saw significant (15% or so) performance
-         hits due to spurious promotion. *)
-      set t 0 dummy_e dummy_f dummy_a;
-      t.front <- (t.front + 1) land t.mask;
-      t.length <- t.length - 1;
-      t.jobs_left_this_cycle <- t.jobs_left_this_cycle - 1;
-      (* It is OK if [run_job] or [run_external_jobs] raises, in which case the exn is
-         handled by the outer try-with.  The only side effects we have done are to take
-         the job out of the queue and decrement [jobs_left_this_cycle].  [run_job] or
-         [run_external_jobs] may side effect [t], either by enqueueing jobs, or by
-         clearing [t]. *)
-      run_job t scheduler execution_context f a;
-      (* [run_external_jobs] at each iteration of the [while] loop, for fairness. *)
+  let res =
+    try
+      (* [run_external_jobs] before entering the loop, since it might enqueue a job,
+        changing [t.length]. *)
       run_external_jobs t scheduler;
-    done;
-    Result.ok_unit
-  with exn ->
-    (* We call [Exn.backtrace] immediately after catching an unhandled exception, to
-       ensure there is no intervening code that interferes with the global backtrace
-       state. *)
-    let backtrace = Backtrace.Exn.most_recent () in
-    Error (exn, backtrace)
+      while can_run_a_job t do
+        let this_job = offset t 0 in
+        let execution_context =
+          (Obj.obj (A.unsafe_get t.jobs this_job) : Execution_context.t)
+        in
+        let f = (Obj.obj (A.unsafe_get t.jobs (this_job + 1)) : a -> unit) in
+        let a = (Obj.obj (A.unsafe_get t.jobs (this_job + 2)) : a        ) in
+        (* We clear out the job right now so that it isn't live at the next minor
+          collection.  We tried not doing this and saw significant (15% or so) performance
+          hits due to spurious promotion. *)
+        set t 0 dummy_e dummy_f dummy_a;
+        t.front <- (t.front + 1) land t.mask;
+        t.length <- t.length - 1;
+        t.jobs_left_this_cycle <- t.jobs_left_this_cycle - 1;
+        (* It is OK if [run_job] or [run_external_jobs] raises, in which case the exn is
+          handled by the outer try-with.  The only side effects we have done are to take
+          the job out of the queue and decrement [jobs_left_this_cycle].  [run_job] or
+          [run_external_jobs] may side effect [t], either by enqueueing jobs, or by
+          clearing [t]. *)
+        run_job t scheduler execution_context f a;
+        (* [run_external_jobs] at each iteration of the [while] loop, for fairness. *)
+        run_external_jobs t scheduler;
+      done;
+      Result.ok_unit
+    with exn ->
+      (* We call [Exn.backtrace] immediately after catching an unhandled exception, to
+        ensure there is no intervening code that interferes with the global backtrace
+        state. *)
+      let backtrace = Backtrace.Exn.most_recent () in
+      Error (exn, backtrace)
+  in
+  (*
+     Consider the following:
+
+     The scheduler finishes its current batch of jobs while executing with ctx.tid = A.
+     The end of the cycle triggers tracing to mark A as completed.
+     At the next cycle, a job with tid = A is the first to run.
+     If the execution_context from last cycle still has tid A, set_execution_context won't
+     notice the change and won't emit a Thread_switch event.
+
+     To induce the edge, we change the current execution context back to main.
+     We don't use set_execution_context because the fastpath doesn't matter
+     and we don't want to emit a Thread_switch event - we don't want to attribute
+     the idle time to the main thread, we want to show up as a gap in the timeline.
+     *)
+  scheduler.current_execution_context <- Execution_context.main ;
+  res
 ;;

src/scheduler0.ml

@@ -7,6 +7,7 @@ let events t = t.time_source.events
 
 let set_execution_context t execution_context =
   (* Avoid a caml_modify in most cases. *)
+  (* XXX: see where job_queue also modifies current_execution_context *)
   if not (phys_equal t.current_execution_context execution_context)
   then (
     if t.current_execution_context.tid <> execution_context.tid then (!Tracing.fns).trace_thread_switch execution_context ;