From 92e1f9618503c9091186b749116dd4f4c180e4ef Mon Sep 17 00:00:00 2001 From: Douglas Katzman Date: Sat, 17 Jan 2015 14:11:33 -0500 Subject: [PATCH] Teach Genesis a new trick to increase OAOO-ness. This pair of forms can now be handled as just a !DEFGLOBAL (defglobal *thing* (make-array...)) #-sb-xc-host (!cold-init-forms (setq *thing* (make-array...))) provided that result of MAKE-ARRAY is sufficiently simple. Also rename VECTOR-TO-CORE back to VECTOR-IN-CORE. --- src/code/cold-init-helper-macros.lisp | 10 ++++----- src/compiler/generic/genesis.lisp | 39 +++++++++++++++++++++-------------- src/compiler/globaldb.lisp | 6 ++---- 3 files changed, 30 insertions(+), 25 deletions(-) diff --git a/src/code/cold-init-helper-macros.lisp b/src/code/cold-init-helper-macros.lisp index 288d0f8eb..84d0b5f83 100644 --- a/src/code/cold-init-helper-macros.lisp +++ b/src/code/cold-init-helper-macros.lisp @@ -61,7 +61,8 @@ ;;; (!defun-from-cold-init-forms !some-cold-init-fun) ;;; or the less respectable (defvar *foo*) and a random SETQ in !COLD-INIT. ;;; Each is like its namesake, but also arranges so that genesis knows -;;; the initial toplevel value, which must be a constant of a restricted type. +;;; the initialization form, on which it calls EVAL and dumps as a constant +;;; when writing out the cold core image. (macrolet ((def (wrapper real-name) `(defmacro ,wrapper (sym value &optional (doc nil doc-p)) `(progn (eval-when (:compile-toplevel) @@ -71,12 +72,11 @@ (def !defparameter defparameter) (def !defvar defvar)) -(defun !delayed-cold-set-symbol-value (symbol value) - (assert (or (typep value '(or (member t nil) keyword number string - (cons (eql quote) (cons t null)))))) +(defun !delayed-cold-set-symbol-value (symbol value-form) ;; Obfuscate the reference into SB-COLD to avoid "bad package for target" (let ((list (find-symbol "*SYMBOL-VALUES-FOR-GENESIS*" "SB-COLD"))) - (set list (acons symbol (if (consp value) (second value) value) + (set list (acons symbol + (cons value-form (package-name *package*)) (delete symbol (symbol-value list) :key #'car))))) ;;; FIXME: Consider renaming this file asap.lisp, diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index ead2a730d..2f8e3c81b 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -800,10 +800,9 @@ core and return a descriptor to it." ;;; Make a simple-vector on the target that holds the specified ;;; OBJECTS, and return its descriptor. -;;; Oops, this function was renamed (by me) for the wrong reason - that it -;;; was unharmonious with other -TO-CORE functions, however X-TO-CORE -;;; should accept an argument of type X which this doesn't (FIXME). -(defun vector-to-core (objects &optional (gspace *dynamic*)) +;;; This is really "vectorify-list-into-core" but that's too wordy, +;;; so historically it was "vector-in-core" which is a fine name. +(defun vector-in-core (objects &optional (gspace *dynamic*)) (let* ((size (length objects)) (result (allocate-vector-object gspace sb!vm:n-word-bits size sb!vm:simple-vector-widetag))) @@ -1017,7 +1016,7 @@ core and return a descriptor to it." ;; Nothing in cold-init needs to call EQUALP on a structure with raw slots, ;; but for type-correctness this slot needs to be a simple-vector. (unless (boundp '*simple-vector-0-descriptor*) - (setq *simple-vector-0-descriptor* (vector-to-core nil))) + (setq *simple-vector-0-descriptor* (vector-in-core nil))) (cold-set-layout-slot result 'equalp-tests *simple-vector-0-descriptor*)) (cold-set-layout-slot result 'source-location *nil-descriptor*) (cold-set-layout-slot result '%for-std-class-b (make-fixnum-descriptor 0)) @@ -1056,7 +1055,7 @@ core and return a descriptor to it." (make-cold-layout name (number-to-core (layout-length warm-layout)) - (vector-to-core inherits) + (vector-in-core inherits) (number-to-core (layout-depthoid warm-layout)) (number-to-core (layout-raw-slot-metadata warm-layout)))))) (let* ((t-layout (chill-layout 't)) @@ -1213,18 +1212,23 @@ core and return a descriptor to it." (bug "~A in bad package for target: ~A" symbol result)) result)))) -;;; Assign target representation of VALUE to DESCRIPTOR. -;;; The VALUE should not have shared substructure in a way that matters, -;;; because sharing detection is not performed. It must not have cycles. -(defun cold-set-symbol-global-value (descriptor value) +;;; Dump the target representation of HOST-VALUE, +;;; the type of which is in a restrictive set. +(defun host-constant-to-core (host-value) + ;; rough check for no shared substructure and/or circularity. + ;; of course this would be wrong if it were a string containing "#1=" + (when (search "#1=" (write-to-string host-value :circle t :readably t)) + (warn "Strange constant to core from Genesis: ~S" host-value)) (labels ((target-representation (value) (etypecase value (symbol (cold-intern value)) (number (number-to-core value)) (string (base-string-to-core value)) (cons (cold-cons (target-representation (car value)) - (target-representation (cdr value))))))) - (cold-set descriptor (target-representation value)))) + (target-representation (cdr value)))) + (simple-vector + (vector-in-core (map 'list #'target-representation value)))))) + (target-representation host-value))) ;;; Return a handle on an interned symbol. If necessary allocate the ;;; symbol and record its home package. @@ -1260,7 +1264,10 @@ core and return a descriptor to it." (setq access :external) (cold-set handle handle)) ((assoc symbol sb-cold:*symbol-values-for-genesis*) - (cold-set-symbol-global-value handle (cdr it)))) + (cold-set handle + (host-constant-to-core + (let ((*package* (find-package (cddr it)))) + (eval (cadr it))))))) (setf (get symbol 'cold-intern-info) handle)))) (defun record-accessibility (accessibility symbol-descriptor target-pkg-info @@ -1458,8 +1465,8 @@ core and return a descriptor to it." (record-accessibility accessibility (cold-intern sym) pkg-info sym host-pkg))))) (cold-push (cold-cons (car pkg-info) - (cold-cons (vector-to-core (cadr pkg-info)) - (vector-to-core (cddr pkg-info)))) + (cold-cons (vector-in-core (cadr pkg-info)) + (vector-in-core (cddr pkg-info)))) cold-pkg-inits))) (cold-set 'sb!impl::*!initial-symbols* cold-pkg-inits)) @@ -1623,7 +1630,7 @@ core and return a descriptor to it." (cold-intern warm-sym) sb!vm:symbol-info-slot ;; Each vector will have one fixnum, possibly the symbol SETF, ;; and one or two # objects in it. - (vector-to-core + (vector-in-core (map 'list (lambda (elt) (etypecase elt (symbol (cold-intern elt)) diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index 746442f8c..6680c5b81 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -121,7 +121,8 @@ ;;; compiler as we can make it, i.e. identical in most ways, including ;;; this one. -- WHN 2001-08-19 (declaim (type (simple-vector #.(ash 1 type-number-bits)) *info-types*)) -(defglobal *info-types* (make-array (ash 1 type-number-bits) :initial-element nil)) +(!defglobal *info-types* + (make-array (ash 1 type-number-bits) :initial-element nil)) (defstruct (type-info #-no-ansi-print-object @@ -795,9 +796,6 @@ ;;; load time to the same state they have currently. (!cold-init-forms (/show0 "beginning *INFO-TYPES* initialization") - #-sb-xc-host - ;; Host already has this array, do not clobber it - (setq *info-types* (make-array (ash 1 type-number-bits) :initial-element nil)) (mapc (lambda (x) (register-info-metadata (first x) (second x) (third x) (fourth x))) '#.(loop for info-type across *info-types* -- 2.11.4.GIT