From b437f7aee100475533add418632833e9eaebc7bc Mon Sep 17 00:00:00 2001
From: "Kartik K. Agaram" <vc@akkartik.com>
Date: Sun, 23 Nov 2014 07:19:14 -0800
Subject: 304 - a unit test for a race condition

Still failing, but worth memorializing for posterity.

Race condition tests are still experimental, even more tied to a very
specific implementation. If I make changes to 'write' the very
'wipe-read' label will go away.

But then you just delete all tests relying on stale labels and try to
think up new race conditions.
---
 mu.arc   |  6 ++++++
 mu.arc.t | 26 ++++++++++++++++++++++++++
 2 files changed, 32 insertions(+)

diff --git a/mu.arc b/mu.arc
index 1dc43b62..d3cf5946 100644
--- a/mu.arc
+++ b/mu.arc
@@ -198,6 +198,7 @@
   (= abort-routine* (parameter nil))
   (= curr-cycle* 0)
   (= scheduling-interval* 500)
+  (= scheduler-switch-table* nil)  ; hook into scheduler for tests
   )
 
 ; like arc's 'point' but you can also call ((abort-routine*)) in nested calls
@@ -443,6 +444,11 @@
       (trace "run" curr-cycle* " " top.routine*!fn-name " " pc.routine* ": " (body.routine* pc.routine*))
 ;?       (trace "run" routine*)
       (when (atom (body.routine* pc.routine*))  ; label
+        (when (aand scheduler-switch-table*
+                    (alref it (body.routine* pc.routine*)))
+          (++ pc.routine*)
+          (trace "run" "context-switch forced " abort-routine*)
+          ((abort-routine*)))
         (++ pc.routine*)
         (continue))
       (let (oarg op arg)  (parse-instr (body.routine* pc.routine*))
diff --git a/mu.arc.t b/mu.arc.t
index d010e415..66d2f3ee 100644
--- a/mu.arc.t
+++ b/mu.arc.t
@@ -2434,6 +2434,32 @@
   (prn "F - channels are meant to be shared between routines"))
 ;? (quit)
 
+(reset)
+(new-trace "channel-race")
+(add-fns
+  '((main
+      ; create a channel with capacity 1
+      ((1 channel-address) <- new-channel (1 literal))
+      ((2 integer-address) <- new (integer literal))
+      ((2 integer-address deref) <- copy (34 literal))
+      ((3 tagged-value-address) <- new-tagged-value (integer-address literal) (2 integer-address))
+      ; write a value
+      ((1 channel-address deref) <- write (1 channel-address) (3 tagged-value-address deref))
+      ; write a second value
+      ((1 channel-address deref) <- write (1 channel-address) (3 tagged-value-address deref)))
+    (reader
+      (_ (1 channel-address deref) <- read (1 channel-address)))))
+; switch context at just the wrong time
+(= scheduler-switch-table*
+   '((wipe-read  reader)))
+;? (= dump-trace* (obj whitelist '("schedule" "run")))
+(run 'main 'reader)
+; second write should not cause deadlock
+(each routine completed-routines*
+  (when (posmatch "deadlock" rep.routine!error)
+    (prn "F - 'write' race condition 1")))
+;? (quit)
+
 ;; Separating concerns
 ;
 ; Lightweight tools can also operate on quoted lists of statements surrounded
-- 
cgit 1.4.1-2-gfad0