1.0.23.37: more CLOS and classoid thread safety

[sbcl.git] / src / code / cold-init.lisp

diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp
index dd51ecf..57c5c12 100644 (file)
--- a/src/code/cold-init.lisp
+++ b/src/code/cold-init.lisp
@@ -104,11 +104,11 @@
         *current-error-depth* 0
         *cold-init-complete-p* nil
         *type-system-initialized* nil
-        sb!vm:*alloc-signal* nil)
+        sb!vm:*alloc-signal* nil
+        sb!kernel::*gc-epoch* (cons nil nil))
 
   ;; I'm not sure where eval is first called, so I put this first.
-  #!+sb-eval
-  (show-and-call sb!eval::!full-eval-cold-init)
+  (show-and-call !eval-cold-init)
 
   (show-and-call thread-init-or-reinit)
   (show-and-call !typecheckfuns-cold-init)
@@ -141,6 +141,7 @@
   ;; forms run.
   (show-and-call !type-class-cold-init)
   (show-and-call !typedefs-cold-init)
+  (show-and-call !world-lock-cold-init)
   (show-and-call !classes-cold-init)
   (show-and-call !early-type-cold-init)
   (show-and-call !late-type-cold-init)
@@ -240,10 +241,14 @@
   ;; The reader and printer are initialized very late, so that they
   ;; can do hairy things like invoking the compiler as part of their
   ;; initialization.
-  (show-and-call !reader-cold-init)
-  (let ((*readtable* *standard-readtable*))
+  (let ((*readtable* (make-readtable)))
+    (show-and-call !reader-cold-init)
     (show-and-call !sharpm-cold-init)
-    (show-and-call !backq-cold-init))
+    (show-and-call !backq-cold-init)
+    ;; The *STANDARD-READTABLE* is assigned at last because the above
+    ;; functions would operate on the standard readtable otherwise---
+    ;; which would result in an error.
+    (setf *standard-readtable* *readtable*))
   (setf *readtable* (copy-readtable *standard-readtable*))
   (setf sb!debug:*debug-readtable* (copy-readtable *standard-readtable*))
   (sb!pretty:!pprint-cold-init)
@@ -270,10 +275,12 @@
 
 (defun quit (&key recklessly-p (unix-status 0))
   #!+sb-doc
-  "Terminate the current Lisp. Things are cleaned up (with
-UNWIND-PROTECT and so forth) unless RECKLESSLY-P is non-NIL. On
-UNIX-like systems, UNIX-STATUS is used as the status code."
+  "Terminate the current Lisp. *EXIT-HOOKS* are pending unwind-protect
+cleanup forms are run unless RECKLESSLY-P is true. On UNIX-like
+systems, UNIX-STATUS is used as the status code."
   (declare (type (signed-byte 32) unix-status))
+  ;; FIXME: Windows is not "unix-like", but still has the same
+  ;; unix-status... maybe we should just revert to calling it :STATUS?
   (/show0 "entering QUIT")
   (if recklessly-p
       (sb!unix:unix-exit unix-status)
@@ -288,6 +295,8 @@ UNIX-like systems, UNIX-STATUS is used as the status code."
   (sb!thread::get-foreground))
 
 (defun reinit ()
+  #!+win32
+  (setf sb!win32::*ansi-codepage* nil)
   (setf *default-external-format* nil)
   (setf sb!alien::*default-c-string-external-format* nil)
   ;; WITHOUT-GCING implies WITHOUT-INTERRUPTS.
@@ -306,9 +315,7 @@ UNIX-like systems, UNIX-STATUS is used as the status code."
   ;; re-disable ldb again.
   (when (eq *invoke-debugger-hook* 'sb!debug::debugger-disabled-hook)
     (sb!debug::disable-debugger))
-  (dolist (hook *init-hooks*)
-    (with-simple-restart (continue "Skip this initialization hook.")
-      (funcall hook))))
+  (call-hooks "initialization" *init-hooks*))
 \f
 ;;;; some support for any hapless wretches who end up debugging cold
 ;;;; init code
@@ -337,14 +344,20 @@ UNIX-like systems, UNIX-STATUS is used as the status code."
 
 #!+sb-show
 (defun cold-print (x)
-  (typecase x
-    (simple-string (sb!sys:%primitive print x))
-    (symbol (sb!sys:%primitive print (symbol-name x)))
-    (list (let ((count 0))
-            (sb!sys:%primitive print "list:")
-            (dolist (i x)
-              (when (>= (incf count) 4)
-                (sb!sys:%primitive print "...")
-                (return))
-              (cold-print i))))
-    (t (sb!sys:%primitive print (hexstr x)))))
+  (labels ((%cold-print (obj depthoid)
+             (if (> depthoid 4)
+                 (sb!sys:%primitive print "...")
+                 (typecase obj
+                   (simple-string
+                    (sb!sys:%primitive print obj))
+                   (symbol
+                    (sb!sys:%primitive print (symbol-name obj)))
+                   (cons
+                    (sb!sys:%primitive print "cons:")
+                    (let ((d (1+ depthoid)))
+                      (%cold-print (car obj) d)
+                      (%cold-print (cdr obj) d)))
+                   (t
+                    (sb!sys:%primitive print (hexstr x)))))))
+    (%cold-print x 0))
+  (values))
\ No newline at end of file