X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=72c6be073402489630298c7b6be1904129558efd;hb=0af84c9c90b1277be6863df8f28f1f0e5512323c;hp=277f0c6849624e84c660bf640de3e6311dbb2467;hpb=f3783ae14bde14c5aefd3d9383d89379defcb00f;p=sbcl.git diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 277f0c6..72c6be0 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -6,13 +6,20 @@ ;;;; As explained by Rob MacLachlan on the CMU CL mailing list Wed, 06 ;;;; Jan 1999 11:05:02 -0500, this cold load generator more or less ;;;; fakes up static function linking. I.e. it makes sure that all the -;;;; functions in the fasl files it reads are bound to the +;;;; DEFUN-defined functions in the fasl files it reads are bound to the ;;;; corresponding symbols before execution starts. It doesn't do ;;;; anything to initialize variable values; instead it just arranges ;;;; for !COLD-INIT to be called at cold load time. !COLD-INIT is ;;;; responsible for explicitly initializing anything which has to be ;;;; initialized early before it transfers control to the ordinary ;;;; top-level forms. +;;;; +;;;; (In CMU CL, and in SBCL as of 0.6.9 anyway, functions not defined +;;;; by DEFUN aren't set up specially by GENESIS. In particular, +;;;; structure slot accessors are not set up. Slot accessors are +;;;; available at cold init time because they're usually compiled +;;;; inline. They're not available as out-of-line functions until the +;;;; toplevel forms installing them have run.) ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -25,10 +32,7 @@ (in-package "SB!IMPL") -(file-comment - "$Header$") - -;;; a magic number used to identify core files +;;; a magic number used to identify our core files (defconstant core-magic (logior (ash (char-code #\S) 24) (ash (char-code #\B) 16) @@ -44,7 +48,12 @@ ;;; IP packets), and in fact the CMU CL version number never ended up ;;; being incremented past 0. A better approach might be to use a ;;; string which is set from CVS data. -(defconstant sbcl-core-version-integer 0) +;;; +;;; 0: inherited from CMU CL +;;; 1: rearranged static symbols for sbcl-0.6.8 +;;; 2: eliminated non-ANSI %DEFCONSTANT/%%DEFCONSTANT support, +;;; deleted a slot from DEBUG-SOURCE structure +(defconstant sbcl-core-version-integer 2) (defun round-up (number size) #!+sb-doc @@ -62,16 +71,16 @@ (defvar *read-only*) (defconstant read-only-space-id 3) -(eval-when (:compile-toplevel :execute :load-toplevel) - (defconstant descriptor-low-bits 16 - "the number of bits in the low half of the descriptor") - (defconstant target-space-alignment (ash 1 descriptor-low-bits) - "the alignment requirement for spaces in the target. - Must be at least (ASH 1 DESCRIPTOR-LOW-BITS)")) +(defconstant descriptor-low-bits 16 + "the number of bits in the low half of the descriptor") +(defconstant target-space-alignment (ash 1 descriptor-low-bits) + "the alignment requirement for spaces in the target. + Must be at least (ASH 1 DESCRIPTOR-LOW-BITS)") ;;; a GENESIS-time representation of a memory space (e.g. read-only space, ;;; dynamic space, or static space) -(defstruct (gspace (:constructor %make-gspace)) +(defstruct (gspace (:constructor %make-gspace) + (:copier nil)) ;; name and identifier for this GSPACE (name (required-argument) :type symbol :read-only t) (identifier (required-argument) :type fixnum :read-only t) @@ -121,7 +130,8 @@ (defstruct (descriptor (:constructor make-descriptor - (high low &optional gspace word-offset))) + (high low &optional gspace word-offset)) + (:copier nil)) ;; the GSPACE that this descriptor is allocated in, or NIL if not set yet. (gspace nil :type (or gspace null)) ;; the offset in words from the start of GSPACE, or NIL if not set yet @@ -334,7 +344,7 @@ ;;; comparing the byte order of *BACKEND* to the byte order of ;;; *NATIVE-BACKEND*, a concept which doesn't exist in SBCL. Instead, ;;; in SBCL byte order swapping would need to be explicitly requested -;;; with a keyword argument to GENESIS. +;;; with a &KEY argument to GENESIS. ;;; ;;; I'm not sure whether this is a problem or not, and I don't have a ;;; machine with different byte order to test to find out for sure. @@ -365,8 +375,8 @@ (defun maybe-byte-swap (word) (declare (type (unsigned-byte 32) word)) - (assert (= sb!vm:word-bits 32)) - (assert (= sb!vm:byte-bits 8)) + (aver (= sb!vm:word-bits 32)) + (aver (= sb!vm:byte-bits 8)) (if (not *genesis-byte-order-swap-p*) word (logior (ash (ldb (byte 8 0) word) 24) @@ -376,8 +386,8 @@ (defun maybe-byte-swap-short (short) (declare (type (unsigned-byte 16) short)) - (assert (= sb!vm:word-bits 32)) - (assert (= sb!vm:byte-bits 8)) + (aver (= sb!vm:word-bits 32)) + (aver (= sb!vm:byte-bits 8)) (if (not *genesis-byte-order-swap-p*) short (logior (ash (ldb (byte 8 0) short) 8) @@ -385,8 +395,8 @@ ;;; like SAP-REF-32, except that instead of a SAP we use a byte vector (defun byte-vector-ref-32 (byte-vector byte-index) - (assert (= sb!vm:word-bits 32)) - (assert (= sb!vm:byte-bits 8)) + (aver (= sb!vm:word-bits 32)) + (aver (= sb!vm:byte-bits 8)) (ecase sb!c:*backend-byte-order* (:little-endian (logior (ash (aref byte-vector (+ byte-index 0)) 0) @@ -396,8 +406,8 @@ (:big-endian (error "stub: no big-endian ports of SBCL (yet?)")))) (defun (setf byte-vector-ref-32) (new-value byte-vector byte-index) - (assert (= sb!vm:word-bits 32)) - (assert (= sb!vm:byte-bits 8)) + (aver (= sb!vm:word-bits 32)) + (aver (= sb!vm:byte-bits 8)) (ecase sb!c:*backend-byte-order* (:little-endian (setf (aref byte-vector (+ byte-index 0)) (ldb (byte 8 0) new-value) @@ -716,7 +726,7 @@ ;;;; symbol magic -;;; FIXME: This should be a keyword argument of ALLOCATE-SYMBOL. +;;; FIXME: This should be a &KEY argument of ALLOCATE-SYMBOL. (defvar *cold-symbol-allocation-gspace* nil) ;;; Allocate (and initialize) a symbol. @@ -1547,7 +1557,7 @@ (#.sb!c:pmax-fasl-file-implementation (ecase kind (:jump - (assert (zerop (ash value -28))) + (aver (zerop (ash value -28))) (setf (ldb (byte 26 0) (sap-ref-32 sap 0)) (ash value -2))) (:lui @@ -1603,9 +1613,9 @@ gspace-byte-offset)) (code-object-start-addr (logandc2 (descriptor-bits code-object) sb!vm:lowtag-mask))) - (assert (= code-object-start-addr - (+ gspace-byte-address - (descriptor-byte-offset code-object)))) + (aver (= code-object-start-addr + (+ gspace-byte-address + (descriptor-byte-offset code-object)))) (ecase kind (:absolute (let ((fixed-up (+ value un-fixed-up))) @@ -1653,7 +1663,7 @@ (logand inst #xffffc000))) (:load-short (let ((low-bits (ldb (byte 11 0) value))) - (assert (<= 0 low-bits (1- (ash 1 4)))) + (aver (<= 0 low-bits (1- (ash 1 4)))) (logior (ash low-bits 17) (logand inst #xffe0ffff)))) (:hi @@ -1665,13 +1675,13 @@ (logand inst #xffe00000))) (:branch (let ((bits (ldb (byte 9 2) value))) - (assert (zerop (ldb (byte 2 0) value))) + (aver (zerop (ldb (byte 2 0) value))) (logior (ash bits 3) (logand inst #xffe0e002))))))))) (#.sb!c:alpha-fasl-file-implementation (ecase kind (:jmp-hint - (assert (zerop (ldb (byte 2 0) value))) + (aver (zerop (ldb (byte 2 0) value))) #+nil (setf (sap-ref-16 sap 0) (logior (sap-ref-16 sap 0) (ldb (byte 14 0) (ash value -2))))) @@ -1696,7 +1706,7 @@ (#.sb!c:sgi-fasl-file-implementation (ecase kind (:jump - (assert (zerop (ash value -28))) + (aver (zerop (ash value -28))) (setf (ldb (byte 26 0) (sap-ref-32 sap 0)) (ash value -2))) (:lui @@ -1740,16 +1750,17 @@ (defvar *normal-fop-functions*) -;;; This is like DEFINE-FOP which defines fops for warm load, but unlike -;;; DEFINE-FOP, this version -;;; (1) looks up the code for this name (created by a previous DEFINE-FOP) -;;; instead of creating a code, and -;;; (2) stores its definition in the *COLD-FOP-FUNCTIONS* vector, instead -;;; of storing in the *FOP-FUNCTIONS* vector. +;;; Cause a fop to have a special definition for cold load. +;;; +;;; This is similar to DEFINE-FOP, but unlike DEFINE-FOP, this version +;;; (1) looks up the code for this name (created by a previous +;; DEFINE-FOP) instead of creating a code, and +;;; (2) stores its definition in the *COLD-FOP-FUNCTIONS* vector, +;;; instead of storing in the *FOP-FUNCTIONS* vector. (defmacro define-cold-fop ((name &optional (pushp t)) &rest forms) - (check-type pushp (member nil t :nope)) + (aver (member pushp '(nil t :nope))) (let ((code (get name 'fop-code)) - (fname (concat-pnames 'cold- name))) + (fname (symbolicate "COLD-" name))) (unless code (error "~S is not a defined FOP." name)) `(progn @@ -1760,7 +1771,7 @@ (setf (svref *cold-fop-functions* ,code) #',fname)))) (defmacro clone-cold-fop ((name &optional (pushp t)) (small-name) &rest forms) - (check-type pushp (member nil t :nope)) + (aver (member pushp '(nil t :nope))) `(progn (macrolet ((clone-arg () '(read-arg 4))) (define-cold-fop (,name ,pushp) ,@forms)) @@ -1772,8 +1783,9 @@ `(define-cold-fop (,name) (error "The fop ~S is not supported in cold load." ',name))) -;;; COLD-LOAD loads stuff into the core image being built by calling FASLOAD -;;; with the fop function table rebound to a table of cold loading functions. +;;; COLD-LOAD loads stuff into the core image being built by calling +;;; LOAD-AS-FASL with the fop function table rebound to a table of cold +;;; loading functions. (defun cold-load (filename) #!+sb-doc "Load the file named by FILENAME into the cold load image being built." @@ -1783,7 +1795,7 @@ (string filename) (pathname (namestring filename))))) (with-open-file (s filename :element-type '(unsigned-byte 8)) - (fasload s nil nil)))) + (load-as-fasl s nil nil)))) ;;;; miscellaneous cold fops @@ -1848,7 +1860,7 @@ (declare (type index old-length)) (declare (type fixnum old-depthoid)) (declare (type list old-inherits-list)) - (assert (eq name old-name)) + (aver (eq name old-name)) (let ((length (descriptor-fixnum length-des)) (inherits-list (listify-cold-inherits cold-inherits)) (depthoid (descriptor-fixnum depthoid-des))) @@ -2500,6 +2512,7 @@ (defun write-c-header () + ;; writing beginning boilerplate (format t "/*~%") (dolist (line '("This is a machine-generated file. Do not edit it by hand." @@ -2514,17 +2527,16 @@ (format t " * ~A~%" line)) (format t " */~%") (terpri) - (format t "#ifndef _SBCL_H_~%#define _SBCL_H_~%") (terpri) + ;; writing miscellaneous constants (format t "#define SBCL_CORE_VERSION_INTEGER ~D~%" sbcl-core-version-integer) (format t "#define SBCL_VERSION_STRING ~S~%" (sb!xc:lisp-implementation-version)) (format t "#define CORE_MAGIC 0x~X~%" core-magic) (terpri) - ;; FIXME: Other things from core.h should be defined here too: ;; #define CORE_END 3840 ;; #define CORE_NDIRECTORY 3861 @@ -2537,38 +2549,54 @@ ;; #define STATIC_SPACE_ID (2) ;; #define READ_ONLY_SPACE_ID (3) + ;; writing entire families of named constants from SB!VM (let ((constants nil)) (do-external-symbols (symbol (find-package "SB!VM")) (when (constantp symbol) (let ((name (symbol-name symbol))) - (labels - ((record (prefix string priority) - (push (list (concatenate - 'simple-string - prefix - (delete #\- (string-capitalize string))) - priority - (symbol-value symbol) - (fdocumentation symbol 'variable)) - constants)) - (test-tail (tail prefix priority) - (when (tail-comp name tail) - (record prefix - (subseq name 0 - (- (length name) - (length tail))) - priority))) - (test-head (head prefix priority) - (when (head-comp name head) - (record prefix - (subseq name (length head)) - priority)))) + (labels (;; shared machinery + (record (string priority) + (push (list string + priority + (symbol-value symbol) + (documentation symbol 'variable)) + constants)) + ;; machinery for old-style CMU CL Lisp-to-C naming + (record-with-munged-name (prefix string priority) + (record (concatenate + 'simple-string + prefix + (delete #\- (string-capitalize string))) + priority)) + (test-tail (tail prefix priority) + (when (tail-comp name tail) + (record-with-munged-name prefix + (subseq name 0 + (- (length name) + (length tail))) + priority))) + (test-head (head prefix priority) + (when (head-comp name head) + (record-with-munged-name prefix + (subseq name (length head)) + priority))) + ;; machinery for new-style SBCL Lisp-to-C naming + (record-with-translated-name (priority) + (record (substitute #\_ #\- name) + priority))) + ;; This style of munging of names is used in the code + ;; inherited from CMU CL. (test-tail "-TYPE" "type_" 0) (test-tail "-FLAG" "flag_" 1) (test-tail "-TRAP" "trap_" 2) (test-tail "-SUBTYPE" "subtype_" 3) (test-head "TRACE-TABLE-" "tracetab_" 4) - (test-tail "-SC-NUMBER" "sc_" 5))))) + (test-tail "-SC-NUMBER" "sc_" 5) + ;; This simpler style of translation of names seems less + ;; confusing, and is used for newer code. + (when (some (lambda (suffix) (tail-comp name suffix)) + #("-START" "-END")) + (record-with-translated-name 6)))))) (setf constants (sort constants #'(lambda (const1 const2) @@ -2577,23 +2605,50 @@ (< (second const1) (second const2)))))) (let ((prev-priority (second (car constants)))) (dolist (const constants) - (unless (= prev-priority (second const)) - (terpri) - (setf prev-priority (second const))) - (format t - "#define ~A ~D /* 0x~X */~@[ /* ~A */~]~%" - (first const) - (third const) - (third const) - (fourth const)))) - (terpri) - (format t "#define ERRORS { \\~%") - ;; FIXME: Is this just DO-VECTOR? - (let ((internal-errors sb!c:*backend-internal-errors*)) - (dotimes (i (length internal-errors)) - (format t " ~S, /*~D*/ \\~%" (cdr (aref internal-errors i)) i))) - (format t " NULL \\~%}~%") + (destructuring-bind (name priority value doc) const + (unless (= prev-priority priority) + (terpri) + (setf prev-priority priority)) + (format t "#define ~A " name) + (format t + ;; KLUDGE: As of sbcl-0.6.7.14, we're dumping two + ;; different kinds of values here, (1) small codes + ;; and (2) machine addresses. The small codes can be + ;; dumped as bare integer values. The large machine + ;; addresses might cause problems if they're large + ;; and represented as (signed) C integers, so we + ;; want to force them to be unsigned. We do that by + ;; wrapping them in the LISPOBJ macro. (We could do + ;; it with a bare "(unsigned)" cast, except that + ;; this header file is used not only in C files, but + ;; also in assembly files, which don't understand + ;; the cast syntax. The LISPOBJ macro goes away in + ;; assembly files, but that shouldn't matter because + ;; we don't do arithmetic on address constants in + ;; assembly files. See? It really is a kludge..) -- + ;; WHN 2000-10-18 + (let (;; cutoff for treatment as a small code + (cutoff (expt 2 16))) + (cond ((minusp value) + (error "stub: negative values unsupported")) + ((< value cutoff) + "~D") + (t + "LISPOBJ(~D)"))) + value) + (format t " /* 0x~X */~@[ /* ~A */~]~%" value doc)))) (terpri)) + + ;; writing codes/strings for internal errors + (format t "#define ERRORS { \\~%") + ;; FIXME: Is this just DO-VECTOR? + (let ((internal-errors sb!c:*backend-internal-errors*)) + (dotimes (i (length internal-errors)) + (format t " ~S, /*~D*/ \\~%" (cdr (aref internal-errors i)) i))) + (format t " NULL \\~%}~%") + (terpri) + + ;; writing primitive object layouts (let ((structs (sort (copy-list sb!vm:*primitive-objects*) #'string< :key #'(lambda (obj) (symbol-name @@ -2627,6 +2682,8 @@ (- (* (sb!vm:slot-offset slot) sb!vm:word-bytes) lowtag))) (terpri)))) (format t "#endif /* LANGUAGE_ASSEMBLY */~2%")) + + ;; writing static symbol offsets (dolist (symbol (cons nil sb!vm:*static-symbols*)) ;; FIXME: It would be nice to use longer names NIL and (particularly) T ;; in #define statements. @@ -2639,10 +2696,12 @@ ;; We actually ran GENESIS, use the real value. (descriptor-bits (cold-intern symbol)) ;; We didn't run GENESIS, so guess at the address. - (+ sb!vm:*static-space-start* + (+ sb!vm:static-space-start sb!vm:word-bytes sb!vm:other-pointer-type (if symbol (sb!vm:static-symbol-offset symbol) 0))))) + + ;; Voila. (format t "~%#endif~%")) ;;;; writing map file @@ -2790,7 +2849,7 @@ initially undefined function references:~2%") ;; less expensively (ERROR, not CERROR), and which reports ;; "internal error" on failure. Use it here and elsewhere in the ;; system. - (assert (zerop rem)) + (aver (zerop rem)) (write-long floor)) (write-long pages) @@ -2940,13 +2999,13 @@ initially undefined function references:~2%") (*cold-package-symbols* nil) (*read-only* (make-gspace :read-only read-only-space-id - sb!vm:*read-only-space-start*)) + sb!vm:read-only-space-start)) (*static* (make-gspace :static static-space-id - sb!vm:*static-space-start*)) + sb!vm:static-space-start)) (*dynamic* (make-gspace :dynamic dynamic-space-id - sb!vm:*dynamic-space-start*)) + sb!vm:dynamic-space-start)) (*nil-descriptor* (make-nil-descriptor)) (*current-reversed-cold-toplevels* *nil-descriptor*) (*unbound-marker* (make-other-immediate-descriptor @@ -2983,7 +3042,7 @@ initially undefined function references:~2%") ;; much. (And the old CMU CL code is still useful for making ;; sure that the appropriate keywords and internal symbols end ;; up interned in the target Lisp, which is good, e.g. in order - ;; to make keyword arguments work right and in order to make + ;; to make &KEY arguments work right and in order to make ;; BACKTRACEs into target Lisp system code be legible.) (dolist (exported-name (sb-cold:read-from-file "common-lisp-exports.lisp-expr"))