MACL and background cycles (fwd)

[bill@cambridge.apple.com (Bill St. Clair)]

   From: gz@cambridge.apple.com (Gail Zacharias)
   Date: Tue, 24 Jul 90 10:44:29 EDT
   X-Mailer: ELM [version 2.2 PL16]

   Forwarded message:

   >From war@skinner Mon Jul 23 16:33:43 1990
   Date: Mon, 23 Jul 90 09:34:38 -0700
   From: "walter elliott trhrhea" <war@skinner.cs.uoregon.edu>
   Message-Id: <9007231634.AA28960@skinner.cs.uoregon.edu>
   To: info-macl-request@cambridge.apple.com
   Subject: MACL and background cycles

   I have a XCMD numerical simulation running in a SuperCard window
   That slows down about 50% when ACL 1.3.2 or any standalones created
   by ot are backgrounded. How do I get MACL to stop robbimg the fore ground
   task of these cycles. Tahnks much...


The problem is that MACL calls _WaitNextEvent with a sleep count of 0
even when it is in the background.  Lisp 2.0 will include a parameter
to allow you to tune this behavior.  The following is a patch I wrote
a few months back to add this feature to 1.3.  I have also put this in
our (cambridge.apple.com) anonymous FTP directory as
/pub/MACL/CONTRIB/background-sleep.lisp.

Bill

---------------------------------------------------------------------------

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; background-sleep.lisp
;;;
;;; Patch to make MACL
;;; sleep while in the background
;;;
(eval-when (eval compile)
  (require 'records)
  (require 'traps))

(defparameter *lisp-version* (lisp-implementation-version))

; If this errors out, do the disassembly below to determine the value of
; *foreground*-offset for your Lisp, and remove the ERROR call.
(pushnew (cond ((search "1.3.2" *lisp-version*) :ccl-1.3.2)
               ((search "1.3.1" *lisp-version*) :ccl-1.3.1)
               ((search "1.2.2" *lisp-version*) :ccl-1.2.2)
               (t (error "Unknown lisp version")))
         *features*)
(when (search "1.3" *lisp-version*) 
  (pushnew :CCL-1.3 *features*))

; Setting *foreground-sleep-ticks* to anything other than 0 will prevent
; the scrap from being made external when the Lisp is suspended.  E.g. you
; won't be able to copy from Lisp to another application.
(defparameter *foreground-sleep-ticks* 0)
(defparameter *background-sleep-ticks* 5)

; You should set *background-event-ticks* higher than *background-sleep-ticks*
; or your Lisp won't run much when it's in the background.  Here's the default
; value that goes with a *background-sleep-ticks* of 5.  It will cause the
; lisp to run for 5 ticks and sleep for 5 ticks.
#+:ccl-1.3(setq *background-event-ticks* 10)

; Note - This value for *foreground*-offset may be different in your Lisp.
; To find the correct value:
;     (dissassemble 'event-dispatch)
; You should see something like this:
;     (46 JSR_SUBPRIM $MVEXPECTN)
;     (50 MOVE.L (A5 -5984) A0)
;     (54 MOVE.W ($ 65535) @A0)
;     (58 TST.L (A5 -5988))          <==== Here's the number you want
;     (62 BEQ.S (LABEL 178))
;     (64 MOVE.L (IMMINT 330) A0)
(defparameter *foreground*-offset
 #+:CCL-1.3.1 -5984
 #+:CCL-1.3.2 -5988
 #+:CCL-1.2.2 -5992)
 (defconstant $CurrentA5 #x904)

(defun foreground ()
  (let ((ptr (%int-to-ptr (+ (%get-long (%int-to-ptr $currentA5))
                             *foreground*-offset))))
    (%get-ptr ptr)))

(defun set-foreground (value)
  (let ((ptr (%int-to-ptr (+ (%get-long (%int-to-ptr $currentA5))
                             *foreground*-offset))))
    (%put-ptr ptr value))
  value)

(defconstant $app4Evt 15)
(defconstant $app4Mask -32768)
(defconstant $evtMessage 2)
(defconstant $evtMessage-b (+ $evtMessage 3))

(defun hilite-window (window hilite)
  (declare (object-variable wptr))
  #-:CCL-1.3 (declare (ignore window hilite))
  #+:CCL-1.3
  (_HiliteWindow :ptr (ask window wptr) :word (if hilite -1 0)))

#-:CCL-1.3
(progn
(defvar *foreground-event-ticks* 20)
(defvar *background-event-ticks* 5)
)

(defun sleep-eventhook ()
  (let ((sleep-ticks (if (foreground)
                       *foreground-sleep-ticks*
                       *background-sleep-ticks*)))
    (unless (eql sleep-ticks 0)
      (rlet ((event :event))
        (_WaitNextEvent :word $app4Mask :ptr event :long sleep-ticks :long 0 :word)
        ; Need to process suspend and resume.
        ; (this can fairly be called a MultiFinder bug, I think).
        (when (eq (%get-word event) $app4Evt)
          (when (eq 1 (%get-byte event $evtMessage))   ; suspend or resume event
            (let ((window (front-window)))
              (if (set-foreground (ccl::%ilogbitp 0 (%get-byte event $evtMessage-b)))
                ; Resume
                (progn
                  (set-event-ticks *foreground-event-ticks*)
                  (if window (hilite-window window t)))
              ; Suspend
                (progn
                  (set-event-ticks *background-event-ticks*)
                  (if window (hilite-window window nil))
                  ;(put-external-scrap)     ; block-compiled away
                ))))))))
  nil)

(defvar *eventhook-list* nil)
(defun eventhook-list ()
  (dolist (hook *eventhook-list* nil)
    (if (funcall hook) (return t))))
(pushnew 'sleep-eventhook *eventhook-list*)
(unless (eq *eventhook* 'eventhook-list)
  (setq *eventhook* 'eventhook-list))