From 30a881caebd676e9bafae6844df8328ea086c25b Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Thu, 1 Jan 1998 17:20:35 +0000
Subject: [PATCH] Fix a bug in the scrubbing of the current stack-group's
 eval-stack. Update the eval-stack for the current stack-group when scrubbing
 to ensuring that the stack-top is valid and maybe flush an old stored vector.

Completely scrub the stored binding stack for the current stack group.

Implement the lock waiting in a separate function rather than
inlining. This ensures that the wait predicate is fast native code so
that locking in byte-compiled and interpreted code doesn't slow the
scheduler.
---
 code/multi-proc.lisp | 57 +++++++++++++++++++++++++++++++++++---------
 1 file changed, 46 insertions(+), 11 deletions(-)

diff --git a/code/multi-proc.lisp b/code/multi-proc.lisp
index 9b3cee9f5..32b8e061e 100644
--- a/code/multi-proc.lisp
+++ b/code/multi-proc.lisp
@@ -3,7 +3,7 @@
 ;;; This code was written by Douglas T. Crosher and has been placed in
 ;;; the Public domain, and is provided 'as is'.
 ;;;
-;;; $Id: multi-proc.lisp,v 1.14 1997/12/31 18:05:45 dtc Exp $
+;;; $Id: multi-proc.lisp,v 1.15 1998/01/01 17:20:35 dtc Exp $
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -319,13 +319,26 @@
   ;; Binding stack.
   (let ((binding-save-stack (stack-group-binding-stack stack-group)))
     (when binding-save-stack
-      (let ((size (stack-group-binding-stack-size stack-group))
+      (let ((size
+	     ;; The stored binding stack for the current stack group
+	     ;; can be completely scrubbed.
+	     (if (eq stack-group *current-stack-group*)
+		 0
+		 (stack-group-binding-stack-size stack-group)))
 	    (len (length binding-save-stack)))
 	;; Scrub the remainder of the binding stack.
 	(do ((index size (+ index 1)))
 	    ((>= index len))
 	  (declare (type (unsigned-byte 29) index))
 	  (setf (aref binding-save-stack index) 0)))))
+  ;; If this is the current stack group then update the stored
+  ;; eval-stack and eval-stack-top before scrubbing.
+  (when (eq stack-group *current-stack-group*)
+    ;; Updare the stored vector, flushing an old vector if a new one
+    ;; has been allocated.
+    (setf (stack-group-eval-stack stack-group) lisp::*eval-stack*)
+    ;; Ensure that the stack-top is valid.
+    (setf (stack-group-eval-stack-top stack-group) lisp::*eval-stack-top*))
   ;; Scrub the eval stack.
   (let ((eval-stack (stack-group-eval-stack stack-group)))
     (when eval-stack
@@ -1294,7 +1307,10 @@
 ;;; Show-Processes
 ;;;
 (defun show-processes (&optional verbose)
+  (fresh-line)
   (dolist (process *all-processes*)
+    (when (eq process *current-process*)
+      (format t "* "))
     (format t "~s ~s ~a~%" process (process-whostate process) 
 	    (process-state process))
     (when verbose
@@ -1317,13 +1333,35 @@
   (name nil)
   (process nil :type (or null process)))
 
+;;; Lock-Wait
+;;;
+;;; Wait for the lock to be free and acquire it for the
+;;; *current-process*. Handled here as a function rather than inlining
+;;; to ensure that the process-wait predicate is fast native code and
+;;; that locks in byte compiled code don't slow the scheduler.
+;;;
+(defun lock-wait (lock whostate)
+  (declare (type lock lock))
+  (process-wait whostate
+		#'(lambda ()
+		    (declare (optimize (speed 3)))
+		    #-i486
+		    (unless (lock-process lock)
+		      (setf (lock-process lock) *current-process*))
+		    #+i486
+		    (null (kernel:%instance-set-conditional
+			   lock 2 nil *current-process*)))))
+
 #-i486
 (defun seize-lock (lock)
-  (declare (type lock lock))
+  (declare (type lock lock)
+	   (optimize (speed 3)))
   (sys:without-interrupts
    (unless (lock-process lock)
      (setf (lock-process lock) *current-process*))))
 
+;;; With-Lock-Held
+;;;
 #-i486
 (defmacro with-lock-held ((lock &optional (whostate "Waiting for lock"))
 			  &body body)
@@ -1333,16 +1371,16 @@
 	   (progn
 	     (unless (or (eq ,orig-process *current-process*)
 			 (seize-lock ,lock))
-	       (process-wait ,whostate
-		     #'(lambda ()
-			 (unless (lock-process ,lock)
-			   (setf (lock-process ,lock) *current-process*)))))
+	       (lock-wait ,lock ,whostate))
 	     ,@body)
 	(unless (or (eq ,orig-process *current-process*)
 		    (not (eq (lock-process ,lock) *current-process*)))
 	  (setf (lock-process ,lock) nil))))))
 
+;;; With-Lock-Held
+;;;
 ;;; Fast locking for the i486 and above.
+;;;
 #+i486
 (defmacro with-lock-held ((lock &optional (whostate "Waiting for lock"))
 			  &body body)
@@ -1353,10 +1391,7 @@
 	     (unless (or (eq ,orig-process *current-process*)
 			 (null (kernel:%instance-set-conditional
 				,lock 2 nil *current-process*)))
-	       (process-wait ,whostate
-			     #'(lambda ()
-				 (null (kernel:%instance-set-conditional
-					,lock 2 nil *current-process*)))))
+	       (lock-wait ,lock ,whostate))
 	     ,@body)
 	(unless (eq ,orig-process *current-process*)
 	  (kernel:%instance-set-conditional ,lock 2 *current-process* nil))))))
-- 
GitLab