X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=54c0730708298e7930ceee577c358ca7dcc40324;hb=cd2c70c8b5d4dcc62b968f5a9bedd3c9c8698e82;hp=8640884c7a6891384e877a6f4e2e6779cb789b4c;hpb=637371f800e71ac4449e01d59571c9d10f6bde26;p=sbcl.git diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 8640884..54c0730 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 @@ -1247,6 +1254,7 @@ (cold-fdefinition-object (cold-intern ',symbol))))) (frob maybe-gc) (frob internal-error) + (frob sb!kernel::control-stack-exhausted-error) (frob sb!di::handle-breakpoint) (frob sb!di::handle-fun-end-breakpoint)) @@ -1452,8 +1460,7 @@ (warm-symbol cadr-des)))) (#.sb!vm:other-pointer-lowtag (warm-symbol des))))) - (unless (legal-fun-name-p result) - (error "not a legal function name: ~S" result)) + (legal-fun-name-or-type-error result) result)) (defun cold-fdefinition-object (cold-name &optional leave-fn-raw) @@ -1678,8 +1685,8 @@ (descriptor-gspace code-object)))) (ecase +backend-fasl-file-implementation+ ;; See CMU CL source for other formerly-supported architectures - ;; (and note that you have to rewrite them to use VECTOR-REF - ;; unstead of SAP-REF). + ;; (and note that you have to rewrite them to use BVREF-X + ;; instead of SAP-REF). (:alpha (ecase kind (:jmp-hint @@ -1710,7 +1717,53 @@ (ldb (byte 8 0) value) (bvref-8 gspace-bytes (1+ gspace-byte-offset)) (ldb (byte 8 8) value))))) - (:ppc + (:hppa + (ecase kind + (:load + (setf (bvref-32 gspace-bytes gspace-byte-offset) + (logior (ash (ldb (byte 11 0) value) 1) + (logand (bvref-32 gspace-bytes gspace-byte-offset) + #xffffc000)))) + (:load-short + (let ((low-bits (ldb (byte 11 0) value))) + (assert (<= 0 low-bits (1- (ash 1 4)))) + (setf (bvref-32 gspace-bytes gspace-byte-offset) + (logior (ash low-bits 17) + (logand (bvref-32 gspace-bytes gspace-byte-offset) + #xffe0ffff))))) + (:hi + (setf (bvref-32 gspace-bytes gspace-byte-offset) + (logior (ash (ldb (byte 5 13) value) 16) + (ash (ldb (byte 2 18) value) 14) + (ash (ldb (byte 2 11) value) 12) + (ash (ldb (byte 11 20) value) 1) + (ldb (byte 1 31) value) + (logand (bvref-32 gspace-bytes gspace-byte-offset) + #xffe00000)))) + (:branch + (let ((bits (ldb (byte 9 2) value))) + (assert (zerop (ldb (byte 2 0) value))) + (setf (bvref-32 gspace-bytes gspace-byte-offset) + (logior (ash bits 3) + (logand (bvref-32 gspace-bytes gspace-byte-offset) + #xffe0e002))))))) + (: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) @@ -2876,7 +2929,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) @@ -2971,6 +3035,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.