1.1--- a/lisp/ffi/zstd/tests.lisp Tue Jun 11 17:36:22 2024 -0400
1.2+++ b/lisp/ffi/zstd/tests.lisp Tue Jun 11 22:33:37 2024 -0400
1.3@@ -38,7 +38,7 @@
1.4 (is (zerop (zstd-iserror (zstd-decompress src src-size dst csize))))))))
1.5
1.6 (deftest streaming ()
1.7- "Test the Zstd Streaming API functions."
1.8+ "Test the Zstd v1 Streaming API."
1.9 (is (< (zstd-cstreaminsize) (zstd-cstreamoutsize)))
1.10 (with-alien ((in (* zstd-inbuffer) (zstd::allocate-zstd-inbuffer))
1.11 (out (* zstd-outbuffer) (zstd::allocate-zstd-outbuffer))
1.12@@ -68,5 +68,7 @@
1.13 c-string)
1.14 str)))))))
1.15
1.16+(deftest streaming2 ()
1.17+ "Test the Zstd v2 Streaming API.")
1.18 ;; simple-dictionary
1.19 ;; builk-dictionary
2.1--- a/lisp/lib/net/tests.lisp Tue Jun 11 17:36:22 2024 -0400
2.2+++ b/lisp/lib/net/tests.lisp Tue Jun 11 22:33:37 2024 -0400
2.3@@ -24,7 +24,7 @@
2.4
2.5 (deftest osc ())
2.6
2.7-(deftest crew (:disabled t)
2.8+(deftest crew (:skip t)
2.9 (let ((pool (make-worker-pool (make-instance 'crew-connection-info :host-name "localhost" :port 9999)
2.10 (list (make-instance 'crew-connection-info :host-name "localhost" :port 10000))
2.11 #'connect-worker)))
3.1--- a/lisp/lib/obj/tests.lisp Tue Jun 11 17:36:22 2024 -0400
3.2+++ b/lisp/lib/obj/tests.lisp Tue Jun 11 22:33:37 2024 -0400
3.3@@ -106,7 +106,7 @@
3.4 (is (setf (getchash #\a map) t))
3.5 (is (getchash #\A map))))
3.6
3.7-(deftest castable-multi (:disabled t)
3.8+(deftest castable-multi (:skip t)
3.9 (let ((tries 40000)
3.10 (threads 4))
3.11 (let ((table (make-castable)))
4.1--- a/lisp/lib/rt/pkg.lisp Tue Jun 11 17:36:22 2024 -0400
4.2+++ b/lisp/lib/rt/pkg.lisp Tue Jun 11 22:33:37 2024 -0400
4.3@@ -682,7 +682,7 @@
4.4
4.5 :PROFILE - enable profiling of this test
4.6
4.7-:DISABLED - don't push this test to the current *TEST-SUITE*
4.8+:SKIP - don't push this test to the current *TEST-SUITE*
4.9
4.10 :BENCH - enable benchmarking of this test
4.11
4.12@@ -704,7 +704,7 @@
4.13 ,@(when-let ((v (getf pr :profile))) `(:profile ,v))
4.14 ,@(when doc `(:doc ,doc))
4.15 ,@(when dec `(:declaration ,dec)))))
4.16- ,(unless (getf pr :disabled) '(push-test obj *test-suite*))
4.17+ ,(unless (getf pr :skip) '(push-test obj *test-suite*))
4.18 obj)))
4.19
4.20 (defmacro defsuite (suite-name &rest props)
5.1--- a/lisp/lib/rt/tests.lisp Tue Jun 11 17:36:22 2024 -0400
5.2+++ b/lisp/lib/rt/tests.lisp Tue Jun 11 22:33:37 2024 -0400
5.3@@ -28,7 +28,7 @@
5.4 (is (probe-file f))
5.5 (delete-file f)))
5.6
5.7-(deftest tracing (:profile t :disabled t) ;; fails in x
5.8+(deftest tracing (:profile t :skip t) ;; fails in x
5.9 (let ((f "/tmp/tracing.json")
5.10 (*default-arg-converter* +arg-converter-store-only-simple-objects-and-strings+)) ;; open with chrome://tracing
5.11 (flet ((foo (i)
6.1--- a/lisp/lib/vc/tests.lisp Tue Jun 11 17:36:22 2024 -0400
6.2+++ b/lisp/lib/vc/tests.lisp Tue Jun 11 22:33:37 2024 -0400
6.3@@ -30,7 +30,7 @@
6.4
6.5 (defun %mirror-update (path) (declare (ignore path)))
6.6
6.7-(deftest mirror-network (:disabled t)
6.8+(deftest mirror-network (:skip t)
6.9 (macrolet ((with-job ((job &rest opts) &body body)
6.10 `(let (()) ,@body)))
6.11 (labels ((%m (name thunk args)))
7.1--- a/lisp/std/macs/pan.lisp Tue Jun 11 17:36:22 2024 -0400
7.2+++ b/lisp/std/macs/pan.lisp Tue Jun 11 22:33:37 2024 -0400
7.3@@ -1,7 +1,7 @@
7.4 ;;; pan.lisp --- Pandoric macros
7.5
7.6 ;;; Code:
7.7-(in-package :std)
7.8+(in-package :std/macs)
7.9 (in-readtable :std)
7.10
7.11 (defun pandoriclet-get (letargs)
7.12@@ -24,7 +24,7 @@
7.13 (defmacro pandoriclet (letargs &rest body)
7.14 (let ((letargs (cons
7.15 '(this)
7.16- (let-binding-transform
7.17+ (std/list:let-binding-transform
7.18 letargs))))
7.19 `(let (,@letargs)
7.20 (setq this ,@(last body))
8.1--- a/lisp/std/pkg.lisp Tue Jun 11 17:36:22 2024 -0400
8.2+++ b/lisp/std/pkg.lisp Tue Jun 11 22:33:37 2024 -0400
8.3@@ -161,29 +161,6 @@
8.4 (:export :list-slot-values-using-class
8.5 :list-class-methods :list-class-slots :list-indirect-slot-methods))
8.6
8.7-(defpkg :std/thread
8.8- (:use :cl :sb-thread :sb-concurrency)
8.9- (:import-from :std/list :flatten)
8.10- (:export
8.11- :print-thread-message-top-level :thread-support-p
8.12- :find-thread-by-id :thread-id-list
8.13- :make-threads :with-threads :finish-threads
8.14- :timed-join-thread :kill-thread :hang
8.15- :thread-count :dump-thread
8.16- :make-oracle :make-supervisor :oracle :run-task
8.17- :oracle-id
8.18- :push-job :push-task :push-worker :push-result
8.19- :run-job :run-stage
8.20- :pop-job :pop-task :pop-worker :pop-result
8.21- :make-task-pool
8.22- :start-task-pool :pause-task-pool :shutdown-task-pool
8.23- :push-stage :designate-oracle :make-task-pool
8.24- :task :job :task-pool :stage :task-pool-p
8.25- :job-tasks :make-job :job-p :task-object
8.26- :make-task :task-p :task :wait-for-threads
8.27- :task-pool-oracle :task-pool-jobs :task-pool-stages
8.28- :task-pool-workers :task-pool-results))
8.29-
8.30 (defpkg :std/fu
8.31 (:use :cl)
8.32 (:import-from :std/sym :make-gensym-list)
8.33@@ -267,6 +244,30 @@
8.34 :collecting
8.35 :xor))
8.36
8.37+(defpkg :std/thread
8.38+ (:use :cl :sb-thread :sb-concurrency)
8.39+ (:import-from :std/list :flatten)
8.40+ (:import-from :std/macs :if-let)
8.41+ (:export
8.42+ :print-thread-message-top-level :thread-support-p
8.43+ :find-thread-by-id :thread-id-list
8.44+ :make-threads :with-threads :finish-threads
8.45+ :timed-join-thread :kill-thread :hang
8.46+ :thread-count :dump-thread
8.47+ :make-oracle :make-supervisor :oracle :run-task
8.48+ :oracle-id
8.49+ :push-job :push-task :push-worker :push-result
8.50+ :run-job :run-stage
8.51+ :pop-job :pop-task :pop-worker :pop-result
8.52+ :make-task-pool
8.53+ :start-task-pool :pause-task-pool :shutdown-task-pool
8.54+ :push-stage :designate-oracle :make-task-pool
8.55+ :task :job :task-pool :stage :task-pool-p
8.56+ :job-tasks :make-job :job-p :task-object
8.57+ :make-task :task-p :task :wait-for-threads
8.58+ :task-pool-oracle :task-pool-jobs :task-pool-stages
8.59+ :task-pool-workers :task-pool-results))
8.60+
8.61 (defpkg :std/readtable
8.62 (:use :cl)
8.63 (:import-from :std/named-readtables :defreadtable)
9.1--- a/lisp/std/std.asd Tue Jun 11 17:36:22 2024 -0400
9.2+++ b/lisp/std/std.asd Tue Jun 11 22:33:37 2024 -0400
9.3@@ -30,7 +30,6 @@
9.4 (:file "hash-table")
9.5 (:file "alien")
9.6 (:file "mop")
9.7- (:file "thread")
9.8 (:file "readtable")
9.9 (:module "macs"
9.10 :components
9.11@@ -40,6 +39,7 @@
9.12 (:file "collecting")
9.13 (:file "control")))
9.14 (:file "bit")
9.15+ (:file "thread")
9.16 (:file "fmt")
9.17 (:file "path")
9.18 (:file "os")
10.1--- a/lisp/std/tests.lisp Tue Jun 11 17:36:22 2024 -0400
10.2+++ b/lisp/std/tests.lisp Tue Jun 11 22:33:37 2024 -0400
10.3@@ -16,7 +16,7 @@
10.4 ;; (setf sb-unix::*on-dangerous-wait* :error)
10.5
10.6 ;; TODO 2024-05-14: fix compilation order of std/fu vs std/readtables
10.7-(deftest readtables (:disabled nil)
10.8+(deftest readtables (:skip nil)
10.9 "Test :std readtable"
10.10 (is (typep #`(,a1 ,a1 ',a1 ,@a1) 'function))
10.11 (is (string= #"test "foo" "# "test \"foo\" "))
10.12@@ -144,8 +144,15 @@
10.13
10.14 (deftest tasks ()
10.15 "Test task-pools, oracles, and workers."
10.16- ;; (let ((pool1 (make-task-pool))))
10.17- )
10.18+ (let ((pool (designate-oracle (make-task-pool) (make-oracle *current-thread*))))
10.19+ ;; pool is bound to a task pool, *ORACLE-THREADS* contains the *CURRENT-THREAD*.
10.20+ (std/thread::spawn-workers pool 16)
10.21+ ;; (with-threads (16 :args (&optional (a 0) (b 1) (c 2)))
10.22+ ;; (sb-thread:allocator-histogram)
10.23+ ;; (sb-concurrency:wait-on-gate (std/thread::task-pool-online pool))
10.24+ ;; (print (+ a b c)))
10.25+ (is (= 16 (length (task-pool-workers pool))))
10.26+ (is (sb-concurrency:open-gate (std/thread::task-pool-online pool)))))
10.27
10.28 (deftest fmt ()
10.29 "Test standard formatters"
10.30@@ -183,7 +190,7 @@
10.31 (lambda () (mapc #'1+ (list a b c)))))
10.32 collect (is (= x y))))
10.33
10.34-(deftest pan (:disabled t)
10.35+(deftest pan ()
10.36 "Test standard pandoric macros"
10.37 (let ((p
10.38 (plambda (a) (b c)
10.39@@ -194,7 +201,9 @@
10.40 (with-pandoric (b c) p
10.41 (is (= 0 (funcall p nil)))
10.42 (is (= 1 (funcall p 1)))
10.43- (is (= 1 b c)))))
10.44+ (is (= 11 (funcall p 10)))
10.45+ (is (= 0 (funcall p nil)))
10.46+ )))
10.47
10.48 (deftest alien ()
10.49 "Test standard alien utils"
10.50@@ -242,7 +251,7 @@
10.51 x) ;; 2
10.52 '(42 42 2)))))
10.53
10.54-(deftest bits (:disabled t)
10.55+(deftest bits (:skip t)
10.56 (define-bitfield testbits
10.57 (a boolean)
10.58 (b (signed-byte 2))
11.1--- a/lisp/std/thread.lisp Tue Jun 11 17:36:22 2024 -0400
11.2+++ b/lisp/std/thread.lisp Tue Jun 11 22:33:37 2024 -0400
11.3@@ -24,10 +24,13 @@
11.4 ;; this is all very unsafe. don't touch the finalizer thread plz.
11.5 (defun find-thread-by-id (id)
11.6 "Search for thread by ID which must be an u64. On success returns the thread itself or nil."
11.7- (sb-thread::avlnode-data (sb-thread::avl-find id sb-thread::*all-threads*)))
11.8+ (find id (sb-thread::list-all-threads) :test '= :key 'thread-os-tid))
11.9+
11.10+(defun thread-key-list ()
11.11+ (sb-thread::avltree-filter #'sb-thread::avlnode-key sb-thread::*all-threads*))
11.12
11.13 (defun thread-id-list ()
11.14- (sb-thread::avltree-filter #'sb-thread::avlnode-key sb-thread::*all-threads*))
11.15+ (sb-thread::avltree-filter (lambda (th) (thread-os-tid (sb-thread::avlnode-data th))) sb-thread::*all-threads*))
11.16
11.17 (defun thread-count ()
11.18 (sb-thread::avl-count sb-thread::*all-threads*))
11.19@@ -37,8 +40,17 @@
11.20 (loop for i below n
11.21 collect (make-thread fn :name (format nil "~A-~D" name i))))
11.22
11.23-(defmacro with-threads ((idx n) &body body)
11.24- `(make-threads ,n (lambda (,idx) (declare (ignorable ,idx)) ,@body)))
11.25+(defun parse-lambda-list-names (ll)
11.26+ (multiple-value-bind (idx _ args) (sb-int:parse-lambda-list ll)
11.27+ (declare (ignore idx _))
11.28+ (loop for a in args
11.29+ collect
11.30+ (etypecase a
11.31+ (atom a)
11.32+ (cons (car a))))))
11.33+
11.34+(defmacro with-threads ((n &key args) &body body)
11.35+ `(make-threads ,n (lambda (,@args) (declare (ignorable ,@(parse-lambda-list-names args))) ,@body)))
11.36
11.37 (defun finish-threads (&rest threads)
11.38 (let ((threads (flatten threads)))
11.39@@ -146,28 +158,29 @@
11.40 Before using this object you should ensure the SCOPE is fully
11.41 initialized. Supervisors should be created at any point during the
11.42 lifetime of SCOPE, but never before and never after."))
11.43-(thread-id-list)
11.44+
11.45 ;; unix-getrusage
11.46 ;; 0,-1,-2
11.47 ;; (multiple-value-list (sb-unix:unix-getrusage 0))
11.48 ;; (setf sb-unix::*on-dangerous-wait* :error)
11.49-(defvar *oracle-threads* nil)
11.50-
11.51-(defun find-oracle (id)
11.52- (declare ((unsigned-byte 32) id))
11.53- (find id *oracle-threads* :test '= :key 'oracle-id))
11.54-
11.55 (defstruct (oracle (:constructor %make-oracle (id thread)))
11.56 (id 0 :type (unsigned-byte 32) :read-only t)
11.57 (thread *current-thread* :read-only t))
11.58
11.59+(defvar *oracle-threads* nil)
11.60+
11.61+(defun find-oracle (id)
11.62+ (find id *oracle-threads* :test '= :key 'oracle-id))
11.63+
11.64 (defun make-oracle (thread)
11.65- (let ((orc (%make-oracle (sb-thread:thread-os-tid thread) thread)))
11.66- (prog1 orc
11.67- (pushnew orc *oracle-threads* :test '= :key #'oracle-id))))
11.68+ (let* ((id (thread-os-tid thread)))
11.69+ (if-let ((found (find-oracle id)))
11.70+ (values id found)
11.71+ (let ((orc (%make-oracle id thread)))
11.72+ (push orc *oracle-threads*)
11.73+ (values id orc)))))
11.74
11.75 (defgeneric designate-oracle (host guest))
11.76-
11.77 (defgeneric push-job (job pool))
11.78 (defgeneric push-task (task pool))
11.79 (defgeneric push-result (task pool))
11.80@@ -182,10 +195,10 @@
11.81 (defgeneric pop-result (pool))
11.82 (defgeneric pop-worker (pool))
11.83 (defgeneric pop-stage (pool))
11.84-
11.85 (defgeneric start-task-pool (pool))
11.86 (defgeneric pause-task-pool (pool))
11.87 (defgeneric stop-task-pool (pool))
11.88+(defgeneric restart-task-pool (pool))
11.89 (defgeneric make-task (&rest args))
11.90 (defgeneric run-job (self job))
11.91 (defgeneric run-stage (self stage))
11.92@@ -203,10 +216,15 @@
11.93 (declare (ignore pool))
11.94 (make-threads count function :name *default-worker-name*)))
11.95
11.96-(defmacro define-task-kernel (name (&key args accessors) &body body)
11.97+(defmacro parse-kernel-ops (op)
11.98+ "Parse an op of the form (NAME ARGS &BODY BODY)"
11.99+ (destructuring-bind (name args &body body) op
11.100+ `(std/macs:plambda ,args ,@body)))
11.101+
11.102+(defmacro define-task-kernel (name ops accessors &body body)
11.103 "Define a task kernel.
11.104
11.105-(define-task-kernel NAME (&key ARGS MAX MIN ACCESSORS)
11.106+(define-task-kernel NAME (&key ARGS ACCESSORS)
11.107
11.108 The kernel should process all options and return a function - the
11.109 'kernel function'.
11.110@@ -219,11 +237,12 @@
11.111 kernel via an ORACLE.
11.112
11.113 This interface is experimental and subject to change."
11.114- (declare (ignorable accessors))
11.115- `(defun ,name (,@args)
11.116- ,@body))
11.117+ (declare (ignorable accessors ops))
11.118+ `(defun ,name ()
11.119+ ,@body
11.120+ (values)))
11.121
11.122-(define-task-kernel default-task-kernel (:args () )
11.123+(define-task-kernel default-task-kernel () ()
11.124 "The default task kernel used to initialize the KERNEL slot of
11.125 task-pools.
11.126
11.127@@ -250,11 +269,22 @@
11.128 (online (make-gate :name "online" :open nil)
11.129 :type gate)
11.130 ;; TODO: test weak-vector here
11.131- (workers (make-array 0 :element-type '(unsigned-byte 32) :fill-pointer 0) :type (vector (unsigned-byte 32) *))
11.132+ (workers nil :type list)
11.133 (results (make-mailbox :name "results")))
11.134
11.135+(defmethod print-object ((self task-pool) stream)
11.136+ (print-unreadable-object (self stream :type t)
11.137+ (format stream "~A ~A :online ~A ~A:~A:~A ~A"
11.138+ (task-pool-oracle-id self)
11.139+ (task-pool-kernel self)
11.140+ (gate-open-p (task-pool-online self))
11.141+ (queue-count (task-pool-jobs self))
11.142+ (length (task-pool-stages self))
11.143+ (length (task-pool-workers self))
11.144+ (mailbox-count (task-pool-results self)))))
11.145+
11.146 (defmethod designate-oracle ((self task-pool) (guest integer))
11.147- (setf (task-pool-oracle-id self) guest)
11.148+ (setf (task-pool-oracle-id self) (make-oracle (find-thread-by-id guest)))
11.149 self)
11.150
11.151 (defmethod designate-oracle ((self task-pool) (guest thread))
11.152@@ -264,12 +294,12 @@
11.153 (oracle-thread (find-oracle (slot-value self 'oracle))))
11.154
11.155 (defmethod push-worker ((worker thread) (pool task-pool))
11.156- (vector-push (thread-os-tid worker) (task-pool-workers pool)))
11.157+ (pushnew worker (task-pool-workers pool)))
11.158
11.159 (defmethod push-workers ((threads list) (pool task-pool))
11.160 (with-slots (workers) pool
11.161 (dolist (w threads)
11.162- (vector-push (thread-os-tid w) workers))))
11.163+ (pushnew w workers))))
11.164
11.165 (defmethod make-worker-for ((pool task-pool) function &rest args)
11.166 (make-thread function :name *default-worker-name* :arguments args))
