<commit_before>(in-package :sys.int)

(defvar *scheduler-stack-group* nil)
(defvar *current-process* nil)
(defvar *run-queue* nil)

(defstruct (process
             (:constructor %make-process))
  name
  (run-reasons '())
  (arrest-reasons '())
  (wait-function (constantly 'nil))
  (wait-argument-list '())
  (whostate '())
  (initial-form nil)
  stack-group
  next prev)

(defmethod print-object ((object process) stream)
  (print-unreadable-object (object stream :type t :identity t)
    (format stream "~A" (process-name object))))

(defun process-preset (process function &rest arguments)
  (setf (process-initial-form process) (cons function arguments))
  (process-reset process))

(defun process-reset (process)
  (setf (process-wait-function process) nil
	(process-wait-argument-list process) nil)
  (stack-group-preset (process-stack-group process)
                      (lambda ()
                        (with-simple-restart (abort "Terminate process ~S." (process-name process))
                          (apply (first (process-initial-form process))
                                 (rest (process-initial-form process))))
                        (process-disable process)
                        (switch-to-stack-group *scheduler-stack-group* t))))

(defun process-run-reason (process object)
  (pushnew object (process-run-reasons process))
  (process-consider-runnability process))

(defun process-revoke-run-reason (process object)
  (setf (process-run-reasons process) (remove object (process-run-reasons process)))
  (process-consider-runnability process))

(defun process-arrest-reason (process object)
  (pushnew object (process-arrest-reasons process))
  (process-consider-runnability process))

(defun process-revoke-arrest-reason (process object)
  (setf (process-run-reasons process) (remove object (process-arrest-reasons process)))
  (process-consider-runnability process))

(defun process-wait (reason function &rest arguments)
  (declare (dynamic-extent arguments))
  (if (and *current-process*
	   *scheduler-stack-group*
	   (not (eql (stack-group-state *scheduler-stack-group*) :active)))
      (progn
	(setf (process-whostate *current-process*) reason
	      (process-wait-function *current-process*) function
	      (process-wait-argument-list *current-process*) arguments)
	(switch-to-stack-group *scheduler-stack-group*))
      (do ()
	  ((apply function arguments))
	(%hlt))))

;; todo, Fix this...
(defun process-wait-with-timeout (reason timeout function &rest arguments)
  (declare (dynamic-extent arguments))
  (cond (timeout
         (process-wait reason (lambda ()
                                (if (<= (decf timeout) 0)
                                    t
                                    (apply function arguments))))
         (<= timeout 0))
        (t (apply #'process-wait reason function arguments)
           t)))

(defun process-consider-runnability (process)
  (cond ((or (process-arrest-reasons process)
	     (null (process-run-reasons process)))
         (when (process-next process)
           (when (eql *run-queue* process)
             (setf *run-queue* (if (eql (process-next process) process)
                                   nil
                                   (process-next process))))
           (psetf (process-next (process-prev process)) (process-next process)
                  (process-prev (process-next process)) (process-prev process))
           (setf (process-next process) nil
                 (process-prev process) nil)))
        ;; Already on run queue.
        ((process-next process))
	(*run-queue*
         ;; Run queue not empty, add to list.
         (setf (process-next process) *run-queue*
               (process-prev process) (process-prev *run-queue*))
         (setf (process-next (process-prev *run-queue*)) process
               (process-prev *run-queue*) process))
        (t ;; Run queue empty, add as the only entry.
         (setf (process-next process) process
               (process-prev process) process
               *run-queue* process))))

(defun process-enable (process)
  (process-disable process)
  (process-run-reason process :enable))

(defun process-reset-and-enable (process)
  (process-reset process)
  (process-enable process))

(defun process-disable (process)
  (setf (process-run-reasons process) nil
	(process-arrest-reasons process) nil)
  (process-consider-runnability process))

(defun get-next-process ()
  (when *run-queue*
    (loop with start = *run-queue*
       with proc = start
       do (let ((wait-fn (process-wait-function proc))
                (wait-args (process-wait-argument-list proc)))
            (when (or (null wait-fn) (apply wait-fn wait-args))
              (setf (process-wait-function proc) nil
                    (process-wait-argument-list proc) nil)
              (setf *run-queue* (process-next proc))
              (return proc)))
         (setf proc (process-next proc))
         (when (eql proc start) (return)))))

;;; FIXME: Running for so long with interrupts disabled is lame.
;;; Probably need to speed this up somehow.
(defun process-scheduler ()
  (let ((*terminal-io* *terminal-io*)
        (*standard-output* *standard-output*)
        (*standard-input* *standard-input*)
        (*debug-io* *debug-io*)
        (*query-io* *query-io*)
        (*error-output* *error-output*))
    (loop
       (%cli)
       (let ((next-process (get-next-process)))
         (setf *current-process* next-process)
         (cond (next-process
                (switch-to-stack-group (process-stack-group next-process)))
               (t (%stihlt)))))))

(defun make-process (name &key
                            control-stack-size
                            binding-stack-size
                            run-reasons
                            arrest-reasons
                            whostate)
  (let* ((stack-group (make-stack-group name
                                        :control-stack-size control-stack-size
                                        :binding-stack-size binding-stack-size))
         (process (%make-process :name name
                                 :stack-group stack-group
                                 :run-reasons run-reasons
                                 :arrest-reasons arrest-reasons
                                 :whostate whostate)))
    (process-consider-runnability process)
    process))

(defmacro with-process ((name function &rest arguments) &body body)
  (let ((x (gensym)))
    `(let ((,x (make-process ,name)))
       (unwind-protect (progn
                         (sys.int::process-preset ,x ,function ,@arguments)
                         (sys.int::process-enable ,x)
                         ,@body)
         (sys.int::process-disable ,x)))))

(setf *scheduler-stack-group* (make-stack-group "scheduler"
                                                :interruptable nil))
(stack-group-preset *scheduler-stack-group* #'process-scheduler)
(setf *current-process* (%make-process :name "Initial Process"
                                       :stack-group (current-stack-group)
                                       :run-reasons '(:initial)
                                       :whostate "RUN"))
(process-consider-runnability *current-process*)

(defconstant +spinlocked-locked-value+ 0)
(defconstant +spinlocked-unlocked-value+ 1)

;(defun (cas foo) (old new args)

(defmacro compare-and-swap (place old new)
  (unless (and (consp place)
               (eql (length place) 2)
               (symbolp (first place)))
    (error "Bad CAS place ~S." place))
  (let ((info (get (first place) 'structure-cas))
        (sym (gensym)))
    (when (not info)
      (error "Bad CAS place ~S." place))
    `(let ((,sym ,(second place)))<commit_msg>Eliminate the scheduler stack group.<commit_after>(in-package :sys.int)

(defvar *current-process* nil)
(defvar *idle-process* nil)
(defvar *run-queue* nil)

(defstruct (process
             (:constructor %make-process))
  name
  (run-reasons '())
  (arrest-reasons '())
  (wait-function (constantly 'nil))
  (wait-argument-list '())
  (whostate '())
  (initial-form nil)
  stack-group
  next prev)

(defmethod print-object ((object process) stream)
  (print-unreadable-object (object stream :type t :identity t)
    (format stream "~A" (process-name object))))

(defun process-preset (process function &rest arguments)
  (setf (process-initial-form process) (cons function arguments))
  (process-reset process))

(defun process-reset (process)
  (setf (process-wait-function process) nil
	(process-wait-argument-list process) nil)
  (stack-group-preset (process-stack-group process)
                      (lambda ()
                        (with-simple-restart (abort "Terminate process ~S." (process-name process))
                          (apply (first (process-initial-form process))
                                 (rest (process-initial-form process))))
                        (process-disable process)
                        (process-yield))))

(defun process-run-reason (process object)
  (pushnew object (process-run-reasons process))
  (process-consider-runnability process))

(defun process-revoke-run-reason (process object)
  (setf (process-run-reasons process) (remove object (process-run-reasons process)))
  (process-consider-runnability process))

(defun process-arrest-reason (process object)
  (pushnew object (process-arrest-reasons process))
  (process-consider-runnability process))

(defun process-revoke-arrest-reason (process object)
  (setf (process-run-reasons process) (remove object (process-arrest-reasons process)))
  (process-consider-runnability process))

(defun process-wait (reason function &rest arguments)
  (declare (dynamic-extent arguments))
  (setf (process-whostate *current-process*) reason
        (process-wait-function *current-process*) function
        (process-wait-argument-list *current-process*) arguments)
  (process-yield))

;; todo, Fix this...
(defun process-wait-with-timeout (reason timeout function &rest arguments)
  (declare (dynamic-extent arguments))
  (cond (timeout
         (process-wait reason (lambda ()
                                (if (<= (decf timeout) 0)
                                    t
                                    (apply function arguments))))
         (<= timeout 0))
        (t (apply #'process-wait reason function arguments)
           t)))

(defun process-consider-runnability (process)
  (cond ((or (process-arrest-reasons process)
	     (null (process-run-reasons process)))
         (when (process-next process)
           (when (eql *run-queue* process)
             (setf *run-queue* (if (eql (process-next process) process)
                                   nil
                                   (process-next process))))
           (psetf (process-next (process-prev process)) (process-next process)
                  (process-prev (process-next process)) (process-prev process))
           (setf (process-next process) nil
                 (process-prev process) nil)))
        ;; Already on run queue.
        ((process-next process))
	(*run-queue*
         ;; Run queue not empty, add to list.
         (setf (process-next process) *run-queue*
               (process-prev process) (process-prev *run-queue*))
         (setf (process-next (process-prev *run-queue*)) process
               (process-prev *run-queue*) process))
        (t ;; Run queue empty, add as the only entry.
         (setf (process-next process) process
               (process-prev process) process
               *run-queue* process))))

(defun process-enable (process)
  (process-disable process)
  (process-run-reason process :enable))

(defun process-reset-and-enable (process)
  (process-reset process)
  (process-enable process))

(defun process-disable (process)
  (setf (process-run-reasons process) nil
	(process-arrest-reasons process) nil)
  (process-consider-runnability process))

(defun get-next-process ()
  (when *run-queue*
    (loop with start = *run-queue*
       with proc = start
       do (let ((wait-fn (process-wait-function proc))
                (wait-args (process-wait-argument-list proc)))
            (when (or (null wait-fn) (apply wait-fn wait-args))
              (setf (process-wait-function proc) nil
                    (process-wait-argument-list proc) nil)
              (setf *run-queue* (process-next proc))
              (return proc)))
         (setf proc (process-next proc))
         (when (eql proc start) (return)))))

(defun process-yield ()
  (with-interrupts-disabled ()
    (let ((next-process (or (get-next-process)
                            *idle-process*)))
      (unless (eql next-process *current-process*)
        (setf *current-process* next-process)
        (switch-to-stack-group (process-stack-group next-process))))))

(defun idle-process ()
  (%cli)
  (loop
     (let ((next-process (get-next-process)))
       (cond (next-process
              (setf *current-process* next-process)
              (switch-to-stack-group (process-stack-group next-process)))
             (t (%stihlt))))))

(defun make-process (name &key
                            control-stack-size
                            binding-stack-size
                            run-reasons
                            arrest-reasons
                            whostate)
  (let* ((stack-group (make-stack-group name
                                        :control-stack-size control-stack-size
                                        :binding-stack-size binding-stack-size))
         (process (%make-process :name name
                                 :stack-group stack-group
                                 :run-reasons run-reasons
                                 :arrest-reasons arrest-reasons
                                 :whostate whostate)))
    (process-consider-runnability process)
    process))

(defmacro with-process ((name function &rest arguments) &body body)
  (let ((x (gensym)))
    `(let ((,x (make-process ,name)))
       (unwind-protect (progn
                         (sys.int::process-preset ,x ,function ,@arguments)
                         (sys.int::process-enable ,x)
                         ,@body)
         (sys.int::process-disable ,x)))))

(setf *current-process* (%make-process :name "Initial Process"
                                       :stack-group (current-stack-group)
                                       :run-reasons '(:initial)
                                       :whostate "RUN"))
(process-consider-runnability *current-process*)

(setf *idle-process* (make-process "Idle"))
(process-preset *idle-process* #'idle-process)

(defconstant +spinlocked-locked-value+ 0)
(defconstant +spinlocked-unlocked-value+ 1)

;(defun (cas foo) (old new args)

(defmacro compare-and-swap (place old new)
  (unless (and (consp place)
               (eql (length place) 2)
               (symbolp (first place)))
    (error "Bad CAS place ~S." place))
  (let ((info (get (first place) 'structure-cas))
        (sym (gensym)))
    (when (not info)
      (error "Bad CAS place ~S." place))
    `(let ((,sym ,(second place)))
{'fraction_non_alphanumeric': 0.12954395241242564, 'fraction_numerical': 0.0006609385327164573, 'mean_word_length': 2.080415309446254, 'pattern_counts': {'":': 0, '<': 7, '<?xml version=': 0, '>': 3, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 32, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '6760983', 'n_tokens_mistral': 4332, 'n_tokens_neox': 4214, 'n_words': 1091}