;; -*- Mode: Lisp; -*-
;; ---------------------------------------------------------------------------
;;     Title: Patch for the most advanced operation systems
;;            that cannot block with timeout
;;   Created: 2022-11-14
;;    Author: Gilbert Baumann <gilbert@bauhh.de>
;; ---------------------------------------------------------------------------
;;  (c) copyright 2022 by Gilbert Baumann

;; The most advanced operating system raises all timeouts given to any systems
;; call, be it sleep(2), poll(2), select(2), or even the Mach
;; semaphore_timedwait to 10s or even 20s. Hence all we can do is to either
;; literally poll by giving a timeout of zero, or block until eternity.

;; This happens as soon as our process turns into a GUI application.

;; Timeouts are now implemented by a polling loop. Within this loop we block
;; on the *PULSAR-SEMAPHORE*, which by a helper process is broadcast using
;; #_semaphore_signal_all approx 1000 times a second. Since sleep(2) isn't
;; working either this is accomplished by spawning a child UNIX process and
;; having a pipe to it. That child process then would write some character to
;; that pipe at 1kHz as a beacon.

;; The trick is, that a child UNIX process is not affected by this feature of
;; raising timeouts (it's not a GUI process) and it thus may sleep for 1ms
;; again.

(in-package :ccl)

(defvar *pulsar-observer* nil
  "CCL process that watches the pulsar")

(defvar *pulsar-semaphore* nil
  "A global semaphore that is supposed to be broadcast at 1kHz")

(defun start-pulsar ()
  (warn "Starting pulsar")
  (setq *pulsar-semaphore* (ccl:make-semaphore))
  ;;
  (multiple-value-bind (fd-in fd-out)
      (ccl:rlet ((fds :int 2))
        (#_pipe fds)
        (values (ccl:paref fds :int 0)
                (ccl:paref fds :int 1)))
    (when (= 0 (#_fork))
      ;; Child UNIX process
      (loop for fd below 1024           ;Hmm, what to pick here?
            do (unless (= fd fd-out) (#_close fd)))
      (ccl:rlet ((buf :char 1))
        (loop
          (let ((ret (ignoring-eintr
                       (int-errno-call (#_write fd-out buf 1)))))
            (when (/= 1 ret) (#_exit 0)))
          (#_usleep 1000))))
    (#_close fd-out)
    (setq *pulsar-observer*
          (ccl:process-run-function 
           "Pulsar Observer"
           #'(lambda (fd semaphore)
               (unwind-protect
                    (ccl:rlet ((buf :char 1000))
                      (loop
                        (#_read fd buf 1000)
                        (#_semaphore_signal_all semaphore)))
                 (setq *pulsar-observer* nil)))
           fd-in
           (ccl:%ptr-to-int (semaphore-value *pulsar-semaphore*))))))

(defun clear-pulsar ()
  (setq *pulsar-semaphore* nil))

(defun ensure-pulsar ()
  "Ensure that we have both the pulsar UNIX child process setup as
well as the observer."
  (unless *pulsar-observer*
    (start-pulsar))
  *pulsar-observer*)

(defun %poll (fds nfds milliseconds)
  "Patched poll(2) which implements timeouts with our pulsar."
  (cond ((or (null milliseconds) (< milliseconds 0))
         ;; Blocking
         (int-errno-call (#_poll fds nfds -1)))
        ((zerop milliseconds)
         ;; True polling
         (int-errno-call (#_poll fds nfds 0)))
        ((not *pulsar-semaphore*)
         (int-errno-call (#_poll fds nfds milliseconds)))
        (t
         ;; With timeout
         (let ((due (+ (get-internal-real-time)
                       (floor (* internal-time-units-per-second milliseconds)
                              1000))))
           (loop
             (let* ((res (int-errno-call (#_poll fds nfds 0))))
               (declare (fixnum res))
               (when (/= 0 res)
                 (return res)))
             (when (>= (get-internal-real-time) due)
               (return 0))
             (ccl:wait-on-semaphore *pulsar-semaphore*))))))

;; Now patch CCL internal functions which may want to block with a timeout,
;; which is not possible.
;;
;; TODO: Previously these would actually report EINTR, perhaps we do so too?

(let ((ccl:*warn-if-redefine-kernel* nil))

  (defun fd-input-available-p (fd &optional milliseconds)
    "Returns true or false depending on whether input is available.
   In some cases on windows, it may return a count of the number of unread bytes.
   This behavior should not be depended upon."
    (rlet ((pollfds (:array (:struct :pollfd) 1)))
      (setf (pref (paref pollfds (:* (:struct :pollfd)) 0) :pollfd.fd) fd
            (pref (paref pollfds (:* (:struct :pollfd)) 0) :pollfd.events) #$POLLIN)
      (let* ((res (%poll pollfds 1 (or milliseconds -1))))
        (declare (fixnum res))
        (values (> res 0) res))))

  (defun fd-ready-for-output-p (fd &optional milliseconds)
    (rlet ((pollfds (:array (:struct :pollfd) 1)))
      (setf (pref (paref pollfds (:* (:struct :pollfd)) 0) :pollfd.fd) fd
            (pref (paref pollfds (:* (:struct :pollfd)) 0) :pollfd.events) #$POLLOUT)
      (let* ((res (%poll pollfds 1 (or milliseconds -1))))
        (declare (fixnum res))
        (values (> res 0) res))))

  (defun %nanosleep (seconds nanoseconds)
    (cond ((null *pulsar-semaphore*)
           #+(and darwin-target 64-bit-target)
           (when (> seconds #x3fffffff) ;over 30 years in seconds
             (setq seconds #x3fffffff))
           (with-process-whostate ("Sleep")
             (rlet ((a :timespec)
                    (b :timespec))
               (setf (pref a :timespec.tv_sec) seconds
                     (pref a :timespec.tv_nsec) nanoseconds)
               (let* ((aptr a)
                      (bptr b))
                 (loop
                   (let* ((result (#_nanosleep aptr bptr)))
                     (declare (type (signed-byte 32) result))
                     (if (and (< result 0)
                              (eql (%get-errno) (- #$EINTR)))
                         (progn
                           ;; Some versions of OSX have a bug: if the call to #_nanosleep
                           ;; is interrupted near the time when the timeout would
                           ;; have occurred, the "remaining time" is computed as
                           ;; a negative value and, on 64-bit platforms, zero-extended.
                           #+(and darwin-target 64-bit-target)
                           (when (>= (pref bptr :timespec.tv_sec) #x80000000)
                             (return))
                           (psetq aptr bptr bptr aptr))
                         (return))))))))
          ;; CCL:PROCESS-WAIT says *NS-PER-TICK* in its loop, no need to read the
          ;; clock in this case.
          ((and (= 0 seconds) (<= nanoseconds *ns-per-tick*))
           (ccl:wait-on-semaphore *pulsar-semaphore*))
          (t
           (let ((due (+ (get-internal-real-time)
                         (+ (* seconds internal-time-units-per-second)
                            (floor (* nanoseconds internal-time-units-per-second)
                                   1000000000)))))
             (loop until (>= (get-internal-real-time) due)
                   do (ccl:wait-on-semaphore *pulsar-semaphore*))))))

  (defun %wait-on-semaphore-ptr (s seconds milliseconds &optional flag)
    (if flag
        (if (istruct-typep flag 'semaphore-notification)
            (setf (semaphore-notification.status flag) nil)
            (report-bad-arg flag 'semaphore-notification)))
    (cond ((or (null *pulsar-semaphore*)
               (and (= seconds 0) (= milliseconds 0))
               (>= seconds #xffffff))   ;Some magic value for blocking
           ;; The original code
           (without-interrupts
             (let* ((status (ff-call
                             (%kernel-import target::kernel-import-wait-on-semaphore)
                             :address s
                             :unsigned seconds
                             :unsigned milliseconds
                             :signed))
                    (result (zerop status)))     
               (declare (fixnum status))
               (when flag (setf (semaphore-notification.status flag) result))
               (values result status))))
          (t
           ;; Using the pulsar
           (let ((due (+ (get-internal-real-time)
                         (floor (* internal-time-units-per-second
                                   (+ (* 1000 seconds) milliseconds))
                                1000)))
                 (pulsar (ccl:%ptr-to-int (semaphore-value *pulsar-semaphore*))))
               (loop
                 (without-interrupts
                   (let* ((status (ff-call
                                   (%kernel-import target::kernel-import-wait-on-semaphore)
                                   :address s
                                   :unsigned 0
                                   :unsigned 0
                                   :signed)))     
                     (declare (fixnum status))
                     (cond ((zerop status)
                            (when flag (setf (semaphore-notification.status flag) t))
                            (return (values t status)))
                           ((>= (get-internal-real-time) due)
                            (when flag (setf (semaphore-notification.status flag) nil))
                            (return (values nil status))))))
                 (#_semaphore_wait pulsar))))))
)

(setf *lisp-startup-functions*
      (append (remove 'clear-pulsar *lisp-startup-functions*)
              (list 'clear-pulsar)))