From 3f423c215dc997099e1e55bc2044202035f3bae4 Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Sat, 13 Mar 1999 15:13:02 +0000
Subject: [PATCH] Initialise the *current-process* to dummy startup process so
 that locks will work even if multi-processing is not initialised.

---
 code/multi-proc.lisp | 78 +++++++++++++++++++++++---------------------
 1 file changed, 41 insertions(+), 37 deletions(-)

diff --git a/code/multi-proc.lisp b/code/multi-proc.lisp
index 38634dc39..27c5942bb 100644
--- a/code/multi-proc.lisp
+++ b/code/multi-proc.lisp
@@ -5,7 +5,7 @@
 ;;; the Public domain, and is provided 'as is'.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/multi-proc.lisp,v 1.33 1999/03/06 03:42:40 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/multi-proc.lisp,v 1.34 1999/03/13 15:13:02 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -769,8 +769,11 @@
   (let ((state (process-state process)))
     (or (eq state :active) (eq state :inactive))))
 
-(declaim (type (or null process) *current-process*))
-(defvar *current-process* nil)
+;;; A dummy initial process is defined so that locks will work before
+;;; multi-processing has been started.
+(declaim (type process *current-process*))
+(defvar *current-process*
+  (%make-process :name "Startup" :state :inactive :stack-group nil))
 
 ;;; Current-Process  --  Public
 ;;;
@@ -1103,40 +1106,41 @@
   chance to unwinding, before shutting down multi-processing. This is
   currently necessary before a purify and is performed before a save-lisp.
   Multi-processing can be restarted by calling init-multi-processing."
-  (assert (eq *current-process* *initial-process*) ()
-	  "Only the *initial-process* can shutdown multi-processing")
-
-  (let ((destroyed-processes nil))
-    (do ((cnt 0 (1+ cnt)))
-	((> cnt 10))
-      (declare (type kernel:index cnt))
-      (dolist (process *all-processes*)
-	(when (and (not (eq process *current-process*))
-		   (process-active-p process)
-		   (not (member process destroyed-processes)))
-	  (destroy-process process)
-	  (push process destroyed-processes)))
-      (unless (rest *all-processes*)
-	(return))
-      (format t "Destroyed ~d process~:P; remaining ~d~%"
-	      (length destroyed-processes) (length *all-processes*))
-      (process-yield)))
-
-  (start-sigalrm-yield 0 0)	; Off with the interrupts.
-  ;; Reset the multi-processing state.
-  (setf *inhibit-scheduling* t)
-  (setf *initial-process* nil)
-  (setf *idle-process* nil)
-  (setf *current-process* nil)
-  (setf *all-processes* nil)
-  (setf *remaining-processes* nil)
-  ;; Cleanup the stack groups.
-  (setf x86::*control-stacks*
-	(make-array 0 :element-type '(or null (unsigned-byte 32))
-		    :initial-element nil))
-  (setf *current-stack-group* nil)
-  (setf *initial-stack-group* nil))
-
+  (when *initial-process*
+    (assert (eq *current-process* *initial-process*) ()
+	    "Only the *initial-process* can shutdown multi-processing")
+
+    (let ((destroyed-processes nil))
+      (do ((cnt 0 (1+ cnt)))
+	  ((> cnt 10))
+	(declare (type kernel:index cnt))
+	(dolist (process *all-processes*)
+	  (when (and (not (eq process *current-process*))
+		     (process-active-p process)
+		     (not (member process destroyed-processes)))
+	    (destroy-process process)
+	    (push process destroyed-processes)))
+	(unless (rest *all-processes*)
+	  (return))
+	(format t "Destroyed ~d process~:P; remaining ~d~%"
+		(length destroyed-processes) (length *all-processes*))
+	(process-yield)))
+
+    (start-sigalrm-yield 0 0)	; Off with the interrupts.
+    ;; Reset the multi-processing state.
+    (setf *inhibit-scheduling* t)
+    (setf *initial-process* nil)
+    (setf *idle-process* nil)
+    (setf *current-process*
+	  (%make-process :name "Startup" :state :inactive :stack-group nil))
+    (setf *all-processes* nil)
+    (setf *remaining-processes* nil)
+    ;; Cleanup the stack groups.
+    (setf x86::*control-stacks*
+	  (make-array 0 :element-type '(or null (unsigned-byte 32))
+		      :initial-element nil))
+    (setf *current-stack-group* nil)
+    (setf *initial-stack-group* nil)))
 
 ;;; Idle-Process-Loop  --  Internal
 ;;;
-- 
GitLab