Fix deadlocks in GC on Windows.
[sbcl.git] / src / cold / warm.lisp
index 2ace156..bab0527 100644 (file)
 ;;;; general warm init compilation policy
 
 (proclaim '(optimize (compilation-speed 1)
-                    (debug #+sb-show 2 #-sb-show 1)
-                    (inhibit-warnings 2)
-                    (safety 1)
-                    (space 1)
-                    (speed 2)))
-\f
-;;;; KLUDGE: Compile and load files which really belong in cold load but are
-;;;; here for various unsound reasons. We handle them here, before the package
-;;;; hacking below, because they use the SB!FOO cold package name convention
-;;;; instead of the SB-FOO final package name convention (since they really
-;;;; do belong in cold load and will hopefully make it back there reasonably
-;;;; soon). -- WHN 19991207
+                     (debug #+sb-show 2 #-sb-show 1)
+                     (inhibit-warnings 2)
+                     (safety 2)
+                     (space 1)
+                     (speed 2)))
 
-(dolist (stem '(;; FIXME: The files here from outside the src/pcl directory
-               ;; probably belong in cold load instead of warm load. They
-               ;; ended up here as a quick hack to work around the
-               ;; consequences of my misunderstanding how ASSEMBLE-FILE works
-               ;; when I wrote the cold build code. The cold build code
-               ;; expects only one FASL filename per source file, when it
-               ;; turns out we really need one FASL file for ASSEMBLE-FILE
-               ;; output and another for COMPILE-FILE output. It would
-               ;; probably be good to redo the cold build code so that the
-               ;; COMPILE-FILE stuff generated here can be loaded at the same
-               ;; time as the ASSEMBLE-FILE stuff generated there.
-               "src/assembly/target/assem-rtns"
-               "src/assembly/target/array"
-               "src/assembly/target/arith"
-               "src/assembly/target/alloc"))
-  ;; KLUDGE: Cut-and-paste programming, the sign of a true professional.:-|
-  ;; (Hopefully this will go away as we move the files above into cold load.)
-  ;; -- WHN 19991214
-  (let ((fullname (concatenate 'string stem ".lisp")))
-    ;; (Now that we use byte compiler for interpretation, /SHOW
-    ;; doesn't get compiled properly until the src/assembly files have
-    ;; been loaded, so we use PRINT instead.)
-    #+sb-show (print "/about to compile src/assembly file")
-    #+sb-show (print fullname)
-    (multiple-value-bind
-       (compiled-truename compilation-warnings-p compilation-failure-p)
-       (compile-file fullname)
-      (declare (ignore compilation-warnings-p))
-      #+sb-show (print "/done compiling src/assembly file")
-      (if compilation-failure-p
-         (error "COMPILE-FILE of ~S failed." fullname)
-         (unless (load compiled-truename)
-           (error "LOAD of ~S failed." compiled-truename))))))
 \f
 ;;;; package hacking
 
-;;; Our cross-compilation host is out of the picture now, so we no longer need
-;;; to worry about collisions between our package names and cross-compilation
-;;; host package names, so now is a good time to rename any package with a
-;;; bootstrap-only name SB!FOO to its permanent name SB-FOO.
+;;; Our cross-compilation host is out of the picture now, so we no
+;;; longer need to worry about collisions between our package names
+;;; and cross-compilation host package names, so now is a good time to
+;;; rename any package with a bootstrap-only name SB!FOO to its
+;;; permanent name SB-FOO.
 ;;;
-;;; (In principle it might be tidier to do this when dumping the cold image in
-;;; genesis, but in practice the logic might be a little messier because
-;;; genesis dumps both symbols and packages, and we'd need to make that dumped
-;;; symbols were renamed in the same way as dumped packages. Or we could do it
-;;; in cold init, but it's easier to experiment with and debug things here in
-;;; warm init than in cold init, so we do it here instead.)
+;;; (In principle it might be tidier to do this when dumping the cold
+;;; image in genesis, but in practice the logic might be a little
+;;; messier because genesis dumps both symbols and packages, and we'd
+;;; need to make sure that dumped symbols were renamed in the same way
+;;; as dumped packages. Or we could do it in cold init, but it's
+;;; easier to experiment with and debug things here in warm init than
+;;; in cold init, so we do it here instead.)
 (let ((boot-prefix "SB!")
       (perm-prefix "SB-"))
   (dolist (package (list-all-packages))
     (let ((old-package-name (package-name package)))
       (when (and (>= (length old-package-name) (length boot-prefix))
-                (string= boot-prefix old-package-name
-                         :end2 (length boot-prefix)))
-       (let ((new-package-name (concatenate 'string
-                                            perm-prefix
-                                            (subseq old-package-name
-                                                    (length boot-prefix)))))
-         (rename-package package
-                         new-package-name
-                         (package-nicknames package)))))))
-
-;;; KLUDGE: This is created here (instead of in package-data-list.lisp-expr)
-;;; because it doesn't have any symbols in it, so even if it's
-;;; present at cold load time, genesis thinks it's unimportant
-;;; and doesn't dump it. There's gotta be a better way, but for now
-;;; I'll just do it here. (As noted below, I'd just as soon have this
-;;; go away entirely, so I'm disinclined to fiddle with it too much.)
-;;; -- WHN 19991206
-;;;
-;;; FIXME: Why do slot accessor names need to be interned anywhere? For
-;;; low-level debugging? Perhaps this should go away, or at least
-;;; be optional, controlled by SB-SHOW or something.
-(defpackage "SB-SLOT-ACCESSOR-NAME"
-  (:use))
+                 (string= boot-prefix old-package-name
+                          :end2 (length boot-prefix)))
+        (let ((new-package-name (concatenate 'string
+                                             perm-prefix
+                                             (subseq old-package-name
+                                                     (length boot-prefix)))))
+          (rename-package package
+                          new-package-name
+                          (package-nicknames package)))))))
+
+;;; FIXME: This nickname is a deprecated hack for backwards
+;;; compatibility with code which assumed the CMU-CL-style
+;;; SB-ALIEN/SB-C-CALL split. That split went away and was deprecated
+;;; in 0.7.0, so we should get rid of this nickname after a while.
+(let ((package (find-package "SB-ALIEN")))
+  (rename-package package
+                  (package-name package)
+                  (cons "SB-C-CALL" (package-nicknames package))))
+
+(let ((package (find-package "SB-SEQUENCE")))
+  (rename-package package (package-name package) (list "SEQUENCE")))
 \f
 ;;;; compiling and loading more of the system
 
-;;; KLUDGE: In SBCL, almost all in-the-flow-of-control package hacking has
-;;; gone away in favor of package setup controlled by tables. However, that
-;;; mechanism isn't smart enough to handle shadowing, and since this shadowing
-;;; is inherently a non-ANSI KLUDGE anyway (i.e. there ought to be no
-;;; difference between e.g. CL:CLASS and SB-PCL:CLASS) there's not much
-;;; point in trying to polish it by implementing a non-KLUDGEy way of
-;;; setting it up. -- WHN 19991203
-(let ((*package* (the package (find-package "SB-PCL"))))
-  (shadow '(;; CLASS itself and operations thereon
-           "CLASS" "CLASS-NAME" "CLASS-OF" "FIND-CLASS"
-           ;; some system classes
-           "BUILT-IN-CLASS" "STANDARD-CLASS" "STRUCTURE-CLASS"))
-  ;; Of the shadowing symbols above, these are external symbols in CMU CL ca.
-  ;; 19991203. I'm not sure what's the basis of the decision to export some and
-  ;; not others; we'll just follow along..
-  (export (mapcar #'intern '("CLASS-NAME" "CLASS-OF" "FIND-CLASS"))))
-
 ;;; FIXME: CMU CL's pclcom.lisp had extra optional stuff wrapped around
 ;;; COMPILE-PCL, at least some of which we should probably have too:
 ;;;
 ;;; (with-compilation-unit
 ;;;     (:optimize '(optimize (debug #+(and (not high-security) small) .5
-;;;                              #-(or high-security small) 2
-;;;                              #+high-security 3)
-;;;                       (speed 2) (safety #+(and (not high-security) small) 0
-;;;                                         #-(or high-security small) 2
-;;;                                         #+high-security 3)
-;;;                       (inhibit-warnings 2))
+;;;                               #-(or high-security small) 2
+;;;                               #+high-security 3)
+;;;                        (speed 2) (safety #+(and (not high-security) small) 0
+;;;                                          #-(or high-security small) 2
+;;;                                          #+high-security 3)
+;;;                        (inhibit-warnings 2))
 ;;;      :optimize-interface '(optimize-interface #+(and (not high-security) small)
 ;;; (safety 1)
-;;;                                           #+high-security (safety 3))
+;;;                                            #+high-security (safety 3))
 ;;;      :context-declarations
 ;;;      '((:external (declare (optimize-interface (safety #-high-security 2 #+high-
 ;;; security 3)
-;;;                                            (debug #-high-security 1 #+high-s
+;;;                                             (debug #-high-security 1 #+high-s
 ;;; ecurity 3))))
-;;;    ((:or :macro (:match "$EARLY-") (:match "$BOOT-"))
-;;;    (declare (optimize (speed 0))))))
+;;;     ((:or :macro (:match "$EARLY-") (:match "$BOOT-"))
+;;;     (declare (optimize (speed 0))))))
 ;;;
 ;;; FIXME: This has mutated into a hack which crudely duplicates
 ;;; functionality from the existing mechanism to load files from
-;;; stems-and-flags.lisp-expr, without being quite parallel. (E.g.
-;;; object files end up alongside the source files instead of ending
-;;; up in parallel directory trees.) Maybe we could merge the
-;;; filenames here into stems-and-flags.lisp-expr with some new flag
-;;; (perhaps :WARM) to indicate that the files should be handled not
-;;; in cold load but afterwards. Alternatively, we could call
-(dolist (stem '(
-               ;; CLOS, derived from the PCL reference implementation
-               ;;
-               ;; This PCL build order is based on a particular
-               ;; linearization of the declared build order
-               ;; dependencies from the old PCL defsys.lisp
-               ;; dependency database.
-               "src/pcl/walk"
-               "src/pcl/iterate"
-               "src/pcl/early-low"
-               "src/pcl/macros"
-                "src/pcl/compiler-support"
-               "src/pcl/low"
-               ;; "src/pcl/fin" merged into "src/pcl/low" in 0.6.11.43
-               "src/pcl/defclass"
-               "src/pcl/defs"
-               "src/pcl/fngen"
-               "src/pcl/cache"
-               "src/pcl/dlisp"
-               "src/pcl/dlisp2"
-               "src/pcl/boot"
-               "src/pcl/vector"
-               "src/pcl/slots-boot"
-               "src/pcl/combin"
-               "src/pcl/dfun"
-               "src/pcl/fast-init"
-               "src/pcl/braid"
-               "src/pcl/dlisp3"
-               "src/pcl/generic-functions"
-               "src/pcl/slots"
-               "src/pcl/init"
-               "src/pcl/std-class"
-               "src/pcl/cpl"
-               "src/pcl/fsc"
-               "src/pcl/methods"
-               "src/pcl/fixup"
-               "src/pcl/defcombin"
-               "src/pcl/ctypes"
-               "src/pcl/construct"
-               "src/pcl/env"
-               "src/pcl/documentation"
-               "src/pcl/print-object"
-               "src/pcl/precom1"
-               "src/pcl/precom2"
-
-               ;; miscellaneous functionality which depends on CLOS
-               "src/code/force-delayed-defbangmethods"
-
-               ;; CLOS-level support for the Gray OO streams
-               ;; extension (which is also supported by various
-               ;; lower-level hooks elsewhere in the code)
-               "src/pcl/gray-streams-class"
-               "src/pcl/gray-streams"
-
-               ;; other functionality not needed for cold init, moved
-               ;; to warm init to reduce peak memory requirement in
-               ;; cold init
-               "src/code/describe"
-               "src/code/inspect"
-               "src/code/profile"
-               "src/code/ntrace"
-               "src/code/foreign"
-               "src/code/run-program"
-
-               ;; Code derived from PCL's pre-ANSI DESCRIBE-OBJECT
-               ;; facility is still used in our ANSI DESCRIBE
-               ;; facility, and should be compiled and loaded after
-               ;; our DESCRIBE facility is compiled and loaded.
-               "src/pcl/describe"))
-
-  (let ((fullname (concatenate 'string stem ".lisp")))
+;;; build-order.lisp-expr, without being quite parallel. (E.g. object
+;;; files end up alongside the source files instead of ending up in
+;;; parallel directory trees.) Maybe we could merge the filenames here
+;;; into build-order.lisp-expr with some new flag (perhaps :WARM) to
+;;; indicate that the files should be handled not in cold load but
+;;; afterwards.
+(dolist (stem '(;; CLOS, derived from the PCL reference implementation
+                ;;
+                ;; This PCL build order is based on a particular
+                ;; (arbitrary) linearization of the declared build
+                ;; order dependencies from the old PCL defsys.lisp
+                ;; dependency database.
+                #+nil "src/pcl/walk" ; #+NIL = moved to build-order.lisp-expr
+                "SRC;PCL;EARLY-LOW"
+                "SRC;PCL;MACROS"
+                "SRC;PCL;COMPILER-SUPPORT"
+                "SRC;PCL;LOW"
+                "SRC;PCL;SLOT-NAME"
+                "SRC;PCL;DEFCLASS"
+                "SRC;PCL;DEFS"
+                "SRC;PCL;FNGEN"
+                "SRC;PCL;WRAPPER"
+                "SRC;PCL;CACHE"
+                "SRC;PCL;DLISP"
+                "SRC;PCL;BOOT"
+                "SRC;PCL;VECTOR"
+                "SRC;PCL;SLOTS-BOOT"
+                "SRC;PCL;COMBIN"
+                "SRC;PCL;DFUN"
+                "SRC;PCL;CTOR"
+                "SRC;PCL;BRAID"
+                "SRC;PCL;DLISP3"
+                "SRC;PCL;GENERIC-FUNCTIONS"
+                "SRC;PCL;SLOTS"
+                "SRC;PCL;INIT"
+                "SRC;PCL;STD-CLASS"
+                "SRC;PCL;CPL"
+                "SRC;PCL;FSC"
+                "SRC;PCL;METHODS"
+                "SRC;PCL;FIXUP"
+                "SRC;PCL;DEFCOMBIN"
+                "SRC;PCL;CTYPES"
+                "SRC;PCL;ENV"
+                "SRC;PCL;DOCUMENTATION"
+                "SRC;PCL;PRINT-OBJECT"
+                "SRC;PCL;PRECOM1"
+                "SRC;PCL;PRECOM2"
+
+                ;; miscellaneous functionality which depends on CLOS
+                "SRC;CODE;FORCE-DELAYED-DEFBANGMETHODS"
+                "SRC;CODE;LATE-CONDITION"
+
+                ;; CLOS-level support for the Gray OO streams
+                ;; extension (which is also supported by various
+                ;; lower-level hooks elsewhere in the code)
+                "SRC;PCL;GRAY-STREAMS-CLASS"
+                "SRC;PCL;GRAY-STREAMS"
+
+                ;; CLOS-level support for User-extensible sequences.
+                "SRC;PCL;SEQUENCE"
+
+                ;; other functionality not needed for cold init, moved
+                ;; to warm init to reduce peak memory requirement in
+                ;; cold init
+                "SRC;CODE;DESCRIBE"
+                "SRC;CODE;DESCRIBE-POLICY"
+                "SRC;CODE;INSPECT"
+                "SRC;CODE;PROFILE"
+                "SRC;CODE;NTRACE"
+                "SRC;CODE;STEP"
+                "SRC;CODE;WARM-LIB"
+                #+win32 "SRC;CODE;WARM-MSWIN"
+                "SRC;CODE;RUN-PROGRAM"))
+
+  (let ((fullname (concatenate 'string "SYS:" stem ".LISP")))
     (sb-int:/show "about to compile" fullname)
-    (multiple-value-bind
-       (compiled-truename compilation-warnings-p compilation-failure-p)
-       (compile-file fullname)
-      (declare (ignore compilation-warnings-p))
-      (sb-int:/show "done compiling" fullname)
-      (cond (compilation-failure-p
-            (error "COMPILE-FILE of ~S failed." fullname))
-           (t
-            (unless (load compiled-truename)
-              (error "LOAD of ~S failed." compiled-truename))
-            (sb-int:/show "done loading" compiled-truename))))))
+    (flet ((report-recompile-restart (stream)
+             (format stream "Recompile file ~S" fullname))
+           (report-continue-restart (stream)
+             (format stream
+                     "Continue, using possibly bogus file ~S"
+                     (compile-file-pathname fullname))))
+      (tagbody
+       retry-compile-file
+         (multiple-value-bind (output-truename warnings-p failure-p)
+             (if *compile-files-p*
+                 (compile-file fullname)
+                 (compile-file-pathname fullname))
+           (declare (ignore warnings-p))
+           (sb-int:/show "done compiling" fullname)
+           (cond ((not output-truename)
+                  (error "COMPILE-FILE of ~S failed." fullname))
+                 (failure-p
+                  (unwind-protect
+                       (restart-case
+                           (error "FAILURE-P was set when creating ~S."
+                                  output-truename)
+                         (recompile ()
+                           :report report-recompile-restart
+                           (go retry-compile-file))
+                         (continue ()
+                           :report report-continue-restart
+                           (setf failure-p nil)))
+                    ;; Don't leave failed object files lying around.
+                    (when (and failure-p (probe-file output-truename))
+                          (delete-file output-truename)
+                          (format t "~&deleted ~S~%" output-truename))))
+                 ;; Otherwise: success, just fall through.
+                 (t nil))
+           (unless (load output-truename)
+             (error "LOAD of ~S failed." output-truename))
+           (sb-int:/show "done loading" output-truename))))))
 \f
 ;;;; setting package documentation
 
 #+sb-doc (setf (documentation (find-package "COMMON-LISP") t)
 "public: home of symbols defined by the ANSI language specification")
 #+sb-doc (setf (documentation (find-package "COMMON-LISP-USER") t)
-              "public: the default package for user code and data")
+               "public: the default package for user code and data")
 #+sb-doc (setf (documentation (find-package "KEYWORD") t)
-              "public: home of keywords")
-
-;;; KLUDGE: It'd be nicer to do this in the table with the other
-;;; non-standard packages. -- WHN 19991206
-#+sb-doc (setf (documentation (find-package "SB-SLOT-ACCESSOR-NAME") t)
-              "private: home of CLOS slot accessor internal names")
-
-;;; FIXME: There doesn't seem to be any easy way to get package doc strings
-;;; through the cold boot process. They need to be set somewhere. Maybe the
-;;; easiest thing to do is to read them out of package-data-list.lisp-expr
-;;; now?
+               "public: home of keywords")
 \f
-;;;; restoring compilation policy to neutral values in preparation for
-;;;; SAVE-LISP-AND-DIE as final SBCL core
 
-(sb-int:/show "setting compilation policy to neutral values")
-(proclaim '(optimize (compilation-speed 1)
-                    (debug 1)
-                    (inhibit-warnings 1)
-                    (safety 1)
-                    (space 1)
-                    (speed 1)))