;;-*- mode: lisp; package: ccl -*-
;;
;; Attempts to work around RMCL crashing when starting a new process outside the event handler.
;; Note that this is in no way a fix, and may negatively impact the responsiveness of the event handler.
;;
;; Terje Norderhaug <terje@in-progress.com>, July 2009. 
;; Public domain, no copyright nor warranty. Use as you please and at your own risk.
;;
;; Exploits that new processes seem to consistently start in the event handler without causing crashes.
;; For more about the issue, see the July 2009 discussion on the info-mcl mailing list.
;;
;; Tested on RMCL


(in-package :ccl)

(defparameter *safe-process-run-function-wait* (* 3 60)
  "Ticks to wait before safe-process-run-function returns NIL if a new process hasn't been created (bind to NIL for no wait)")

(defun safe-process-run-function (name-or-keywords function &rest args)
  "Same as process-run-function, but works around the RMCL problem with crashes when starting new processes outside the event handler"
  (let* ((name-or-keywords 
          (if (listp name-or-keywords)
            (copy-list name-or-keywords)
            name-or-keywords))
         (args (copy-list args))
         (hook nil)
         (process nil)
         (condition nil))
    (flet ((hook ()
             (handler-case
               (progn
                 (assert (memq hook *eventhook*))
                 (setq *eventhook* (delete hook *eventhook* :test #'eq))
                 (assert (or (eq *current-process* *event-processor*)
                             (eq *current-process* *initial-process*)
                             *processing-events*))
                 (setf process (apply #'process-run-function name-or-keywords function args)))
               (error (c)
                      (setf condition c)))
             nil))
      (setf hook #'hook))
    (without-interrupts
     (setq *eventhook*
           (cons hook 
                 (if (listp *eventhook*) *eventhook* (list *eventhook*))))
     (setq *event-wakeup* t))
    (when *safe-process-run-function-wait*
      (process-wait-with-timeout "starting" *safe-process-run-function-wait*
                                 (lambda () (or process condition)))
      (when condition
        (error condition))
      process)))

#+rmcl
(advise process-run-function
        (if (or (eq *current-process* *event-processor*)
                (eq *current-process* *initial-process*)
                #+ignore *processing-events*)
          (:do-it)
          (apply #'safe-process-run-function arglist))
        :when :around :name use-safe-process-run-function)