# HG changeset patch
# User Richard Westhaver <ellis@rwest.io>
# Date 1718159617 14400
# Node ID 83f8623a6ec345043fdb9c2a25fe4eb159145e7c
# Parent  52608bbc3a7c180eea0901e954fa16f4921d59d2
std work, renamed :disabled in deftest to :skip

diff -r 52608bbc3a7c -r 83f8623a6ec3 lisp/ffi/zstd/tests.lisp
--- a/lisp/ffi/zstd/tests.lisp	Tue Jun 11 17:36:22 2024 -0400
+++ b/lisp/ffi/zstd/tests.lisp	Tue Jun 11 22:33:37 2024 -0400
@@ -38,7 +38,7 @@
         (is (zerop (zstd-iserror (zstd-decompress src src-size dst csize))))))))
 
 (deftest streaming ()
-  "Test the Zstd Streaming API functions."
+  "Test the Zstd v1 Streaming API."
   (is (< (zstd-cstreaminsize) (zstd-cstreamoutsize)))
   (with-alien ((in (* zstd-inbuffer) (zstd::allocate-zstd-inbuffer))
                (out (* zstd-outbuffer) (zstd::allocate-zstd-outbuffer))
@@ -68,5 +68,7 @@
                      c-string)
                str)))))))
 
+(deftest streaming2 ()
+  "Test the Zstd v2 Streaming API.")
 ;; simple-dictionary
 ;; builk-dictionary
diff -r 52608bbc3a7c -r 83f8623a6ec3 lisp/lib/net/tests.lisp
--- a/lisp/lib/net/tests.lisp	Tue Jun 11 17:36:22 2024 -0400
+++ b/lisp/lib/net/tests.lisp	Tue Jun 11 22:33:37 2024 -0400
@@ -24,7 +24,7 @@
 
 (deftest osc ())
 
-(deftest crew (:disabled t)
+(deftest crew (:skip t)
   (let ((pool (make-worker-pool (make-instance 'crew-connection-info :host-name "localhost" :port 9999)
                                 (list (make-instance 'crew-connection-info :host-name "localhost" :port 10000))
                                 #'connect-worker)))
diff -r 52608bbc3a7c -r 83f8623a6ec3 lisp/lib/obj/tests.lisp
--- a/lisp/lib/obj/tests.lisp	Tue Jun 11 17:36:22 2024 -0400
+++ b/lisp/lib/obj/tests.lisp	Tue Jun 11 22:33:37 2024 -0400
@@ -106,7 +106,7 @@
     (is (setf (getchash #\a map) t))
     (is (getchash #\A map))))
 
-(deftest castable-multi (:disabled t)
+(deftest castable-multi (:skip t)
   (let ((tries 40000)
         (threads 4))
     (let ((table (make-castable)))
diff -r 52608bbc3a7c -r 83f8623a6ec3 lisp/lib/rt/pkg.lisp
--- a/lisp/lib/rt/pkg.lisp	Tue Jun 11 17:36:22 2024 -0400
+++ b/lisp/lib/rt/pkg.lisp	Tue Jun 11 22:33:37 2024 -0400
@@ -682,7 +682,7 @@
 
 :PROFILE - enable profiling of this test
 
-:DISABLED - don't push this test to the current *TEST-SUITE*
+:SKIP - don't push this test to the current *TEST-SUITE*
 
 :BENCH - enable benchmarking of this test
 
@@ -704,7 +704,7 @@
 		 ,@(when-let ((v (getf pr :profile))) `(:profile ,v))
 		 ,@(when doc `(:doc ,doc))
 		 ,@(when dec `(:declaration ,dec)))))
-       ,(unless (getf pr :disabled) '(push-test obj *test-suite*))
+       ,(unless (getf pr :skip) '(push-test obj *test-suite*))
        obj)))
 
 (defmacro defsuite (suite-name &rest props)
diff -r 52608bbc3a7c -r 83f8623a6ec3 lisp/lib/rt/tests.lisp
--- a/lisp/lib/rt/tests.lisp	Tue Jun 11 17:36:22 2024 -0400
+++ b/lisp/lib/rt/tests.lisp	Tue Jun 11 22:33:37 2024 -0400
@@ -28,7 +28,7 @@
     (is (probe-file f))
     (delete-file f)))
 
-(deftest tracing (:profile t :disabled t) ;; fails in x 
+(deftest tracing (:profile t :skip t) ;; fails in x 
   (let ((f "/tmp/tracing.json")
         (*default-arg-converter* +arg-converter-store-only-simple-objects-and-strings+)) ;; open with chrome://tracing
     (flet ((foo (i)
diff -r 52608bbc3a7c -r 83f8623a6ec3 lisp/lib/vc/tests.lisp
--- a/lisp/lib/vc/tests.lisp	Tue Jun 11 17:36:22 2024 -0400
+++ b/lisp/lib/vc/tests.lisp	Tue Jun 11 22:33:37 2024 -0400
@@ -30,7 +30,7 @@
 
 (defun %mirror-update (path) (declare (ignore path)))
 
-(deftest mirror-network (:disabled t)
+(deftest mirror-network (:skip t)
   (macrolet ((with-job ((job &rest opts) &body body)
                `(let (()) ,@body)))
     (labels ((%m (name thunk args)))
diff -r 52608bbc3a7c -r 83f8623a6ec3 lisp/std/macs/pan.lisp
--- a/lisp/std/macs/pan.lisp	Tue Jun 11 17:36:22 2024 -0400
+++ b/lisp/std/macs/pan.lisp	Tue Jun 11 22:33:37 2024 -0400
@@ -1,7 +1,7 @@
 ;;; pan.lisp --- Pandoric macros
 
 ;;; Code:
-(in-package :std)
+(in-package :std/macs)
 (in-readtable :std)
 
 (defun pandoriclet-get (letargs)
@@ -24,7 +24,7 @@
 (defmacro pandoriclet (letargs &rest body)
   (let ((letargs (cons
                   '(this)
-                  (let-binding-transform
+                  (std/list:let-binding-transform
                    letargs))))
     `(let (,@letargs)
        (setq this ,@(last body))
diff -r 52608bbc3a7c -r 83f8623a6ec3 lisp/std/pkg.lisp
--- a/lisp/std/pkg.lisp	Tue Jun 11 17:36:22 2024 -0400
+++ b/lisp/std/pkg.lisp	Tue Jun 11 22:33:37 2024 -0400
@@ -161,29 +161,6 @@
   (:export :list-slot-values-using-class
    :list-class-methods :list-class-slots :list-indirect-slot-methods))
    
-(defpkg :std/thread
-  (:use :cl :sb-thread :sb-concurrency)
-  (:import-from :std/list :flatten)
-  (:export
-   :print-thread-message-top-level :thread-support-p
-   :find-thread-by-id :thread-id-list
-   :make-threads :with-threads :finish-threads
-   :timed-join-thread :kill-thread :hang
-   :thread-count :dump-thread
-   :make-oracle :make-supervisor :oracle :run-task
-   :oracle-id
-   :push-job :push-task :push-worker :push-result
-   :run-job :run-stage
-   :pop-job :pop-task :pop-worker :pop-result
-   :make-task-pool
-   :start-task-pool :pause-task-pool :shutdown-task-pool
-   :push-stage :designate-oracle :make-task-pool
-   :task :job :task-pool :stage :task-pool-p
-   :job-tasks :make-job :job-p :task-object
-   :make-task :task-p :task :wait-for-threads
-   :task-pool-oracle :task-pool-jobs :task-pool-stages
-   :task-pool-workers :task-pool-results))
-
 (defpkg :std/fu
   (:use :cl)
   (:import-from :std/sym :make-gensym-list)
@@ -267,6 +244,30 @@
    :collecting
    :xor))
 
+(defpkg :std/thread
+  (:use :cl :sb-thread :sb-concurrency)
+  (:import-from :std/list :flatten)
+  (:import-from :std/macs :if-let)
+  (:export
+   :print-thread-message-top-level :thread-support-p
+   :find-thread-by-id :thread-id-list
+   :make-threads :with-threads :finish-threads
+   :timed-join-thread :kill-thread :hang
+   :thread-count :dump-thread
+   :make-oracle :make-supervisor :oracle :run-task
+   :oracle-id
+   :push-job :push-task :push-worker :push-result
+   :run-job :run-stage
+   :pop-job :pop-task :pop-worker :pop-result
+   :make-task-pool
+   :start-task-pool :pause-task-pool :shutdown-task-pool
+   :push-stage :designate-oracle :make-task-pool
+   :task :job :task-pool :stage :task-pool-p
+   :job-tasks :make-job :job-p :task-object
+   :make-task :task-p :task :wait-for-threads
+   :task-pool-oracle :task-pool-jobs :task-pool-stages
+   :task-pool-workers :task-pool-results))
+
 (defpkg :std/readtable
   (:use :cl)
   (:import-from :std/named-readtables :defreadtable)
diff -r 52608bbc3a7c -r 83f8623a6ec3 lisp/std/std.asd
--- a/lisp/std/std.asd	Tue Jun 11 17:36:22 2024 -0400
+++ b/lisp/std/std.asd	Tue Jun 11 22:33:37 2024 -0400
@@ -30,7 +30,6 @@
                (:file "hash-table")
                (:file "alien")
                (:file "mop")
-               (:file "thread")
                (:file "readtable")
                (:module "macs"
                 :components
@@ -40,6 +39,7 @@
                  (:file "collecting")
                  (:file "control")))
                (:file "bit")
+               (:file "thread")
                (:file "fmt")
                (:file "path")
                (:file "os")
diff -r 52608bbc3a7c -r 83f8623a6ec3 lisp/std/tests.lisp
--- a/lisp/std/tests.lisp	Tue Jun 11 17:36:22 2024 -0400
+++ b/lisp/std/tests.lisp	Tue Jun 11 22:33:37 2024 -0400
@@ -16,7 +16,7 @@
 ;; (setf sb-unix::*on-dangerous-wait* :error)
 
 ;; TODO 2024-05-14: fix compilation order of std/fu vs std/readtables
-(deftest readtables (:disabled nil)
+(deftest readtables (:skip nil)
   "Test :std readtable"
   (is (typep #`(,a1 ,a1 ',a1 ,@a1) 'function))
   (is (string= #"test "foo" "# "test \"foo\" "))
@@ -144,8 +144,15 @@
 
 (deftest tasks ()
   "Test task-pools, oracles, and workers."
-  ;; (let ((pool1 (make-task-pool))))
-  )
+  (let ((pool (designate-oracle (make-task-pool) (make-oracle *current-thread*))))
+    ;; pool is bound to a task pool, *ORACLE-THREADS* contains the *CURRENT-THREAD*.
+    (std/thread::spawn-workers pool 16)
+    ;; (with-threads (16 :args (&optional (a 0) (b 1) (c 2)))
+    ;;   (sb-thread:allocator-histogram)
+    ;;   (sb-concurrency:wait-on-gate (std/thread::task-pool-online pool))
+    ;;   (print (+ a b c)))
+    (is (= 16 (length (task-pool-workers pool))))
+    (is (sb-concurrency:open-gate (std/thread::task-pool-online pool)))))
 
 (deftest fmt ()
   "Test standard formatters"
@@ -183,7 +190,7 @@
                                 (lambda () (mapc #'1+ (list a b c)))))
         collect (is (= x y))))
 
-(deftest pan (:disabled t)
+(deftest pan ()
   "Test standard pandoric macros"
   (let ((p
 	  (plambda (a) (b c)
@@ -194,7 +201,9 @@
     (with-pandoric (b c) p
       (is (= 0 (funcall p nil)))
       (is (= 1 (funcall p 1)))
-      (is (= 1 b c)))))
+      (is (= 11 (funcall p 10)))
+      (is (= 0 (funcall p nil)))
+      )))
 
 (deftest alien ()
   "Test standard alien utils"
@@ -242,7 +251,7 @@
                x) ;; 2
          '(42 42 2)))))
 
-(deftest bits (:disabled t)
+(deftest bits (:skip t)
   (define-bitfield testbits
     (a boolean)
     (b (signed-byte 2))
diff -r 52608bbc3a7c -r 83f8623a6ec3 lisp/std/thread.lisp
--- a/lisp/std/thread.lisp	Tue Jun 11 17:36:22 2024 -0400
+++ b/lisp/std/thread.lisp	Tue Jun 11 22:33:37 2024 -0400
@@ -24,10 +24,13 @@
 ;; this is all very unsafe. don't touch the finalizer thread plz.
 (defun find-thread-by-id (id)
   "Search for thread by ID which must be an u64. On success returns the thread itself or nil."
-  (sb-thread::avlnode-data (sb-thread::avl-find id sb-thread::*all-threads*)))
+  (find id (sb-thread::list-all-threads) :test '= :key 'thread-os-tid))
+
+(defun thread-key-list ()
+  (sb-thread::avltree-filter #'sb-thread::avlnode-key sb-thread::*all-threads*))
 
 (defun thread-id-list ()
-  (sb-thread::avltree-filter #'sb-thread::avlnode-key sb-thread::*all-threads*))
+  (sb-thread::avltree-filter (lambda (th) (thread-os-tid (sb-thread::avlnode-data th))) sb-thread::*all-threads*))
 
 (defun thread-count ()
   (sb-thread::avl-count sb-thread::*all-threads*))
@@ -37,8 +40,17 @@
   (loop for i below n
         collect (make-thread fn :name (format nil "~A-~D" name i))))
 
-(defmacro with-threads ((idx n) &body body)
-  `(make-threads ,n (lambda (,idx) (declare (ignorable ,idx)) ,@body)))
+(defun parse-lambda-list-names (ll)
+  (multiple-value-bind (idx _ args) (sb-int:parse-lambda-list ll)
+    (declare (ignore idx _))
+    (loop for a in args
+          collect
+             (etypecase a
+               (atom a)
+               (cons (car a))))))
+
+(defmacro with-threads ((n &key args) &body body)
+  `(make-threads ,n (lambda (,@args) (declare (ignorable ,@(parse-lambda-list-names args))) ,@body)))
 
 (defun finish-threads (&rest threads)
   (let ((threads (flatten threads)))
@@ -146,28 +158,29 @@
 Before using this object you should ensure the SCOPE is fully
 initialized. Supervisors should be created at any point during the
 lifetime of SCOPE, but never before and never after."))
-(thread-id-list)
+
 ;; unix-getrusage  
 ;; 0,-1,-2
 ;; (multiple-value-list (sb-unix:unix-getrusage 0))
 ;; (setf sb-unix::*on-dangerous-wait* :error)
-(defvar *oracle-threads* nil)
-
-(defun find-oracle (id)
-  (declare ((unsigned-byte 32) id))
-  (find id *oracle-threads* :test '= :key 'oracle-id))
-
 (defstruct (oracle (:constructor %make-oracle (id thread)))
   (id 0 :type (unsigned-byte 32) :read-only t)
   (thread *current-thread* :read-only t))
 
+(defvar *oracle-threads* nil)
+
+(defun find-oracle (id)
+  (find id *oracle-threads* :test '= :key 'oracle-id))
+
 (defun make-oracle (thread)
-  (let ((orc (%make-oracle (sb-thread:thread-os-tid thread) thread)))
-    (prog1 orc
-      (pushnew orc *oracle-threads* :test '= :key #'oracle-id))))
+  (let* ((id (thread-os-tid thread)))
+    (if-let ((found (find-oracle id)))
+      (values id found)
+      (let ((orc (%make-oracle id thread)))
+        (push orc *oracle-threads*)
+        (values id orc)))))
 
 (defgeneric designate-oracle (host guest))
-
 (defgeneric push-job (job pool))
 (defgeneric push-task (task pool))
 (defgeneric push-result (task pool))
@@ -182,10 +195,10 @@
 (defgeneric pop-result (pool))
 (defgeneric pop-worker (pool))
 (defgeneric pop-stage (pool))
-
 (defgeneric start-task-pool (pool))
 (defgeneric pause-task-pool (pool))
 (defgeneric stop-task-pool (pool))
+(defgeneric restart-task-pool (pool))
 (defgeneric make-task (&rest args))
 (defgeneric run-job (self job))
 (defgeneric run-stage (self stage))
@@ -203,10 +216,15 @@
     (declare (ignore pool))
     (make-threads count function :name *default-worker-name*)))
 
-(defmacro define-task-kernel (name (&key args accessors) &body body)
+(defmacro parse-kernel-ops (op)
+  "Parse an op of the form (NAME ARGS &BODY BODY)"
+  (destructuring-bind (name args &body body) op
+    `(std/macs:plambda ,args ,@body)))
+
+(defmacro define-task-kernel (name ops accessors &body body)
   "Define a task kernel.
 
-(define-task-kernel NAME (&key ARGS MAX MIN ACCESSORS)
+(define-task-kernel NAME (&key ARGS ACCESSORS)
 
 The kernel should process all options and return a function - the
 'kernel function'.
@@ -219,11 +237,12 @@
 kernel via an ORACLE. 
 
 This interface is experimental and subject to change."
-  (declare (ignorable accessors))
-  `(defun ,name (,@args) 
-     ,@body))
+  (declare (ignorable accessors ops))
+  `(defun ,name ()
+     ,@body
+     (values)))
 
-(define-task-kernel default-task-kernel (:args () )
+(define-task-kernel default-task-kernel () ()
   "The default task kernel used to initialize the KERNEL slot of
 task-pools.
 
@@ -250,11 +269,22 @@
   (online (make-gate :name "online" :open nil)
    :type gate)
   ;; TODO: test weak-vector here
-  (workers (make-array 0 :element-type '(unsigned-byte 32) :fill-pointer 0) :type (vector (unsigned-byte 32) *))
+  (workers nil :type list)
   (results (make-mailbox :name "results")))
 
+(defmethod print-object ((self task-pool) stream)
+  (print-unreadable-object (self stream :type t)
+    (format stream "~A ~A :online ~A ~A:~A:~A ~A"
+            (task-pool-oracle-id self)
+            (task-pool-kernel self)
+            (gate-open-p (task-pool-online self))
+            (queue-count (task-pool-jobs self))
+            (length (task-pool-stages self))
+            (length (task-pool-workers self))
+            (mailbox-count (task-pool-results self)))))
+
 (defmethod designate-oracle ((self task-pool) (guest integer))
-  (setf (task-pool-oracle-id self) guest)
+  (setf (task-pool-oracle-id self) (make-oracle (find-thread-by-id guest)))
   self)
 
 (defmethod designate-oracle ((self task-pool) (guest thread))
@@ -264,12 +294,12 @@
   (oracle-thread (find-oracle (slot-value self 'oracle))))
 
 (defmethod push-worker ((worker thread) (pool task-pool))
-  (vector-push (thread-os-tid worker) (task-pool-workers pool)))
+  (pushnew worker (task-pool-workers pool)))
 
 (defmethod push-workers ((threads list) (pool task-pool))
   (with-slots (workers) pool
     (dolist (w threads)
-      (vector-push (thread-os-tid w) workers))))
+      (pushnew w workers))))
 
 (defmethod make-worker-for ((pool task-pool) function &rest args)
   (make-thread function :name *default-worker-name* :arguments args))