(in-package :clim-sys-internals)

(defvar *pid* (sb-thread::current-thread-id))
(defvar *konses* nil)
  
(defstruct (process
             (:constructor %make-process)
             (:predicate processp))
  name
  state
  whostate
  function
  id)

(defvar *current-process*
  (%make-process :name "initial process" :function nil))

(defun make-process (function &key (name "anonymous"))
  (let ((p (%make-process :name name)))
    (setf (process-id p)
          (sb-thread:make-thread
           (lambda ()
             (let ((*current-process* p)
                   (*pid* (sb-thread::current-thread-id))
                   (*konses* nil))
               (funcall function)))))
    p))

(defun current-process ()
  *current-process*)

#-CLIM-SYS-INTERNAL::USE-WAITQUEUE
(progn

;;;; Spin Locks

  (defstruct spin-lock
    (spin 0))   ; 0 means free, otherwise the pid is entered

  (declaim (inline current-thread-id))
  (defun current-thread-id ()
    *pid*)

  (defun acquire-spin-lock (spin-lock)
    (declare (optimize (speed 3) (safety 0)))
    (loop until
        (eql (sb-vm::%instance-set-conditional
              spin-lock 
              #|offset|#    1
              #|old value|# 0
              #|new value|# (current-thread-id))
             0)
      do (sleep 0) ))

  (defun release-spin-lock (spin-lock)
    (declare (type spin-lock spin-lock))
    (setf (spin-lock-spin spin-lock) 0))

  (defmacro with-spin-lock ((lock-form) &body body)
    (let ((lock (gensym ".LOCK.")))
      `(let ((,lock ,lock-form))
        (unwind-protect
             (progn
               (acquire-spin-lock ,lock)
               (locally ,@body))
          (release-spin-lock ,lock)))))

;;;; Waiting and Wakeup

;; We provide two alternative implementations

  #+CLIM-SYS-INTERNALS::USE-PIPES
  (progn
    (defvar *thread-pipes*
      (make-hash-table :test #'eq))

    (defvar *thread-pipes-spin* (make-spin-lock))

    (defun thread-pipe (pid)
      (with-spin-lock (*thread-pipes-spin*)
        (or (gethash pid *thread-pipes*)
            (setf (gethash pid *thread-pipes*)
                  (make-thread-pipe)))))
  
    (defun make-thread-pipe ()
      (multiple-value-list (sb-unix:unix-pipe)))
  
    (defvar *scratch-buf* (SB-SYS:ALLOCATE-SYSTEM-MEMORY 1))
  
    (defun prepare-wait ()
      )
    
    (defun wait ()
      (sb-unix:unix-read (first (thread-pipe (current-thread-id)))
                         *scratch-buf*
                         1))
  
    (defun wakeup (pid)
      (sb-unix:unix-write (second (thread-pipe pid))
                          *scratch-buf* 0 1))
    )

  #-CLIM-SYS-INTERNALS::USE-PIPES
  (progn
    (defun prepare-wait ()
      (sb-thread::block-sigcont))
    
    (defun wait ()
      (sb-thread::unblock-sigcont-and-sleep))

    (defun wakeup (pid)
      (sb-unix:unix-kill pid :sigcont)) )

;;;; Regular Locks

;; Note: Our locks are always recursive.

  (defstruct (queue (:include spin-lock))
    (queue nil))

  (declaim (inline queue-push queue-pop))

  (defun kons (x y)
    (let ((r (pop *konses*)))
      (if r
          (progn (setf (car r) x (cdr r) y) r)
          (cons x y))))

  (defun snok (cell)
    (push cell *konses*))

  #+NIL
  (progn
    (defun queue-push (queue)
      (declare (type queue queue))
      (let ((p (current-thread-id))
            (q (queue-queue queue)))
        (cond ((null q)
               (setf (queue-queue queue) p))
              ((atom q)
               (setf (queue-queue queue) (cons p (cons q nil))))
              (t
               (setf (queue-queue queue) (cons p q))))))

    (defun queue-pop (queue)
      (declare (type queue queue))
      (let ((p (queue-queue queue)))
        (cond ((atom p)
               (setf (queue-queue queue) nil)
               p)
              (t
               (setf (queue-queue queue) (cdr (queue-queue queue)))
               (car p))))) )

  #-NIL
  (progn
    (defun queue-push (queue)
      (declare (type queue queue))
      (push (current-thread-id) (queue-queue queue)))

    (defun queue-pop (queue)
      (declare (type queue queue))
      (pop (queue-queue queue))))

  #+NIL
  (progn
    (defun queue-push (queue)
      (declare (type queue queue))
      (setf (queue-queue queue)
            (kons (current-thread-id)
                  (queue-queue queue))))

    (defun queue-pop (queue)
      (declare (type queue queue))
      (let ((x (queue-queue queue)))
        (if (consp x)
            (progn
              (snok x)
              (setf (queue-queue queue) (cdr x))
              (car x))
            nil))))

;;;

  (defstruct (lock (:include queue))
    name
    (lock-count 0) ;how many times this was acquired
    (holder nil))

  (defun acquire-lock (lock)
    (loop
        (acquire-spin-lock lock)
        (cond ((null (lock-holder lock))
               ;; this one is free, just acquire it.
               (incf (lock-lock-count lock))
               (setf (lock-holder lock) (current-thread-id))
               (release-spin-lock lock)
               (return))
              ((eql (lock-holder lock) (current-thread-id))
               (incf (lock-lock-count lock))
               (release-spin-lock lock)
               (return))
              (t
               ;; Holded by somebody else, just put us on the queue
               (prepare-wait)
               (queue-push lock)
               (release-spin-lock lock)
               (wait)))))

  (defun release-lock (lock)
    (acquire-spin-lock lock)
    (decf (lock-lock-count lock))
    (when (zerop (lock-lock-count lock))
      (setf (lock-holder lock) nil) ;it's free now
      (let ((p (queue-pop lock)))
        (release-spin-lock lock) ;<-- hope this is safe ...
        (when p
          ;; somebody is waiting
          (wakeup p))))
    #+NIL(release-spin-lock lock))

  (defmacro with-lock-held ((lock-form) &body body)
    (let ((lock (gensym ".LOCK.")))
      `(let ((,lock ,lock-form))
        (unwind-protect
             (progn
               (acquire-lock ,lock)
               (locally ,@body))
          (release-lock ,lock)))))

  (defmacro with-recursive-lock-held ((lock-form) &body body)
    `(with-lock-held (,lock-form) ,@body))

  (defun make-recursive-lock (&key name)
    (make-lock :name name))

;;;; condition variables

  (defstruct (condition-variable (:include queue))
    )

  (defun condition-notify (cv)
    (let ((p (queue-pop cv)))
      (cond ((null p)
             (warn "~S without somebody waiting, Eh?"
                   'CONDITION-NOTIFY))
            (t
             (wakeup p)))))

  (defun condition-wait (cv lock)
    (queue-push cv)
    (prepare-wait)
    (release-lock lock)
    (wait)
    (acquire-lock lock)) )

;;;;;

#+CLIM-SYS-INTERNALS::USE-WAITQUEUE
(progn  
  (defun make-lock (&optional name)
    (sb-thread:make-mutex :name name))

  (defmacro with-lock-held ((place &optional state) &body body)
    (let ((old-state (gensym "OLD-STATE")))
      `(let (,old-state)
        (unwind-protect
             (progn
               (sb-thread:get-mutex ,place)
               (when ,state
                 (setf ,old-state (process-state *current-process*))
                 (setf (process-state *current-process*) ,state))
               ,@body)
          (setf (process-state *current-process*) ,old-state)
          (sb-thread::release-mutex ,place)))))

  (defun make-recursive-lock (&optional name)
    (sb-thread:make-mutex :name name))

  (defmacro with-recursive-lock-held ((place &optional state) &body body)
    (let ((old-state (gensym "OLD-STATE")))
      `(sb-thread:with-recursive-lock (,place)
        (let (,old-state)
          (unwind-protect
               (progn
                 (when ,state
                   (setf ,old-state (process-state *current-process*))
                   (setf (process-state *current-process*) ,state))
                 ,@body)
            (setf (process-state *current-process*) ,old-state))))))

  (defun make-condition-variable ()
    (sb-thread:make-waitqueue))

  (defun condition-wait (condition-variable lock)
    (sb-thread:condition-wait condition-variable lock))

  (defun condition-notify (condition-variable)
    (sb-thread:condition-notify condition-variable)))