0.6.9.12:
authorWilliam Harold Newman <william.newman@airmail.net>
Fri, 29 Dec 2000 18:39:01 +0000 (18:39 +0000)
committerWilliam Harold Newman <william.newman@airmail.net>
Fri, 29 Dec 2000 18:39:01 +0000 (18:39 +0000)
(This version is broken. It builds, but can't build itself,
dying in vop.lisp with what looks like memory
corruption. 0.6.9.11 might be broken the same way.)
no more special support for DECLARE SB-PCL::CLASS
moved policy stuff into policy.lisp
moved !UNINTERN-INIT-ONLY-STUFF to after warm init
renamed some PCL stuff to make it be uninterned after warm init

12 files changed:
make-target-2.sh
package-data-list.lisp-expr
src/code/cold-init.lisp
src/compiler/early-c.lisp
src/compiler/ir1tran.lisp
src/compiler/macros.lisp
src/compiler/policy.lisp [new file with mode: 0644]
src/pcl/boot.lisp
src/pcl/braid.lisp
src/pcl/fixup.lisp
stems-and-flags.lisp-expr
version.lisp-expr

index 0c66d5b..c03fcaa 100644 (file)
@@ -28,11 +28,19 @@ echo //doing warm init
 ./src/runtime/sbcl \
 --core output/cold-sbcl.core \
 --sysinit /dev/null --userinit /dev/null <<-'EOF' || exit 1
+
         (sb!int:/show "hello, world!")
+
+        ;; Do warm init.
        (let ((*print-length* 5)
              (*print-level* 5))
           (sb!int:/show "about to LOAD warm.lisp")
          (load "src/cold/warm.lisp"))
+
+        ;; Unintern no-longer-needed stuff before the possible PURIFY
+        ;; in SAVE-LISP-AND-DIE.
+        #-sb-fluid (sb-impl::!unintern-init-only-stuff)
+
         (sb-int:/show "done with warm.lisp, about to SAVE-LISP-AND-DIE")
        ;; Even if /SHOW output was wanted during build, it's probably
        ;; not wanted by default after build is complete. (And if it's
index 6f3c24c..c41fe96 100644 (file)
@@ -1190,7 +1190,7 @@ is a good idea, but see SB-SYS for blurring of boundaries."
              "NAMESTRING-PARSE-ERROR" "NAMESTRING-PARSE-ERROR-OFFSET"
              "DESCRIBE-CONDITION"
              
-            "!COLD-INIT"
+            "!COLD-INIT" "!UNINTERN-INIT-ONLY-STUFF"
              "!GLOBALDB-COLD-INIT" "!FDEFN-COLD-INIT"
              "!TYPE-CLASS-COLD-INIT" "!TYPEDEFS-COLD-INIT"
              "!ALIEN-TYPE-COLD-INIT" "!CLASSES-COLD-INIT"
index ad00f27..074ee18 100644 (file)
   (show-and-call !class-finalize)
 
   ;; The reader and printer are initialized very late, so that they
-  ;; can even do hairy things like invoking the compiler as part of
-  ;; their initialization.
+  ;; can do hairy things like invoking the compiler as part of their
+  ;; initialization.
   (show-and-call !reader-cold-init)
   (let ((*readtable* *standard-readtable*))
     (show-and-call !sharpm-cold-init)
   (/show0 "done initializing")
   (setf *cold-init-complete-p* t)
 
-  ;; Unintern no-longer-needed stuff before we GC.
-  #!-sb-fluid
-  (!unintern-init-only-stuff)
-
   ;; The system is finally ready for GC.
   #!-gengc (setf *already-maybe-gcing* nil)
   (/show0 "enabling GC")
index 9f266bb..205eccb 100644 (file)
 
 ;;; the type of LAYOUT-DEPTHOID slot values
 (def!type sb!kernel::layout-depthoid () '(or index (integer -1 -1)))
-
-;;; a value for an optimization declaration
-(def!type policy-quality () '(or (rational 0 3) null))
-\f
-;;;; policy stuff
-
-;;; CMU CL used a special STRUCTURE-OBJECT type POLICY to represent
-;;; the state of optimization policy at any point in compilation. This
-;;; became a little unwieldy, especially because of cold init issues
-;;; for structures and structure accessors, so in SBCL we use an alist
-;;; instead.
-(deftype policy () 'list)
-
-;;; names of recognized optimization qualities which don't have
-;;; special defaulting behavior
-(defvar *policy-basic-qualities*)
-
-;;; FIXME: I'd like to get rid of DECLAIM OPTIMIZE-INTERFACE in favor
-;;; of e.g. (DECLAIM (OPTIMIZE (INTERFACE-SPEED 2) (INTERFACE-SAFETY 3))).
-#|
-;;; a list of conses (DEFAULTING-QUALITY . DEFAULT-QUALITY) of qualities
-;;; which default to other qualities when undefined, e.g. interface
-;;; speed defaulting to basic speed
-(defvar *policy-defaulting-qualities*)
-|#
-
-(defun optimization-quality-p (name)
-  (or (member name *policy-basic-qualities*)
-      ;; FIXME: Uncomment this when OPTIMIZE-INTERFACE goes away.
-      #|(member name *policy-defaulting-qualities* :key #'car)|#))
-
-;;; *DEFAULT-POLICY* holds the current global compiler policy
-;;; information, as an alist mapping from optimization quality name to
-;;; quality value. Inside the scope of declarations, new entries are
-;;; added at the head of the alist.
-;;;
-;;; *DEFAULT-INTERFACE-POLICY* holds any values specified by an
-;;; OPTIMIZE-INTERFACE declaration.
-(declaim (type policy *default-policy* *default-interface-policy*))
-(defvar *default-policy*)         ; initialized in cold init
-(defvar *default-interface-policy*) ; initialized in cold init
-
-;;; This is to be called early in cold init to set things up, and may
-;;; also be called again later in cold init in order to reset default
-;;; optimization policy back to default values after toplevel PROCLAIM
-;;; OPTIMIZE forms have messed with it.
-(defun !policy-cold-init-or-resanify ()
-  (setf *policy-basic-qualities*
-       '(;; ANSI standard qualities
-         compilation-speed
-         debug
-         safety
-         space
-         speed
-         ;; SBCL extensions
-         ;;
-         ;; FIXME: INHIBIT-WARNINGS is a misleading name for this.
-         ;; Perhaps BREVITY would be better. But the ideal name would
-         ;; have connotations of suppressing not warnings but only
-         ;; optimization-related notes, which is already mostly the
-         ;; behavior, and should probably become the exact behavior.
-         ;; Perhaps INHIBIT-NOTES?
-         inhibit-warnings))
-  (setf *policy-defaulting-qualities*
-       '((interface-speed . speed)
-         (interface-safety . safety)))
-  (setf *default-policy*
-       (mapcar (lambda (name)
-                 ;; CMU CL didn't use 1 as the default for everything,
-                 ;; but since ANSI says 1 is the ordinary value, we do.
-                 (cons name 1))
-               *policy-basic-qualities*))
-  (setf *default-interface-policy*
-       *default-policy*))
-;;; On the cross-compilation host, we initialize the compiler immediately.
-#+sb-xc-host (!policy-cold-init-or-resanify)
-
-;;; Is X the name of an optimization quality?
-(defun policy-quality-p (x)
-  (memq x *policy-basic-qualities*))
 \f
 ;;; possible values for the INLINE-ness of a function.
 (deftype inlinep ()
     (notinline . :notinline)
     (maybe-inline . :maybe-inline)))
 
-;;; The lexical environment we are currently converting in.
+;;; the lexical environment we are currently converting in
 (defvar *lexenv*)
 (declaim (type lexenv *lexenv*))
 
index b1b9a97..c402944 100644 (file)
                         (lexenv-interface-policy res))))
     (type
      (process-type-declaration (cdr spec) res vars))
-    (sb!pcl::class
-     (process-type-declaration (list (third spec) (second spec)) res vars))
     (values
      (if *suppress-values-declaration*
         res
index 956f59e..1ea2355 100644 (file)
 ;;;            Retain expansion, but only use it opportunistically.
 (deftype inlinep () '(member :inline :maybe-inline :notinline nil))
 \f
-;;;; the POLICY macro
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-
-;;; a helper function for the POLICY macro: Look up a named optimization
-;;; quality in POLICY.
-(declaim (ftype (function (policy symbol) policy-quality)))
-(defun policy-quality (policy quality-name)
-  (the policy-quality
-       (cdr (assoc quality-name policy))))
-
-;;; A helper function for the POLICY macro: Return a list of symbols
-;;; naming the qualities which appear in EXPR.
-(defun policy-qualities-used-by (expr)
-  (let ((result nil))
-    (labels ((recurse (x)
-              (if (listp x)
-                  (map nil #'recurse x)
-                  (when (policy-quality-p x)
-                    (pushnew x result)))))
-      (recurse expr)
-      result)))
-
-) ; EVAL-WHEN
-
-;;; syntactic sugar for querying optimization policy qualities
-;;;
-;;; Evaluate EXPR in terms of the current optimization policy for
-;;; NODE, or if NODE is NIL, in terms of the current policy as defined
-;;; by *DEFAULT-POLICY* and *CURRENT-POLICY*. (Using NODE=NIL is only
-;;; well-defined during IR1 conversion.)
-;;;
-;;; EXPR is a form which accesses the policy values by referring to
-;;; them by name, e.g. (> SPEED SPACE).
-(defmacro policy (node expr)
-  (let* ((n-policy (gensym))
-        (binds (mapcar (lambda (name)
-                         `(,name (policy-quality ,n-policy ',name)))
-                       (policy-qualities-used-by expr))))
-    (/show "in POLICY" expr binds)
-    `(let* ((,n-policy (lexenv-policy ,(if node
-                                          `(node-lexenv ,node)
-                                          '*lexenv*)))
-           ,@binds)
-       ,expr)))
-\f
 ;;;; source-hacking defining forms
 
 ;;; to be passed to PARSE-DEFMACRO when we want compiler errors
diff --git a/src/compiler/policy.lisp b/src/compiler/policy.lisp
new file mode 100644 (file)
index 0000000..0d880cc
--- /dev/null
@@ -0,0 +1,131 @@
+;;;; compiler optimization policy stuff
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+;;; a value for an optimization declaration
+(def!type policy-quality () '(or (rational 0 3) null))
+
+;;; CMU CL used a special STRUCTURE-OBJECT type POLICY to represent
+;;; the state of optimization policy at any point in compilation. This
+;;; became a little unwieldy, especially because of cold init issues
+;;; for structures and structure accessors, so in SBCL we use an alist
+;;; instead.
+(def!type policy () 'list)
+
+;;; names of recognized optimization qualities which don't have
+;;; special defaulting behavior
+(defvar *policy-basic-qualities*) ; (initialized at cold init)
+
+;;; FIXME: I'd like to get rid of DECLAIM OPTIMIZE-INTERFACE in favor
+;;; of e.g. (DECLAIM (OPTIMIZE (INTERFACE-SPEED 2) (INTERFACE-SAFETY 3))).
+#|
+;;; a list of conses (DEFAULTING-QUALITY . DEFAULT-QUALITY) of qualities
+;;; which default to other qualities when undefined, e.g. interface
+;;; speed defaulting to basic speed
+(defvar *policy-defaulting-qualities*)
+|#
+
+(defun optimization-quality-p (name)
+  (or (member name *policy-basic-qualities*)
+      ;; FIXME: Uncomment this when OPTIMIZE-INTERFACE goes away.
+      #|(member name *policy-defaulting-qualities* :key #'car)|#))
+
+;;; *DEFAULT-POLICY* holds the current global compiler policy
+;;; information, as an alist mapping from optimization quality name to
+;;; quality value. Inside the scope of declarations, new entries are
+;;; added at the head of the alist.
+;;;
+;;; *DEFAULT-INTERFACE-POLICY* holds any values specified by an
+;;; OPTIMIZE-INTERFACE declaration.
+(declaim (type policy *default-policy* *default-interface-policy*))
+(defvar *default-policy*)         ; initialized in cold init
+(defvar *default-interface-policy*) ; initialized in cold init
+
+;;; This is to be called early in cold init to set things up, and may
+;;; also be called again later in cold init in order to reset default
+;;; optimization policy back to default values after toplevel PROCLAIM
+;;; OPTIMIZE forms have messed with it.
+(defun !policy-cold-init-or-resanify ()
+  (setf *policy-basic-qualities*
+       '(;; ANSI standard qualities
+         compilation-speed
+         debug
+         safety
+         space
+         speed
+         ;; SBCL extensions
+         ;;
+         ;; FIXME: INHIBIT-WARNINGS is a misleading name for this.
+         ;; Perhaps BREVITY would be better. But the ideal name would
+         ;; have connotations of suppressing not warnings but only
+         ;; optimization-related notes, which is already mostly the
+         ;; behavior, and should probably become the exact behavior.
+         ;; Perhaps INHIBIT-NOTES?
+         inhibit-warnings))
+  (setf *policy-defaulting-qualities*
+       '((interface-speed . speed)
+         (interface-safety . safety)))
+  (setf *default-policy*
+       (mapcar (lambda (name)
+                 ;; CMU CL didn't use 1 as the default for everything,
+                 ;; but since ANSI says 1 is the ordinary value, we do.
+                 (cons name 1))
+               *policy-basic-qualities*))
+  (setf *default-interface-policy*
+       *default-policy*))
+;;; On the cross-compilation host, we initialize immediately (not
+;;; waiting for "cold init", since cold init doesn't exist on
+;;; cross-compilation host).
+#+sb-xc-host (!policy-cold-init-or-resanify)
+
+;;; Is X the name of an optimization quality?
+(defun policy-quality-p (x)
+  (memq x *policy-basic-qualities*))
+
+;;; Look up a named optimization quality in POLICY.
+(declaim (ftype (function (policy symbol) policy-quality)))
+(defun policy-quality (policy quality-name)
+  (the policy-quality
+       (cdr (assoc quality-name policy))))
+
+;;; Return a list of symbols naming the optimization qualities which
+;;; appear in EXPR.
+(defun policy-qualities-used-by (expr)
+  (let ((result nil))
+    (labels ((recurse (x)
+              (if (listp x)
+                  (map nil #'recurse x)
+                  (when (policy-quality-p x)
+                    (pushnew x result)))))
+      (recurse expr)
+      result)))
+
+;;; syntactic sugar for querying optimization policy qualities
+;;;
+;;; Evaluate EXPR in terms of the current optimization policy for
+;;; NODE, or if NODE is NIL, in terms of the current policy as defined
+;;; by *DEFAULT-POLICY* and *CURRENT-POLICY*. (Using NODE=NIL is only
+;;; well-defined during IR1 conversion.)
+;;;
+;;; EXPR is a form which accesses the policy values by referring to
+;;; them by name, e.g. (> SPEED SPACE).
+(defmacro policy (node expr)
+  (let* ((n-policy (gensym))
+        (binds (mapcar (lambda (name)
+                         `(,name (policy-quality ,n-policy ',name)))
+                       (policy-qualities-used-by expr))))
+    (/show "in POLICY" expr binds)
+    `(let* ((,n-policy (lexenv-policy ,(if node
+                                          `(node-lexenv ,node)
+                                          '*lexenv*)))
+           ,@binds)
+       ,expr)))
index dfa7dcc..9334e5e 100644 (file)
@@ -38,11 +38,11 @@ functions and the corresponding early methods and early method lookup
 are used to get enough of the system running that it is possible to
 create real generic functions and methods and implement real method
 lookup. At that point (done in the file FIXUP) the function
-fix-early-generic-functions is called to convert all the early generic
+!FIX-EARLY-GENERIC-FUNCTIONS is called to convert all the early generic
 functions to real generic functions.
 
 The cheap generic functions are built using the same
-funcallable-instance objects real generic-functions are made out of.
+FUNCALLABLE-INSTANCE objects that real generic functions are made out of.
 This means that as PCL is being bootstrapped, the cheap generic
 function objects which are being created are the same objects which
 will later be real generic functions. This is good because:
@@ -51,23 +51,33 @@ will later be real generic functions. This is good because:
     during booting because those pointers will still point to
     the right object after the generic functions are all fixed up.
 
-This file defines the defmethod macro and the mechanism used to expand
+This file defines the DEFMETHOD macro and the mechanism used to expand
 it. This includes the mechanism for processing the body of a method.
 DEFMETHOD basically expands into a call to LOAD-DEFMETHOD, which
-basically calls ADD-METHOD to add the method to the generic-function.
+basically calls ADD-METHOD to add the method to the generic function.
 These expansions can be loaded either during bootstrapping or when PCL
 is fully up and running.
 
 An important effect of this arrangement is it means we can compile
-files with defmethod forms in them in a completely running PCL, but
+files with DEFMETHOD forms in them in a completely running PCL, but
 then load those files back in during bootstrapping. This makes
 development easier. It also means there is only one set of code for
-processing defmethod. Bootstrapping works by being sure to have
-load-method be careful to call only primitives which work during
+processing DEFMETHOD. Bootstrapping works by being sure to have
+LOAD-METHOD be careful to call only primitives which work during
 bootstrapping.
 
 |#
 
+;;; FIXME: As of sbcl-0.6.9.10, PCL still uses this nonstandard type
+;;; of declaration internally. It would be good to figure out how to
+;;; get rid of it, or failing that, (1) document why it's needed and
+;;; (2) use a private symbol with a forbidding name which suggests
+;;; it's not to be messed with by the user (e.g. SB-PCL:%CLASS)
+;;; instead of the too-inviting CLASS. (I tried just deleting the
+;;; declarations in MAKE-METHOD-LAMBDA-INTERNAL ca. sbcl-0.6.9.10, but
+;;; then things break.)
+(declaim (declaration class))
+
 ;;; FIXME: SB-KERNEL::PCL-CHECK-WRAPPER-VALIDITY-HOOK shouldn't be a
 ;;; separate function. Instead, we should define a simple placeholder
 ;;; version of SB-PCL:CHECK-WRAPPER-VALIDITY where
@@ -84,7 +94,7 @@ bootstrapping.
                    add-method
                    remove-method))
 
-(defvar *early-functions*
+(defvar *!early-functions*
        '((make-a-method early-make-a-method
                         real-make-a-method)
          (add-named-method early-add-named-method
@@ -109,17 +119,17 @@ bootstrapping.
             (apply (the function (symbol-function early)) args))
         real)))
 
-(dolist (fns *early-functions*)
+(dolist (fns *!early-functions*)
   (let ((name (car fns))
        (early-name (cadr fns)))
     (redirect-early-function-internal name early-name)))
 
 ) ; EVAL-WHEN
 
-;;; *GENERIC-FUNCTION-FIXUPS* is used by fix-early-generic-functions to
-;;; convert the few functions in the bootstrap which are supposed to be
-;;; generic functions but can't be early on.
-(defvar *generic-function-fixups*
+;;; *!GENERIC-FUNCTION-FIXUPS* is used by !FIX-EARLY-GENERIC-FUNCTIONS
+;;; to convert the few functions in the bootstrap which are supposed
+;;; to be generic functions but can't be early on.
+(defvar *!generic-function-fixups*
   '((add-method
      ((generic-function method)         ;lambda-list
       (standard-generic-function method) ;specializers
@@ -507,9 +517,9 @@ bootstrapping.
               (calls (list nil))
               (class-declarations
                `(declare
-                 ;; FIXME: Are these (DECLARE (SB-PCL::CLASS FOO BAR))
-                 ;; declarations used for anything any more?
-                  ;; WHN 2000-12-21: I think not, commented 'em out to see..
+                 ;; FIXME: These nonstandard (DECLARE (SB-PCL::CLASS FOO BAR))
+                 ;; declarations should go away but as of 0.6.9.10, it's not
+                 ;; as simple as just deleting them.
                  ,@(remove nil
                            (mapcar (lambda (a s) (and (symbolp s)
                                                       (neq s 't)
@@ -1379,7 +1389,7 @@ bootstrapping.
 \f
 ;;;; early generic function support
 
-(defvar *early-generic-functions* ())
+(defvar *!early-generic-functions* ())
 
 (defun ensure-generic-function (function-name
                                &rest all-keys
@@ -1634,12 +1644,12 @@ bootstrapping.
                               (class-name (cadr specls)))))))))
   arg-info)
 
-;;; This is the early definition of ensure-generic-function-using-class.
+;;; This is the early definition of ENSURE-GENERIC-FUNCTION-USING-CLASS.
 ;;;
-;;; The static-slots field of the funcallable instances used as early generic
-;;; functions is used to store the early methods and early discriminator code
-;;; for the early generic function. The static slots field of the fins
-;;; contains a list whose:
+;;; The STATIC-SLOTS field of the funcallable instances used as early
+;;; generic functions is used to store the early methods and early
+;;; discriminator code for the early generic function. The static
+;;; slots field of the fins contains a list whose:
 ;;;    CAR    -   a list of the early methods on this early gf
 ;;;    CADR   -   the early discriminator code for this method
 (defun ensure-generic-function-using-class (existing spec &rest keys
@@ -1648,16 +1658,16 @@ bootstrapping.
   (declare (ignore keys))
   (cond ((and existing (early-gf-p existing))
         existing)
-       ((assoc spec *generic-function-fixups* :test #'equal)
+       ((assoc spec *!generic-function-fixups* :test #'equal)
         (if existing
             (make-early-gf spec lambda-list lambda-list-p existing)
             (error "The function ~S is not already defined." spec)))
        (existing
         (error "~S should be on the list ~S."
                spec
-               '*generic-function-fixups*))
+               '*!generic-function-fixups*))
        (t
-        (pushnew spec *early-generic-functions* :test #'equal)
+        (pushnew spec *!early-generic-functions* :test #'equal)
         (make-early-gf spec lambda-list lambda-list-p))))
 
 (defun make-early-gf (spec &optional lambda-list lambda-list-p function)
@@ -1919,21 +1929,22 @@ bootstrapping.
     (when existing (remove-method gf existing))
     (add-method gf new)))
 
-;;; This is the early version of add-method. Later this will become a
-;;; generic function. See fix-early-generic-functions which has special
-;;; knowledge about add-method.
+;;; This is the early version of ADD-METHOD. Later this will become a
+;;; generic function. See !FIX-EARLY-GENERIC-FUNCTIONS which has special
+;;; knowledge about ADD-METHOD.
 (defun add-method (generic-function method)
   (when (not (fsc-instance-p generic-function))
-    (error "Early add-method didn't get a funcallable instance."))
+    (error "Early ADD-METHOD didn't get a funcallable instance."))
   (when (not (and (listp method) (eq (car method) :early-method)))
-    (error "Early add-method didn't get an early method."))
+    (error "Early ADD-METHOD didn't get an early method."))
   (push method (early-gf-methods generic-function))
   (set-arg-info generic-function :new-method method)
-  (unless (assoc (early-gf-name generic-function) *generic-function-fixups*
+  (unless (assoc (early-gf-name generic-function) *!generic-function-fixups*
                 :test #'equal)
     (update-dfun generic-function)))
 
-;;; This is the early version of REMOVE-METHOD..
+;;; This is the early version of REMOVE-METHOD. See comments on
+;;; the early version of ADD-METHOD.
 (defun remove-method (generic-function method)
   (when (not (fsc-instance-p generic-function))
     (error "An early remove-method didn't get a funcallable instance."))
@@ -1942,11 +1953,12 @@ bootstrapping.
   (setf (early-gf-methods generic-function)
        (remove method (early-gf-methods generic-function)))
   (set-arg-info generic-function)
-  (unless (assoc (early-gf-name generic-function) *generic-function-fixups*
+  (unless (assoc (early-gf-name generic-function) *!generic-function-fixups*
                 :test #'equal)
     (update-dfun generic-function)))
 
-;;; ..and the early version of GET-METHOD.
+;;; This is the early version of GET-METHOD. See comments on the early
+;;; version of ADD-METHOD.
 (defun get-method (generic-function qualifiers specializers
                                    &optional (errorp t))
   (if (early-gf-p generic-function)
@@ -1962,13 +1974,13 @@ bootstrapping.
              nil))
       (real-get-method generic-function qualifiers specializers errorp)))
 
-(defvar *fegf-debug-p* nil)
-
-(defun fix-early-generic-functions (&optional (noisyp *fegf-debug-p*))
+(defun !fix-early-generic-functions ()
+  (sb-int:/show "entering !FIX-EARLY-GENERIC-FUNCTIONS")
   (let ((accessors nil))
-    ;; Rearrange *EARLY-GENERIC-FUNCTIONS* to speed up
+    ;; Rearrange *!EARLY-GENERIC-FUNCTIONS* to speed up
     ;; FIX-EARLY-GENERIC-FUNCTIONS.
-    (dolist (early-gf-spec *early-generic-functions*)
+    (dolist (early-gf-spec *!early-generic-functions*)
+      (sb-int:/show early-gf-spec)
       (when (every #'early-method-standard-accessor-p
                   (early-gf-methods (gdefinition early-gf-spec)))
        (push early-gf-spec accessors)))
@@ -1991,11 +2003,13 @@ bootstrapping.
                           standard-class-p
                           funcallable-standard-class-p
                           specializerp)))
-      (setq *early-generic-functions*
-           (cons spec (delete spec *early-generic-functions* :test #'equal))))
+      (sb-int:/show spec)
+      (setq *!early-generic-functions*
+           (cons spec
+                 (delete spec *!early-generic-functions* :test #'equal))))
 
-    (dolist (early-gf-spec *early-generic-functions*)
-      (when noisyp (format t "~&~S..." early-gf-spec))
+    (dolist (early-gf-spec *!early-generic-functions*)
+      (sb-int:/show early-gf-spec)
       (let* ((gf (gdefinition early-gf-spec))
             (methods (mapcar #'(lambda (early-method)
                                  (let ((args (copy-list (fifth
@@ -2010,10 +2024,12 @@ bootstrapping.
              *standard-method-combination*)
        (set-methods gf methods)))
 
-    (dolist (fns *early-functions*)
-      (setf (gdefinition (car fns)) (symbol-function (caddr fns))))
+    (dolist (fn *!early-functions*)
+      (sb-int:/show fn)
+      (setf (gdefinition (car fn)) (symbol-function (caddr fn))))
 
-    (dolist (fixup *generic-function-fixups*)
+    (dolist (fixup *!generic-function-fixups*)
+      (sb-int:/show fixup)
       (let* ((fspec (car fixup))
             (gf (gdefinition fspec))
             (methods (mapcar #'(lambda (method)
@@ -2041,7 +2057,8 @@ bootstrapping.
        (setf (generic-function-method-class gf) *the-class-standard-method*)
        (setf (generic-function-method-combination gf)
              *standard-method-combination*)
-       (set-methods gf methods)))))
+       (set-methods gf methods))))
+  (sb-int:/show "leaving !FIX-EARLY-GENERIC-FUNCTIONS"))
 \f
 ;;; PARSE-DEFMETHOD is used by DEFMETHOD to parse the &REST argument into
 ;;; the 'real' arguments. This is where the syntax of DEFMETHOD is really
index b331634..c99a787 100644 (file)
       (if (find specls (early-gf-methods gf)
                :key #'early-method-specializers
                :test 'equal)
-         (unless (assoc accessor-name *generic-function-fixups*
+         (unless (assoc accessor-name *!generic-function-fixups*
                         :test #'equal)
            (update-dfun gf))
          (add-method gf
index 26ec86f..b759071 100644 (file)
@@ -23,7 +23,7 @@
 
 (in-package "SB-PCL")
 
-(fix-early-generic-functions)
+(!fix-early-generic-functions)
 (setq *boot-state* 'complete)
 
 (defun print-std-instance (instance stream depth)
index 871eb56..3018510 100644 (file)
  ("code/setf-funs" :not-host)
 
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;; compiler (and a few miscellaneous :NOT-HOST files whose
- ;;; dependencies make it convenient to stick them here)
+ ;;; compiler (and a few miscellaneous files whose dependencies make it
+ ;;; convenient to stick them here)
 
  ("compiler/early-c")
+ ("compiler/policy")
  ("code/numbers")
 
  ("code/typedefs")
index a4477fa..83b89b7 100644 (file)
@@ -15,4 +15,4 @@
 ;;; versions, and a string like "0.6.5.12" is used for versions which
 ;;; aren't released but correspond only to CVS tags or snapshots.
 
-"0.6.9.10"
+"0.6.9.12"