1.0.48.10: add deadlock detection to spinlocks and mutexes

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

diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp
index 2d07ef1..8444234 100644 (file)
--- a/src/code/cold-init.lisp
+++ b/src/code/cold-init.lisp
@@ -93,10 +93,12 @@
   ;; *TYPE-SYSTEM-INITIALIZED-WHEN-BOUND* so that it doesn't need to
   ;; be explicitly set in order to be meaningful.
   (setf *after-gc-hooks* nil
+        *in-without-gcing* nil
         *gc-inhibit* t
         *gc-pending* nil
         #!+sb-thread *stop-for-gc-pending* #!+sb-thread nil
         *allow-with-interrupts* t
+        sb!unix::*unblock-deferrables-on-enabling-interrupts-p* nil
         *interrupts-enabled* t
         *interrupt-pending* nil
         *break-on-signals* nil
@@ -109,7 +111,7 @@
 
   ;; I'm not sure where eval is first called, so I put this first.
   (show-and-call !eval-cold-init)
-
+  (show-and-call !deadline-cold-init)
   (show-and-call thread-init-or-reinit)
   (show-and-call !typecheckfuns-cold-init)
 
@@ -141,6 +143,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)
@@ -196,15 +199,10 @@
             (setf (svref *!load-time-values* (third toplevel-thing))
                   (funcall (second toplevel-thing))))
            (:load-time-value-fixup
-            (setf (sap-ref-word (second toplevel-thing) 0)
+            (setf (sap-ref-word (int-sap (get-lisp-obj-address (second toplevel-thing)))
+                                (third toplevel-thing))
                   (get-lisp-obj-address
-                   (svref *!load-time-values* (third toplevel-thing)))))
-           #!+(and (or x86 x86-64) gencgc)
-           (:load-time-code-fixup
-            (sb!vm::!envector-load-time-code-fixup (second toplevel-thing)
-                                                   (third  toplevel-thing)
-                                                   (fourth toplevel-thing)
-                                                   (fifth  toplevel-thing)))
+                   (svref *!load-time-values* (fourth toplevel-thing)))))
            (t
             (!cold-lose "bogus fixup code in *!REVERSED-COLD-TOPLEVELS*"))))
         (t (!cold-lose "bogus function in *!REVERSED-COLD-TOPLEVELS*")))))
@@ -225,6 +223,8 @@
   (show-and-call !late-proclaim-cold-init)
 
   (show-and-call os-cold-init-or-reinit)
+  (show-and-call !pathname-cold-init)
+  (show-and-call !debug-info-cold-init)
 
   (show-and-call stream-cold-init-or-reset)
   (show-and-call !loader-cold-init)
@@ -240,10 +240,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)
@@ -254,9 +258,11 @@
   (/show0 "done initializing, setting *COLD-INIT-COMPLETE-P*")
   (setf *cold-init-complete-p* t)
 
+  ; hppa heap is segmented, lisp and c uses a stub to call eachother
+  #!+hpux (sb!sys:%primitive sb!vm::setup-return-from-lisp-stub)
   ;; The system is finally ready for GC.
   (/show0 "enabling GC")
-  (gc-on)
+  (setq *gc-inhibit* nil)
   (/show0 "doing first GC")
   (gc :full t)
   (/show0 "back from first GC")
@@ -270,7 +276,7 @@
 
 (defun quit (&key recklessly-p (unix-status 0))
   #!+sb-doc
-  "Terminate the current Lisp. *EXIT-HOOKS* are pending unwind-protect
+  "Terminate the current Lisp. *EXIT-HOOKS* and 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))
@@ -339,14 +345,20 @@ 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