;;; threads.lisp --- Multi-thread utilities

 ;; Threading Macros

 ;;; Commentary:

 ;; mostly yoinked from sb-thread and friends

 ;;; Code:

 (in-package :std/thread)

 ;; (sb-thread:thread-os-tid sb-thread:*current-thread*)

 ;; sb-thread:interrupt-thread

 ;;; Utils

 (defun thread-support-p () (member :thread-support *features*))

 (eval-when (:compile-toplevel)

   (defun print-top-level (msg)

     (sb-thread:make-thread

      (lambda ()

        (format #.*standard-output* msg)))

     nil))

 (defun find-thread-by-id (id)

   "Search for thread by ID which must be an u64. On success returns the thread itself or nil."

   (find id (sb-thread::list-all-threads) :test '= :key 'thread-os-tid))

 (defun find-thread (name)

   "Find a thread by name."

   (find name (sb-thread::list-all-threads) :test 'equal :key 'thread-name))

 (defun thread-key-list ()

   (sb-thread::avltree-filter #'sb-thread::avlnode-key sb-thread::*all-threads*))

 (defun thread-id-list ()

   (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*))

 (defun make-threads (n fn &key (name "thread"))

   (declare (type fixnum n))

   (loop for i below n

         collect (make-thread fn :name (format nil "~A-~D" name i))))

 (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)))

     (unwind-protect

          (mapc #'join-thread threads)

       (dolist (thread threads)

         (when (thread-alive-p thread)

           (terminate-thread thread))))))

 (defun timed-join-thread (thread timeout)

   (declare (type thread thread) (type float timeout))

   (handler-case (sb-sys:with-deadline (:seconds timeout)

                   (join-thread thread :default :aborted))

     (sb-ext:timeout ()

       :timeout)))

 (defun hang ()

   (join-thread *current-thread*))

 (defun kill-thread (thread)

   (when (thread-alive-p thread)

     (ignore-errors

       (terminate-thread thread))))

 ;; (sb-vm::primitive-object-slots (sb-vm::primitive-object 'sb-vm::thread))

 (defun init-session (&optional (thread *current-thread*)) (sb-thread::new-session thread))

 ;; (sb-thread::with-progressive-timeout (timet :seconds 4) (dotimes (i 4000) (print (timet))))

 ;; (describe sb-thread::*session*)

 ;; make-listener-thread 

 ;; with-progressive-timeout

 ;; from sb-thread

 (defun dump-thread ()

   (let* ((slots (sb-vm::primitive-object-slots #1=(sb-vm::primitive-object 'sb-vm::thread)))

          (sap (current-thread-sap))

          (thread-obj-len (sb-vm::primitive-object-length #1#))

          (names (make-array thread-obj-len :initial-element "")))

     (loop for slot across slots

           do

           (setf (aref names (sb-vm::slot-offset slot)) (sb-vm::slot-name slot)))

     (flet ((safely-read (sap offset &aux (bits (sb-vm::sap-ref-word sap offset)))

              (cond ((eql bits sb-vm:no-tls-value-marker) :no-tls-value)

                    ((eql (logand bits sb-vm:widetag-mask) sb-vm:unbound-marker-widetag) :unbound)

                    (t (sb-vm::sap-ref-lispobj sap offset))))

            (show (sym val)

              (declare (type fixnum sym))

              (let ((*print-right-margin* 128)

                    (*print-lines* 4))

                (format t " ~3d ~30a : ~s~%"

                        #+sb-thread (ash sym (- sb-vm:word-shift))

                        #-sb-thread 0

                        #+sb-thread (sb-vm:symbol-from-tls-index sym)

                        #-sb-thread sym

                        val))))

       (format t "~&TLS: (base=~x)~%" (sb-vm::sap-int sap))

       (loop for tlsindex from sb-vm:n-word-bytes below

             #+sb-thread (ash sb-vm::*free-tls-index* sb-vm:n-fixnum-tag-bits)

             #-sb-thread (ash thread-obj-len sb-vm:word-shift)

             by sb-vm:n-word-bytes

             do

          (unless (<= sb-vm::thread-allocator-histogram-slot

                      (ash tlsindex (- sb-vm:word-shift))

                      (1- sb-vm::thread-lisp-thread-slot))

            (let ((thread-slot-name

                   (if (< tlsindex (ash thread-obj-len sb-vm:word-shift))

                            (aref names (ash tlsindex (- sb-vm:word-shift))))))

                  (if (and thread-slot-name (sb-vm::neq thread-slot-name 'sb-vm::lisp-thread))

                      (format t " ~3d ~30a : #x~x~%" (ash tlsindex (- sb-vm:word-shift))

                              thread-slot-name (sb-vm::sap-ref-word sap tlsindex))

                      (let ((val (safely-read sap tlsindex)))

                        (unless (eq val :no-tls-value)

                          (show tlsindex val)))))))

       (let ((from (sb-vm::descriptor-sap sb-vm:*binding-stack-start*))

             (to (sb-vm::binding-stack-pointer-sap)))

         (format t "~%Binding stack: (depth ~d)~%"

                 (/ (sb-vm::sap- to from) (* sb-vm:binding-size sb-vm:n-word-bytes)))

         (loop

           (when (sb-vm::sap>= from to) (return))

           (let ((val (safely-read from 0))

                 (sym #+sb-thread (sb-vm::sap-ref-word from sb-vm:n-word-bytes) ; a TLS index

                      #-sb-thread (sb-vm::sap-ref-lispobj from sb-vm:n-word-bytes)))

             (show sym val))

           (setq from (sb-vm::sap+ from (* sb-vm:binding-size sb-vm:n-word-bytes))))))))

 (defun wait-for-threads (threads)

   (map 'list (lambda (thread) (sb-thread:join-thread thread :default nil)) threads)

   (not (some #'sb-thread:thread-alive-p threads)))

 (defun process-all-interrupts (&optional (thread sb-thread:*current-thread*))

   (sb-ext:wait-for (null (sb-thread::thread-interruptions thread))))