X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=301d162842d2c404959829937ea2d6de82fe330e;hb=2912f5f6c2acb2da3b9fcc0f5afd1ca89782a9f8;hp=6ef6c4a63aee438882bd77cb27dd6a4fbc69cdf7;hpb=8a19c6876412b8ad1cf729297c2a373d63a0d0ec;p=sbcl.git diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 6ef6c4a..301d162 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -47,13 +47,20 @@ ;;; way to do this in high level data like this (as opposed to e.g. in ;;; 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. +;;; string which is set from CVS data. (Though now as of sbcl-0.7.8 or +;;; so, we have another problem that the core incompatibility +;;; detection mechanisms are on such a hair trigger -- with even +;;; different builds from the same sources being considered +;;; incompatible -- that any coarser-grained versioning mechanisms +;;; like this are largely irrelevant as long as the hair-triggering +;;; persists.) ;;; ;;; 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) +;;; 3: added build ID to cores to discourage sbcl/.core mismatch +(defconstant sbcl-core-version-integer 3) (defun round-up (number size) #!+sb-doc @@ -591,7 +598,7 @@ (des (allocate-vector-object gspace sb!vm:n-byte-bits (1+ length) - sb!vm:simple-string-widetag)) + sb!vm:simple-base-string-widetag)) (bytes (gspace-bytes gspace)) (offset (+ (* sb!vm:vector-data-offset sb!vm:n-word-bytes) (descriptor-byte-offset des)))) @@ -709,20 +716,32 @@ (ecase sb!c:*backend-byte-order* (:little-endian (write-wordindexed des sb!vm:complex-double-float-real-slot low-bits) - (write-wordindexed des (1+ sb!vm:complex-double-float-real-slot) high-bits)) + (write-wordindexed des + (1+ sb!vm:complex-double-float-real-slot) + high-bits)) (:big-endian (write-wordindexed des sb!vm:complex-double-float-real-slot high-bits) - (write-wordindexed des (1+ sb!vm:complex-double-float-real-slot) low-bits)))) + (write-wordindexed des + (1+ sb!vm:complex-double-float-real-slot) + low-bits)))) (let* ((imag (imagpart num)) (high-bits (make-random-descriptor (double-float-high-bits imag))) (low-bits (make-random-descriptor (double-float-low-bits imag)))) (ecase sb!c:*backend-byte-order* (:little-endian - (write-wordindexed des sb!vm:complex-double-float-imag-slot low-bits) - (write-wordindexed des (1+ sb!vm:complex-double-float-imag-slot) high-bits)) + (write-wordindexed des + sb!vm:complex-double-float-imag-slot + low-bits) + (write-wordindexed des + (1+ sb!vm:complex-double-float-imag-slot) + high-bits)) (:big-endian - (write-wordindexed des sb!vm:complex-double-float-imag-slot high-bits) - (write-wordindexed des (1+ sb!vm:complex-double-float-imag-slot) low-bits)))) + (write-wordindexed des + sb!vm:complex-double-float-imag-slot + high-bits) + (write-wordindexed des + (1+ sb!vm:complex-double-float-imag-slot) + low-bits)))) des)) ;;; Copy the given number to the core. @@ -1021,7 +1040,8 @@ ;;; ;;; ;;; -;;; ) +;;; +;;; ) ;;; ;;; KLUDGE: It would be nice to implement the sublists as instances of ;;; a DEFSTRUCT (:TYPE LIST). (They'd still be lists, but at least we'd be @@ -1245,14 +1265,15 @@ (macrolet ((frob (symbol) `(cold-set ',symbol (cold-fdefinition-object (cold-intern ',symbol))))) - (frob maybe-gc) + (frob sub-gc) (frob internal-error) (frob sb!kernel::control-stack-exhausted-error) (frob sb!di::handle-breakpoint) - (frob sb!di::handle-fun-end-breakpoint)) + (frob sb!di::handle-fun-end-breakpoint) + (frob sb!thread::handle-thread-exit)) - (cold-set '*current-catch-block* (make-fixnum-descriptor 0)) - (cold-set '*current-unwind-protect-block* (make-fixnum-descriptor 0)) + (cold-set 'sb!vm::*current-catch-block* (make-fixnum-descriptor 0)) + (cold-set 'sb!vm::*current-unwind-protect-block* (make-fixnum-descriptor 0)) (cold-set '*free-interrupt-context-index* (make-fixnum-descriptor 0)) @@ -1264,6 +1285,7 @@ (let* ((cold-package (car cold-package-symbols-entry)) (symbols (cdr cold-package-symbols-entry)) (shadows (package-shadowing-symbols cold-package)) + (documentation (string-to-core (documentation cold-package t))) (internal *nil-descriptor*) (external *nil-descriptor*) (imported-internal *nil-descriptor*) @@ -1310,6 +1332,7 @@ (cold-push handle imported-external) (cold-push handle external))))))) (let ((r *nil-descriptor*)) + (cold-push documentation r) (cold-push shadowing r) (cold-push imported-external r) (cold-push imported-internal r) @@ -1740,7 +1763,25 @@ (logior (ash bits 3) (logand (bvref-32 gspace-bytes gspace-byte-offset) #xffe0e002))))))) - (:ppc + (:mips + (ecase kind + (:jump + (assert (zerop (ash value -28))) + (setf (ldb (byte 26 0) + (bvref-32 gspace-bytes gspace-byte-offset)) + (ash value -2))) + (:lui + (setf (bvref-32 gspace-bytes gspace-byte-offset) + (logior (mask-field (byte 16 16) + (bvref-32 gspace-bytes gspace-byte-offset)) + (+ (ash value -16) + (if (logbitp 15 value) 1 0))))) + (:addi + (setf (bvref-32 gspace-bytes gspace-byte-offset) + (logior (mask-field (byte 16 16) + (bvref-32 gspace-bytes gspace-byte-offset)) + (ldb (byte 16 0) value)))))) + (:ppc (ecase kind (:ba (setf (bvref-32 gspace-bytes gspace-byte-offset) @@ -1870,7 +1911,9 @@ forms)) (setf (svref *cold-fop-funs* ,code) #',fname)))) -(defmacro clone-cold-fop ((name &key (pushp t) (stackp t)) (small-name) &rest forms) +(defmacro clone-cold-fop ((name &key (pushp t) (stackp t)) + (small-name) + &rest forms) (aver (member pushp '(nil t))) (aver (member stackp '(nil t))) `(progn @@ -1902,8 +1945,6 @@ (define-cold-fop (fop-misc-trap) *unbound-marker*) -(define-cold-fop (fop-character) - (make-character-descriptor (read-arg 3))) (define-cold-fop (fop-short-character) (make-character-descriptor (read-arg 1))) @@ -1995,7 +2036,7 @@ (defun cold-load-symbol (size package) (let ((string (make-string size))) (read-string-as-bytes *fasl-input-stream* string) - (cold-intern (intern string package) package))) + (cold-intern (intern string package)))) (macrolet ((frob (name pname-len package-len) `(define-cold-fop (,name) @@ -2099,11 +2140,18 @@ (let* ((len (read-arg 4)) (sizebits (read-arg 1)) (type (case sizebits + (0 sb!vm:simple-array-nil-widetag) (1 sb!vm:simple-bit-vector-widetag) (2 sb!vm:simple-array-unsigned-byte-2-widetag) (4 sb!vm:simple-array-unsigned-byte-4-widetag) + (7 (prog1 sb!vm:simple-array-unsigned-byte-7-widetag + (setf sizebits 8))) (8 sb!vm:simple-array-unsigned-byte-8-widetag) + (15 (prog1 sb!vm:simple-array-unsigned-byte-15-widetag + (setf sizebits 16))) (16 sb!vm:simple-array-unsigned-byte-16-widetag) + (31 (prog1 sb!vm:simple-array-unsigned-byte-31-widetag + (setf sizebits 32))) (32 sb!vm:simple-array-unsigned-byte-32-widetag) (t (error "losing element size: ~W" sizebits)))) (result (allocate-vector-object *dynamic* sizebits len type)) @@ -2617,9 +2665,7 @@ (and (>= (length string) (length tail)) (string= string tail :start1 (- (length string) (length tail))))) -(defun write-c-header () - - ;; writing beginning boilerplate +(defun write-boilerplate () (format t "/*~%") (dolist (line '("This is a machine-generated file. Please do not edit it by hand." @@ -2632,11 +2678,9 @@ "load and run 'core' files, which are basically programs" "in SBCL's own format.")) (format t " * ~A~%" line)) - (format t " */~%") - (terpri) - (format t "#ifndef _SBCL_H_~%#define _SBCL_H_~%") - (terpri) + (format t " */~%")) +(defun write-config-h () ;; propagating *SHEBANG-FEATURES* into C-level #define's (dolist (shebang-feature-name (sort (mapcar #'symbol-name sb-cold:*shebang-features*) @@ -2645,15 +2689,20 @@ "#define LISP_FEATURE_~A~%" (substitute #\_ #\- shebang-feature-name))) (terpri) - - ;; writing miscellaneous constants + ;; and 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) - + (format t "#ifndef LANGUAGE_ASSEMBLY~2%") + (format t "#define LISPOBJ(x) ((lispobj)x)~2%") + (format t "#else /* LANGUAGE_ASSEMBLY */~2%") + (format t "#define LISPOBJ(thing) thing~2%") + (format t "#endif /* LANGUAGE_ASSEMBLY */~2%") + (terpri)) + +(defun write-constants-h () ;; writing entire families of named constants (let ((constants nil)) (dolist (package-name '(;; Even in CMU CL, constants from VM @@ -2771,28 +2820,30 @@ ;; type things. We therefore don't export it, but instead do #!+sparc (when (boundp 'sb!vm::pseudo-atomic-trap) - (format t "#define PSEUDO_ATOMIC_TRAP ~D /* 0x~:*~X */~%" sb!vm::pseudo-atomic-trap) + (format t + "#define PSEUDO_ATOMIC_TRAP ~D /* 0x~:*~X */~%" + sb!vm::pseudo-atomic-trap) (terpri)) ;; possibly this is another candidate for a rename (to ;; pseudo-atomic-trap-number or pseudo-atomic-magic-constant ;; [possibly applicable to other platforms]) - (dolist (symbol '(sb!vm::float-traps-byte sb!vm::float-exceptions-byte sb!vm::float-sticky-bits sb!vm::float-rounding-mode)) + (dolist (symbol '(sb!vm::float-traps-byte + sb!vm::float-exceptions-byte + sb!vm::float-sticky-bits + sb!vm::float-rounding-mode)) (format t "#define ~A_POSITION ~A /* ~:*0x~X */~%" (substitute #\_ #\- (symbol-name symbol)) (sb!xc:byte-position (symbol-value symbol))) (format t "#define ~A_MASK 0x~X /* ~:*~A */~%" (substitute #\_ #\- (symbol-name symbol)) - (sb!xc:mask-field (symbol-value symbol) -1))) + (sb!xc:mask-field (symbol-value symbol) -1)))) + + +(defun write-primitive-object (obj) ;; writing primitive object layouts - (let ((structs (sort (copy-list sb!vm:*primitive-objects*) #'string< - :key (lambda (obj) - (symbol-name - (sb!vm:primitive-object-name obj)))))) (format t "#ifndef LANGUAGE_ASSEMBLY~2%") - (format t "#define LISPOBJ(x) ((lispobj)x)~2%") - (dolist (obj structs) (format t "struct ~A {~%" (substitute #\_ #\- @@ -2805,10 +2856,8 @@ (substitute #\_ #\- (string-downcase (string (sb!vm:slot-name slot)))) (sb!vm:slot-rest-p slot))) - (format t "};~2%")) + (format t "};~2%") (format t "#else /* LANGUAGE_ASSEMBLY */~2%") - (format t "#define LISPOBJ(thing) thing~2%") - (dolist (obj structs) (let ((name (sb!vm:primitive-object-name obj)) (lowtag (eval (sb!vm:primitive-object-lowtag obj)))) (when lowtag @@ -2817,10 +2866,10 @@ (substitute #\_ #\- (string name)) (substitute #\_ #\- (string (sb!vm:slot-name slot))) (- (* (sb!vm:slot-offset slot) sb!vm:n-word-bytes) lowtag))) - (terpri)))) + (terpri))) (format t "#endif /* LANGUAGE_ASSEMBLY */~2%")) - ;; writing static symbol offsets +(defun write-static-symbols () (dolist (symbol (cons nil sb!vm:*static-symbols*)) ;; FIXME: It would be nice to use longer names than NIL and ;; (particularly) T in #define statements. @@ -2836,10 +2885,8 @@ (+ sb!vm:static-space-start sb!vm:n-word-bytes sb!vm:other-pointer-lowtag - (if symbol (sb!vm:static-symbol-offset symbol) 0))))) + (if symbol (sb!vm:static-symbol-offset symbol) 0)))))) - ;; Voila. - (format t "~%#endif~%")) ;;;; writing map file @@ -2906,7 +2953,18 @@ initially undefined function references:~2%") (defvar *core-file*) (defvar *data-page*) +;;; magic numbers to identify entries in a core file +;;; +;;; (In case you were wondering: No, AFAIK there's no special magic about +;;; these which requires them to be in the 38xx range. They're just +;;; arbitrary words, tested not for being in a particular range but just +;;; for equality. However, if you ever need to look at a .core file and +;;; figure out what's going on, it's slightly convenient that they're +;;; all in an easily recognizable range, and displacing the range away from +;;; zero seems likely to reduce the chance that random garbage will be +;;; misinterpreted as a .core file.) (defconstant version-core-entry-type-code 3860) +(defconstant build-id-core-entry-type-code 3899) (defconstant new-directory-core-entry-type-code 3861) (defconstant initial-fun-core-entry-type-code 3863) (defconstant end-core-entry-type-code 3840) @@ -3001,6 +3059,22 @@ initially undefined function references:~2%") (write-word 3) (write-word sbcl-core-version-integer) + ;; Write the build ID. + (write-word build-id-core-entry-type-code) + (let ((build-id (with-open-file (s "output/build-id.tmp" + :direction :input) + (read s)))) + (declare (type simple-string build-id)) + (/show build-id (length build-id)) + ;; Write length of build ID record: BUILD-ID-CORE-ENTRY-TYPE-CODE + ;; word, this length word, and one word for each char of BUILD-ID. + (write-word (+ 2 (length build-id))) + (dovector (char build-id) + ;; (We write each character as a word in order to avoid + ;; having to think about word alignment issues in the + ;; sbcl-0.7.8 version of coreparse.c.) + (write-word (char-code char)))) + ;; Write the New Directory entry header. (write-word new-directory-core-entry-type-code) (write-word 17) ; length = (5 words/space) * 3 spaces + 2 for header. @@ -3058,7 +3132,7 @@ initially undefined function references:~2%") symbol-table-file-name core-file-name map-file-name - c-header-file-name) + c-header-dir-name) (when (and core-file-name (not symbol-table-file-name)) @@ -3072,8 +3146,7 @@ initially undefined function references:~2%") ;; we're not e.g. also creating a header file when we ;; create a core. (format nil "creating core ~S" core-file-name) - (format nil "creating header ~S" c-header-file-name))) - + (format nil "creating headers in ~S" c-header-dir-name))) (let* ((*cold-foreign-symbol-table* (make-hash-table :test 'equal))) ;; Read symbol table, if any. @@ -3088,8 +3161,7 @@ initially undefined function references:~2%") (when filename (ensure-directories-exist filename :verbose t)))) (frob core-file-name) - (frob map-file-name) - (frob c-header-file-name)) + (frob map-file-name)) ;; (This shouldn't matter in normal use, since GENESIS normally ;; only runs once in any given Lisp image, but it could reduce @@ -3159,6 +3231,7 @@ initially undefined function references:~2%") (let ((package (find-package (sb-cold:package-data-name pd)))) (labels (;; Call FN on every node of the TREE. (mapc-on-tree (fn tree) + (declare (type function fn)) (typecase tree (cons (mapc-on-tree fn (car tree)) (mapc-on-tree fn (cdr tree))) @@ -3215,15 +3288,42 @@ initially undefined function references:~2%") ;; lexical variable, and it's annoying to have WRITE-MAP (to ;; *STANDARD-OUTPUT*) not be parallel to WRITE-INITIAL-CORE-FILE ;; (to a stream explicitly passed as an argument). + (macrolet ((out-to (name &body body) + `(let ((fn (format nil "~A/~A.h" c-header-dir-name ,name))) + (ensure-directories-exist fn) + (with-open-file (*standard-output* fn + :if-exists :supersede :direction :output) + (write-boilerplate) + (let ((n (substitute #\_ #\- (string-upcase ,name)))) + (format + t + "#ifndef SBCL_GENESIS_~A~%#define SBCL_GENESIS_~A 1~%" + n n)) + ,@body + (format t + "#endif /* SBCL_GENESIS_~A */~%" + (string-upcase ,name)))))) (when map-file-name (with-open-file (*standard-output* map-file-name :direction :output :if-exists :supersede) (write-map))) - (when c-header-file-name - (with-open-file (*standard-output* c-header-file-name - :direction :output - :if-exists :supersede) - (write-c-header))) + (out-to "config" (write-config-h)) + (out-to "constants" (write-constants-h)) + (let ((structs (sort (copy-list sb!vm:*primitive-objects*) #'string< + :key (lambda (obj) + (symbol-name + (sb!vm:primitive-object-name obj)))))) + (dolist (obj structs) + (out-to + (string-downcase (string (sb!vm:primitive-object-name obj))) + (write-primitive-object obj))) + (out-to "primitive-objects" + (dolist (obj structs) + (format t "~&#include \"~A.h\"~%" + (string-downcase + (string (sb!vm:primitive-object-name obj))))))) + (out-to "static-symbols" (write-static-symbols)) + (when core-file-name - (write-initial-core-file core-file-name))))) + (write-initial-core-file core-file-name))))))