X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=4b9ce54a1288d2e262293394c05d2e1f47befdb2;hb=eb5265ab22a2b1cae18bbdf43c871dba9b5927ea;hp=fad92a998482bf4b0469894c43668c26ff06d959;hpb=1bcf4fb22a25e713a0ab898d78abb97abe94c225;p=sbcl.git diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index fad92a9..4b9ce54 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 @@ -149,7 +156,7 @@ bigvec) ;;;; looking up bytes and multi-byte values in a BIGVEC (considering -;;;; it as an image of machine memory) +;;;; it as an image of machine memory on the cross-compilation target) ;;; BVREF-32 and friends. These are like SAP-REF-n, except that ;;; instead of a SAP we use a BIGVEC. @@ -179,20 +186,34 @@ (ldb (byte 8 ,(- n 8 (* i 8))) new-value))))) `(progn (defun ,name (bigvec byte-index) - (aver (= sb!vm:n-word-bits 32)) - (aver (= sb!vm:n-byte-bits 8)) (logior ,@(ecase sb!c:*backend-byte-order* (:little-endian ash-list-le) (:big-endian ash-list-be)))) (defun (setf ,name) (new-value bigvec byte-index) - (aver (= sb!vm:n-word-bits 32)) - (aver (= sb!vm:n-byte-bits 8)) (setf ,@(ecase sb!c:*backend-byte-order* (:little-endian setf-list-le) (:big-endian setf-list-be)))))))) (make-bvref-n 8) (make-bvref-n 16) - (make-bvref-n 32)) + (make-bvref-n 32) + (make-bvref-n 64)) + +;; lispobj-sized word, whatever that may be +;; hopefully nobody ever wants a 128-bit SBCL... +#!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) +(progn +(defun bvref-word (bytes index) + (bvref-64 bytes index)) +(defun (setf bvref-word) (new-val bytes index) + (setf (bvref-64 bytes index) new-val))) + +#!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or)) +(progn +(defun bvref-word (bytes index) + (bvref-32 bytes index)) +(defun (setf bvref-word) (new-val bytes index) + (setf (bvref-32 bytes index) new-val))) + ;;;; representation of spaces in the core @@ -260,7 +281,7 @@ ;; 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 - (word-offset nil :type (or (unsigned-byte #.sb!vm:n-word-bits) null)) + (word-offset nil :type (or sb!vm:word null)) ;; the high and low halves of the descriptor ;; ;; KLUDGE: Judging from the comments in genesis.lisp of the CMU CL @@ -287,7 +308,11 @@ (- unsigned #x40000000) unsigned)))) ((or (= lowtag sb!vm:other-immediate-0-lowtag) - (= lowtag sb!vm:other-immediate-1-lowtag)) + (= lowtag sb!vm:other-immediate-1-lowtag) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + (= lowtag sb!vm:other-immediate-2-lowtag) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + (= lowtag sb!vm:other-immediate-3-lowtag)) (format stream "for other immediate: #X~X, type #b~8,'0B" (ash (descriptor-bits des) (- sb!vm:n-widetag-bits)) @@ -343,14 +368,15 @@ (defun descriptor-fixnum (des) (let ((bits (descriptor-bits des))) (if (logbitp (1- sb!vm:n-word-bits) bits) - ;; KLUDGE: The (- SB!VM:N-WORD-BITS 2) term here looks right to - ;; me, and it works, but in CMU CL it was (1- SB!VM:N-WORD-BITS), - ;; and although that doesn't make sense for me, or work for me, - ;; it's hard to see how it could have been wrong, since CMU CL - ;; genesis worked. It would be nice to understand how this came - ;; to be.. -- WHN 19990901 - (logior (ash bits -2) (ash -1 (- sb!vm:n-word-bits 2))) - (ash bits -2)))) + ;; KLUDGE: The (- SB!VM:N-WORD-BITS 2) term here looks right to + ;; me, and it works, but in CMU CL it was (1- SB!VM:N-WORD-BITS), + ;; and although that doesn't make sense for me, or work for me, + ;; it's hard to see how it could have been wrong, since CMU CL + ;; genesis worked. It would be nice to understand how this came + ;; to be.. -- WHN 19990901 + (logior (ash bits (- 1 sb!vm:n-lowtag-bits)) + (ash -1 (1+ sb!vm:n-positive-fixnum-bits))) + (ash bits (- 1 sb!vm:n-lowtag-bits))))) ;;; common idioms (defun descriptor-bytes (des) @@ -483,7 +509,7 @@ (bytes (gspace-bytes gspace)) (byte-index (ash (+ index (descriptor-word-offset address)) sb!vm:word-shift)) - (value (bvref-32 bytes byte-index))) + (value (bvref-word bytes byte-index))) (make-random-descriptor value))) (declaim (ftype (function (descriptor) descriptor) read-memory)) @@ -526,7 +552,7 @@ (let* ((bytes (gspace-bytes (descriptor-intuit-gspace address))) (byte-index (ash (+ index (descriptor-word-offset address)) sb!vm:word-shift))) - (setf (bvref-32 bytes byte-index) + (setf (bvref-word bytes byte-index) (descriptor-bits value))))) (declaim (ftype (function (descriptor descriptor)) write-memory)) @@ -591,7 +617,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)))) @@ -668,23 +694,6 @@ (:big-endian (write-wordindexed des sb!vm:double-float-value-slot high-bits) (write-wordindexed des (1+ sb!vm:double-float-value-slot) low-bits))) - des)) - #!+(and long-float x86) - (long-float - (let ((des (allocate-unboxed-object *dynamic* - sb!vm:n-word-bits - (1- sb!vm:long-float-size) - sb!vm:long-float-widetag)) - (exp-bits (make-random-descriptor (long-float-exp-bits x))) - (high-bits (make-random-descriptor (long-float-high-bits x))) - (low-bits (make-random-descriptor (long-float-low-bits x)))) - (ecase sb!c:*backend-byte-order* - (:little-endian - (write-wordindexed des sb!vm:long-float-value-slot low-bits) - (write-wordindexed des (1+ sb!vm:long-float-value-slot) high-bits) - (write-wordindexed des (+ 2 sb!vm:long-float-value-slot) exp-bits)) - (:big-endian - (error "LONG-FLOAT is not supported for big-endian byte order."))) des)))) (defun complex-single-float-to-core (num) @@ -709,26 +718,39 @@ (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. (defun number-to-core (number) (typecase number - (integer (if (< (integer-length number) 30) + (integer (if (< (integer-length number) + (- (1+ sb!vm:n-word-bits) sb!vm:n-lowtag-bits)) (make-fixnum-descriptor number) (bignum-to-core number))) (ratio (number-pair-to-core (number-to-core (numerator number)) @@ -788,11 +810,9 @@ (1- sb!vm:symbol-size) sb!vm:symbol-header-widetag))) (write-wordindexed symbol sb!vm:symbol-value-slot *unbound-marker*) - #!+x86 (write-wordindexed symbol sb!vm:symbol-hash-slot - (make-fixnum-descriptor - (1+ (random sb!xc:most-positive-fixnum)))) + (make-fixnum-descriptor 0)) (write-wordindexed symbol sb!vm:symbol-plist-slot *nil-descriptor*) (write-wordindexed symbol sb!vm:symbol-name-slot (string-to-core name *dynamic*)) @@ -1021,7 +1041,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,13 +1266,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)) @@ -1263,6 +1286,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*) @@ -1309,6 +1333,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) @@ -1326,26 +1351,12 @@ (cold-set '*!reversed-cold-toplevels* *current-reversed-cold-toplevels*) - #!+x86 + #!+(or x86 x86-64) (progn (cold-set 'sb!vm::*fp-constant-0d0* (number-to-core 0d0)) (cold-set 'sb!vm::*fp-constant-1d0* (number-to-core 1d0)) (cold-set 'sb!vm::*fp-constant-0f0* (number-to-core 0f0)) - (cold-set 'sb!vm::*fp-constant-1f0* (number-to-core 1f0)) - #!+long-float - (progn - (cold-set 'sb!vm::*fp-constant-0l0* (number-to-core 0L0)) - (cold-set 'sb!vm::*fp-constant-1l0* (number-to-core 1L0)) - ;; FIXME: Why is initialization of PI conditional on LONG-FLOAT? - ;; (ditto LG2, LN2, L2E, etc.) - (cold-set 'sb!vm::*fp-constant-pi* (number-to-core pi)) - (cold-set 'sb!vm::*fp-constant-l2t* (number-to-core (log 10L0 2L0))) - (cold-set 'sb!vm::*fp-constant-l2e* - (number-to-core (log 2.718281828459045235360287471352662L0 2L0))) - (cold-set 'sb!vm::*fp-constant-lg2* (number-to-core (log 2L0 10L0))) - (cold-set 'sb!vm::*fp-constant-ln2* - (number-to-core - (log 2L0 2.718281828459045235360287471352662L0)))))) + (cold-set 'sb!vm::*fp-constant-1f0* (number-to-core 1f0)))) ;;; Make a cold list that can be used as the arg list to MAKE-PACKAGE in order ;;; to make a package that is similar to PKG. @@ -1452,12 +1463,12 @@ (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) (declare (type descriptor cold-name)) + (/show0 "/cold-fdefinition-object") (let ((warm-name (warm-fun-name cold-name))) (or (gethash warm-name *cold-fdefn-objects*) (let ((fdefn (allocate-boxed-object (or *cold-fdefn-gspace* *dynamic*) @@ -1489,6 +1500,7 @@ sb!vm:fdefn-raw-addr-slot (ecase type (#.sb!vm:simple-fun-header-widetag + (/show0 "static-fset (simple-fun)") #!+sparc defn #!-sparc @@ -1498,6 +1510,7 @@ (ash sb!vm:simple-fun-code-offset sb!vm:word-shift)))) (#.sb!vm:closure-header-widetag + (/show0 "/static-fset (closure)") (make-random-descriptor (cold-foreign-symbol-address-as-integer (sb!vm:extern-alien-name "closure_tramp")))))) @@ -1514,8 +1527,8 @@ (desired (sb!vm:static-fun-offset sym))) (unless (= offset desired) ;; FIXME: should be fatal - (warn "Offset from FDEFN ~S to ~S is ~W, not ~W." - sym nil offset desired)))))) + (error "Offset from FDEFN ~S to ~S is ~W, not ~W." + sym nil offset desired)))))) (defun list-all-fdefn-objects () (let ((result *nil-descriptor*)) @@ -1531,55 +1544,55 @@ (defvar *cold-foreign-symbol-table*) (declaim (type hash-table *cold-foreign-symbol-table*)) -;;; Read the sbcl.nm file to find the addresses for foreign-symbols in -;;; the C runtime. +;; Read the sbcl.nm file to find the addresses for foreign-symbols in +;; the C runtime. (defun load-cold-foreign-symbol-table (filename) + (/show "load-cold-foreign-symbol-table" filename) (with-open-file (file filename) - (loop - (let ((line (read-line file nil nil))) - (unless line - (return)) - ;; UNIX symbol tables might have tabs in them, and tabs are - ;; not in Common Lisp STANDARD-CHAR, so there seems to be no - ;; nice portable way to deal with them within Lisp, alas. - ;; Fortunately, it's easy to use UNIX command line tools like - ;; sed to remove the problem, so it's not too painful for us - ;; to push responsibility for converting tabs to spaces out to - ;; the caller. - ;; - ;; Other non-STANDARD-CHARs are problematic for the same reason. - ;; Make sure that there aren't any.. - (let ((ch (find-if (lambda (char) - (not (typep char 'standard-char))) - line))) - (when ch - (error "non-STANDARD-CHAR ~S found in foreign symbol table:~%~S" - ch - line))) - (setf line (string-trim '(#\space) line)) - (let ((p1 (position #\space line :from-end nil)) - (p2 (position #\space line :from-end t))) - (if (not (and p1 p2 (< p1 p2))) - ;; KLUDGE: It's too messy to try to understand all - ;; possible output from nm, so we just punt the lines we - ;; don't recognize. We realize that there's some chance - ;; that might get us in trouble someday, so we warn - ;; about it. - (warn "ignoring unrecognized line ~S in ~A" line filename) - (multiple-value-bind (value name) - (if (string= "0x" line :end2 2) - (values (parse-integer line :start 2 :end p1 :radix 16) - (subseq line (1+ p2))) - (values (parse-integer line :end p1 :radix 16) - (subseq line (1+ p2)))) - (multiple-value-bind (old-value found) - (gethash name *cold-foreign-symbol-table*) - (when (and found - (not (= old-value value))) - (warn "redefining ~S from #X~X to #X~X" - name old-value value))) - (setf (gethash name *cold-foreign-symbol-table*) value)))))) - (values))) + (loop for line = (read-line file nil nil) + while line do + ;; UNIX symbol tables might have tabs in them, and tabs are + ;; not in Common Lisp STANDARD-CHAR, so there seems to be no + ;; nice portable way to deal with them within Lisp, alas. + ;; Fortunately, it's easy to use UNIX command line tools like + ;; sed to remove the problem, so it's not too painful for us + ;; to push responsibility for converting tabs to spaces out to + ;; the caller. + ;; + ;; Other non-STANDARD-CHARs are problematic for the same reason. + ;; Make sure that there aren't any.. + (let ((ch (find-if (lambda (char) + (not (typep char 'standard-char))) + line))) + (when ch + (error "non-STANDARD-CHAR ~S found in foreign symbol table:~%~S" + ch + line))) + (setf line (string-trim '(#\space) line)) + (let ((p1 (position #\space line :from-end nil)) + (p2 (position #\space line :from-end t))) + (if (not (and p1 p2 (< p1 p2))) + ;; KLUDGE: It's too messy to try to understand all + ;; possible output from nm, so we just punt the lines we + ;; don't recognize. We realize that there's some chance + ;; that might get us in trouble someday, so we warn + ;; about it. + (warn "ignoring unrecognized line ~S in ~A" line filename) + (multiple-value-bind (value name) + (if (string= "0x" line :end2 2) + (values (parse-integer line :start 2 :end p1 :radix 16) + (subseq line (1+ p2))) + (values (parse-integer line :end p1 :radix 16) + (subseq line (1+ p2)))) + (multiple-value-bind (old-value found) + (gethash name *cold-foreign-symbol-table*) + (when (and found + (not (= old-value value))) + (warn "redefining ~S from #X~X to #X~X" + name old-value value))) + (/show "adding to *cold-foreign-symbol-table*:" name value) + (setf (gethash name *cold-foreign-symbol-table*) value)))))) + (values)) ;; PROGN (defun cold-foreign-symbol-address-as-integer (name) (or (find-foreign-symbol-in-table name *cold-foreign-symbol-table*) @@ -1618,10 +1631,10 @@ ;;; The x86 port needs to store code fixups along with code objects if ;;; they are to be moved, so fixups for code objects in the dynamic ;;; heap need to be noted. -#!+x86 +#!+(or x86 x86-64) (defvar *load-time-code-fixups*) -#!+x86 +#!+(or x86 x86-64) (defun note-load-time-code-fixup (code-object offset value kind) ;; If CODE-OBJECT might be moved (when (= (gspace-identifier (descriptor-intuit-gspace code-object)) @@ -1630,7 +1643,7 @@ (push (list code-object offset value kind) *load-time-code-fixups*)) (values)) -#!+x86 +#!+(or x86 x86-64) (defun output-load-time-code-fixups () (dolist (fixups *load-time-code-fixups*) (let ((code-object (first fixups)) @@ -1678,8 +1691,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 +1723,55 @@ (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) @@ -1738,8 +1799,8 @@ (dpb (ldb (byte 10 0) value) (byte 10 0) (bvref-32 gspace-bytes gspace-byte-offset)))))) - (:x86 - (let* ((un-fixed-up (bvref-32 gspace-bytes + ((:x86 :x86-64) + (let* ((un-fixed-up (bvref-word gspace-bytes gspace-byte-offset)) (code-object-start-addr (logandc2 (descriptor-bits code-object) sb!vm:lowtag-mask))) @@ -1769,7 +1830,7 @@ (let ((fixed-up (- (+ value un-fixed-up) gspace-byte-address gspace-byte-offset - sb!vm:n-word-bytes))) ; length of CALL argument + 4))) ; "length of CALL argument" (setf (bvref-32 gspace-bytes gspace-byte-offset) fixed-up) ;; Note relative fixups that point outside the code @@ -1779,7 +1840,7 @@ (note-load-time-code-fixup code-object after-header value - kind)))))) )) + kind)))))))) (values)) (defun resolve-assembler-fixups () @@ -1793,20 +1854,21 @@ ;;; the core. When the core is loaded, !LOADER-COLD-INIT uses this to ;;; create *STATIC-FOREIGN-SYMBOLS*, which the code in ;;; target-load.lisp refers to. -(defun linkage-info-to-core () +(defun foreign-symbols-to-core () (let ((result *nil-descriptor*)) (maphash (lambda (symbol value) (cold-push (cold-cons (string-to-core symbol) (number-to-core value)) result)) *cold-foreign-symbol-table*) - (cold-set (cold-intern '*!initial-foreign-symbols*) result)) + (cold-set (cold-intern 'sb!kernel:*!initial-foreign-symbols*) result)) (let ((result *nil-descriptor*)) (dolist (rtn *cold-assembler-routines*) (cold-push (cold-cons (cold-intern (car rtn)) (number-to-core (cdr rtn))) result)) (cold-set (cold-intern '*!initial-assembler-routines*) result))) + ;;;; general machinery for cold-loading FASL files @@ -1840,13 +1902,15 @@ 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 - (macrolet ((clone-arg () '(read-arg 4))) + (macrolet ((clone-arg () '(read-word-arg))) (define-cold-fop (,name :pushp ,pushp :stackp ,stackp) ,@forms)) - (macrolet ((clone-arg () '(read-arg 1))) + (macrolet ((clone-arg () '(read-byte-arg))) (define-cold-fop (,small-name :pushp ,pushp :stackp ,stackp) ,@forms)))) ;;; Cause a fop to be undefined in cold load. @@ -1872,10 +1936,8 @@ (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))) + (make-character-descriptor (read-byte-arg))) (define-cold-fop (fop-empty-list) *nil-descriptor*) (define-cold-fop (fop-truth) (cold-intern t)) @@ -1965,7 +2027,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) @@ -1973,9 +2035,9 @@ (push-fop-table (cold-load-symbol (read-arg ,pname-len) (svref *current-fop-table* index))))))) - (frob fop-symbol-in-package-save 4 4) - (frob fop-small-symbol-in-package-save 1 4) - (frob fop-symbol-in-byte-package-save 4 1) + (frob fop-symbol-in-package-save #.sb!vm:n-word-bytes #.sb!vm:n-word-bytes) + (frob fop-small-symbol-in-package-save 1 #.sb!vm:n-word-bytes) + (frob fop-symbol-in-byte-package-save #.sb!vm:n-word-bytes 1) (frob fop-small-symbol-in-byte-package-save 1 1)) (clone-cold-fop (fop-lisp-symbol-save) @@ -2005,9 +2067,9 @@ (declare (fixnum index)))) (define-cold-fop (fop-list) - (cold-stack-list (read-arg 1) *nil-descriptor*)) + (cold-stack-list (read-byte-arg) *nil-descriptor*)) (define-cold-fop (fop-list*) - (cold-stack-list (read-arg 1) (pop-stack))) + (cold-stack-list (read-byte-arg) (pop-stack))) (define-cold-fop (fop-list-1) (cold-stack-list 1 *nil-descriptor*)) (define-cold-fop (fop-list-2) @@ -2066,15 +2128,27 @@ result)) (define-cold-fop (fop-int-vector) - (let* ((len (read-arg 4)) - (sizebits (read-arg 1)) + (let* ((len (read-word-arg)) + (sizebits (read-byte-arg)) (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) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + (63 (prog1 sb!vm:simple-array-unsigned-byte-63-widetag + (setf sizebits 64))) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + (64 sb!vm:simple-array-unsigned-byte-64-widetag) (t (error "losing element size: ~W" sizebits)))) (result (allocate-vector-object *dynamic* sizebits len type)) (start (+ (descriptor-byte-offset result) @@ -2089,7 +2163,7 @@ result)) (define-cold-fop (fop-single-float-vector) - (let* ((len (read-arg 4)) + (let* ((len (read-word-arg)) (result (allocate-vector-object *dynamic* sb!vm:n-word-bits @@ -2097,7 +2171,7 @@ sb!vm:simple-array-single-float-widetag)) (start (+ (descriptor-byte-offset result) (ash sb!vm:vector-data-offset sb!vm:word-shift))) - (end (+ start (* len sb!vm:n-word-bytes)))) + (end (+ start (* len 4)))) (read-bigvec-as-sequence-or-die (descriptor-bytes result) *fasl-input-stream* :start start @@ -2111,7 +2185,7 @@ #!+long-float (not-cold-fop fop-complex-long-float-vector) (define-cold-fop (fop-array) - (let* ((rank (read-arg 4)) + (let* ((rank (read-word-arg)) (data-vector (pop-stack)) (result (allocate-boxed-object *dynamic* (+ sb!vm:array-dimensions-offset rank) @@ -2143,6 +2217,7 @@ sb!vm:array-elements-slot (make-fixnum-descriptor total-elements))) result)) + ;;;; cold fops for loading numbers @@ -2166,117 +2241,6 @@ (define-cold-number-fop fop-complex-single-float) (define-cold-number-fop fop-complex-double-float) -#!+long-float -(define-cold-fop (fop-long-float) - (ecase +backend-fasl-file-implementation+ - (:x86 ; (which has 80-bit long-float format) - (prepare-for-fast-read-byte *fasl-input-stream* - (let* ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits - (1- sb!vm:long-float-size) - sb!vm:long-float-widetag)) - (low-bits (make-random-descriptor (fast-read-u-integer 4))) - (high-bits (make-random-descriptor (fast-read-u-integer 4))) - (exp-bits (make-random-descriptor (fast-read-s-integer 2)))) - (done-with-fast-read-byte) - (write-wordindexed des sb!vm:long-float-value-slot low-bits) - (write-wordindexed des (1+ sb!vm:long-float-value-slot) high-bits) - (write-wordindexed des (+ 2 sb!vm:long-float-value-slot) exp-bits) - des))) - ;; This was supported in CMU CL, but isn't currently supported in - ;; SBCL. - #+nil - (#.sb!c:sparc-fasl-file-implementation ; 128 bit long-float format - (prepare-for-fast-read-byte *fasl-input-stream* - (let* ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits - (1- sb!vm:long-float-size) - sb!vm:long-float-widetag)) - (low-bits (make-random-descriptor (fast-read-u-integer 4))) - (mid-bits (make-random-descriptor (fast-read-u-integer 4))) - (high-bits (make-random-descriptor (fast-read-u-integer 4))) - (exp-bits (make-random-descriptor (fast-read-s-integer 4)))) - (done-with-fast-read-byte) - (write-wordindexed des sb!vm:long-float-value-slot exp-bits) - (write-wordindexed des (1+ sb!vm:long-float-value-slot) high-bits) - (write-wordindexed des (+ 2 sb!vm:long-float-value-slot) mid-bits) - (write-wordindexed des (+ 3 sb!vm:long-float-value-slot) low-bits) - des))))) - -#!+long-float -(define-cold-fop (fop-complex-long-float) - (ecase +backend-fasl-file-implementation+ - (:x86 ; (which has 80-bit long-float format) - (prepare-for-fast-read-byte *fasl-input-stream* - (let* ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits - (1- sb!vm:complex-long-float-size) - sb!vm:complex-long-float-widetag)) - (real-low-bits (make-random-descriptor (fast-read-u-integer 4))) - (real-high-bits (make-random-descriptor (fast-read-u-integer 4))) - (real-exp-bits (make-random-descriptor (fast-read-s-integer 2))) - (imag-low-bits (make-random-descriptor (fast-read-u-integer 4))) - (imag-high-bits (make-random-descriptor (fast-read-u-integer 4))) - (imag-exp-bits (make-random-descriptor (fast-read-s-integer 2)))) - (done-with-fast-read-byte) - (write-wordindexed des - sb!vm:complex-long-float-real-slot - real-low-bits) - (write-wordindexed des - (1+ sb!vm:complex-long-float-real-slot) - real-high-bits) - (write-wordindexed des - (+ 2 sb!vm:complex-long-float-real-slot) - real-exp-bits) - (write-wordindexed des - sb!vm:complex-long-float-imag-slot - imag-low-bits) - (write-wordindexed des - (1+ sb!vm:complex-long-float-imag-slot) - imag-high-bits) - (write-wordindexed des - (+ 2 sb!vm:complex-long-float-imag-slot) - imag-exp-bits) - des))) - ;; This was supported in CMU CL, but isn't currently supported in SBCL. - #+nil - (#.sb!c:sparc-fasl-file-implementation ; 128 bit long-float format - (prepare-for-fast-read-byte *fasl-input-stream* - (let* ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits - (1- sb!vm:complex-long-float-size) - sb!vm:complex-long-float-widetag)) - (real-low-bits (make-random-descriptor (fast-read-u-integer 4))) - (real-mid-bits (make-random-descriptor (fast-read-u-integer 4))) - (real-high-bits (make-random-descriptor (fast-read-u-integer 4))) - (real-exp-bits (make-random-descriptor (fast-read-s-integer 4))) - (imag-low-bits (make-random-descriptor (fast-read-u-integer 4))) - (imag-mid-bits (make-random-descriptor (fast-read-u-integer 4))) - (imag-high-bits (make-random-descriptor (fast-read-u-integer 4))) - (imag-exp-bits (make-random-descriptor (fast-read-s-integer 4)))) - (done-with-fast-read-byte) - (write-wordindexed des - sb!vm:complex-long-float-real-slot - real-exp-bits) - (write-wordindexed des - (1+ sb!vm:complex-long-float-real-slot) - real-high-bits) - (write-wordindexed des - (+ 2 sb!vm:complex-long-float-real-slot) - real-mid-bits) - (write-wordindexed des - (+ 3 sb!vm:complex-long-float-real-slot) - real-low-bits) - (write-wordindexed des - sb!vm:complex-long-float-real-slot - imag-exp-bits) - (write-wordindexed des - (1+ sb!vm:complex-long-float-real-slot) - imag-high-bits) - (write-wordindexed des - (+ 2 sb!vm:complex-long-float-real-slot) - imag-mid-bits) - (write-wordindexed des - (+ 3 sb!vm:complex-long-float-real-slot) - imag-low-bits) - des))))) - (define-cold-fop (fop-ratio) (let ((den (pop-stack))) (number-pair-to-core (pop-stack) den sb!vm:ratio-widetag))) @@ -2293,7 +2257,7 @@ (defvar *load-time-value-counter*) (define-cold-fop (fop-funcall) - (unless (= (read-arg 1) 0) + (unless (= (read-byte-arg) 0) (error "You can't FOP-FUNCALL arbitrary stuff in cold load.")) (let ((counter *load-time-value-counter*)) (cold-push (cold-cons @@ -2315,7 +2279,7 @@ sb!vm:simple-vector-widetag))) (define-cold-fop (fop-funcall-for-effect :pushp nil) - (if (= (read-arg 1) 0) + (if (= (read-byte-arg) 0) (cold-push (pop-stack) *current-reversed-cold-toplevels*) (error "You can't FOP-FUNCALL arbitrary stuff in cold load."))) @@ -2323,18 +2287,18 @@ ;;;; cold fops for fixing up circularities (define-cold-fop (fop-rplaca :pushp nil) - (let ((obj (svref *current-fop-table* (read-arg 4))) - (idx (read-arg 4))) + (let ((obj (svref *current-fop-table* (read-word-arg))) + (idx (read-word-arg))) (write-memory (cold-nthcdr idx obj) (pop-stack)))) (define-cold-fop (fop-rplacd :pushp nil) - (let ((obj (svref *current-fop-table* (read-arg 4))) - (idx (read-arg 4))) + (let ((obj (svref *current-fop-table* (read-word-arg))) + (idx (read-word-arg))) (write-wordindexed (cold-nthcdr idx obj) 1 (pop-stack)))) (define-cold-fop (fop-svset :pushp nil) - (let ((obj (svref *current-fop-table* (read-arg 4))) - (idx (read-arg 4))) + (let ((obj (svref *current-fop-table* (read-word-arg))) + (idx (read-word-arg))) (write-wordindexed obj (+ idx (ecase (descriptor-lowtag obj) @@ -2343,14 +2307,14 @@ (pop-stack)))) (define-cold-fop (fop-structset :pushp nil) - (let ((obj (svref *current-fop-table* (read-arg 4))) - (idx (read-arg 4))) + (let ((obj (svref *current-fop-table* (read-word-arg))) + (idx (read-word-arg))) (write-wordindexed obj (1+ idx) (pop-stack)))) ;;; In the original CMUCL code, this actually explicitly declared PUSHP ;;; to be T, even though that's what it defaults to in DEFINE-COLD-FOP. (define-cold-fop (fop-nthcdr) - (cold-nthcdr (read-arg 4) (pop-stack))) + (cold-nthcdr (read-word-arg) (pop-stack))) (defun cold-nthcdr (index obj) (dotimes (i index) @@ -2443,9 +2407,9 @@ (bvref-32 (descriptor-bytes des) i))))) des))) -(define-cold-code-fop fop-code (read-arg 4) (read-arg 4)) +(define-cold-code-fop fop-code (read-word-arg) (read-word-arg)) -(define-cold-code-fop fop-small-code (read-arg 1) (read-arg 2)) +(define-cold-code-fop fop-small-code (read-byte-arg) (read-halfword-arg)) (clone-cold-fop (fop-alter-code :pushp nil) (fop-byte-alter-code) @@ -2459,7 +2423,7 @@ (arglist (pop-stack)) (name (pop-stack)) (code-object (pop-stack)) - (offset (calc-offset code-object (read-arg 4))) + (offset (calc-offset code-object (read-word-arg))) (fn (descriptor-beyond code-object offset sb!vm:fun-pointer-lowtag)) @@ -2517,16 +2481,28 @@ (define-cold-fop (fop-foreign-fixup) (let* ((kind (pop-stack)) (code-object (pop-stack)) - (len (read-arg 1)) + (len (read-byte-arg)) (sym (make-string len))) (read-string-as-bytes *fasl-input-stream* sym) - (let ((offset (read-arg 4)) + (let ((offset (read-word-arg)) (value (cold-foreign-symbol-address-as-integer sym))) (do-cold-fixup code-object offset value kind)) - code-object)) + code-object)) + +#!+linkage-table +(define-cold-fop (fop-foreign-dataref-fixup) + (let* ((kind (pop-stack)) + (code-object (pop-stack)) + (len (read-byte-arg)) + (sym (make-string len))) + (read-string-as-bytes *fasl-input-stream* sym) + (maphash (lambda (k v) + (format *error-output* "~&~S = #X~8X~%" k v)) + *cold-foreign-symbol-table*) + (error "shared foreign symbol in cold load: ~S (~S)" sym kind))) (define-cold-fop (fop-assembler-code) - (let* ((length (read-arg 4)) + (let* ((length (read-word-arg)) (header-n-words ;; Note: we round the number of constants up to ensure that ;; the code vector will be properly aligned. @@ -2559,7 +2535,7 @@ (define-cold-fop (fop-assembler-routine) (let* ((routine (pop-stack)) (des (pop-stack)) - (offset (calc-offset des (read-arg 4)))) + (offset (calc-offset des (read-word-arg)))) (record-cold-assembler-routine routine (+ (logandc2 (descriptor-bits des) sb!vm:lowtag-mask) offset)) @@ -2569,14 +2545,14 @@ (let* ((routine (pop-stack)) (kind (pop-stack)) (code-object (pop-stack)) - (offset (read-arg 4))) + (offset (read-word-arg))) (record-cold-assembler-fixup routine code-object offset kind) code-object)) (define-cold-fop (fop-code-object-fixup) (let* ((kind (pop-stack)) (code-object (pop-stack)) - (offset (read-arg 4)) + (offset (read-word-arg)) (value (descriptor-bits code-object))) (do-cold-fixup code-object offset value kind) code-object)) @@ -2587,12 +2563,11 @@ (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." + "(As of sbcl-0.8.14, it came from WRITE-CONFIG-H in genesis.lisp.)" "" "This file contains low-level information about the" "internals of a particular version and configuration" @@ -2602,11 +2577,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*) @@ -2615,15 +2588,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 @@ -2677,9 +2655,25 @@ (maybe-record-with-munged-name "-TRAP" "trap_" 3) (maybe-record-with-munged-name "-SUBTYPE" "subtype_" 4) (maybe-record-with-munged-name "-SC-NUMBER" "sc_" 5) - (maybe-record-with-translated-name '("-START" "-END") 6) + (maybe-record-with-translated-name '("-START" "-END" "-SIZE") 6) (maybe-record-with-translated-name '("-CORE-ENTRY-TYPE-CODE") 7) (maybe-record-with-translated-name '("-CORE-SPACE-ID") 8)))))) + ;; KLUDGE: these constants are sort of important, but there's no + ;; pleasing way to inform the code above about them. So we fake + ;; it for now. nikodemus on #lisp (2004-08-09) suggested simply + ;; exporting every numeric constant from SB!VM; that would work, + ;; but the C runtime would have to be altered to use Lisp-like names + ;; rather than the munged names currently exported. --njf, 2004-08-09 + (dolist (c '(sb!vm:n-word-bits sb!vm:n-word-bytes + sb!vm:n-lowtag-bits sb!vm:lowtag-mask + sb!vm:n-widetag-bits sb!vm:widetag-mask + sb!vm:n-fixnum-tag-bits sb!vm:fixnum-tag-mask)) + (push (list (substitute #\_ #\- (symbol-name c)) + -1 ; invent a new priority + (symbol-value c) + nil) + constants)) + (setf constants (sort constants (lambda (const1 const2) @@ -2741,20 +2735,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)) + (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)))) + + + +(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 #\_ #\- @@ -2767,10 +2771,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 @@ -2779,10 +2781,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. @@ -2798,10 +2800,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 @@ -2868,7 +2868,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) @@ -2877,11 +2888,12 @@ initially undefined function references:~2%") (defun write-word (num) (ecase sb!c:*backend-byte-order* (:little-endian - (dotimes (i 4) + (dotimes (i sb!vm:n-word-bytes) (write-byte (ldb (byte 8 (* i 8)) num) *core-file*))) (:big-endian - (dotimes (i 4) - (write-byte (ldb (byte 8 (* (- 3 i) 8)) num) *core-file*)))) + (dotimes (i sb!vm:n-word-bytes) + (write-byte (ldb (byte 8 (* (- (1- sb!vm:n-word-bytes) i) 8)) num) + *core-file*)))) num) (defun advance-to-page () @@ -2963,6 +2975,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. @@ -3020,11 +3048,7 @@ initially undefined function references:~2%") symbol-table-file-name core-file-name map-file-name - c-header-file-name) - - (when (and core-file-name - (not symbol-table-file-name)) - (error "can't output a core file without symbol table file input")) + c-header-dir-name) (format t "~&beginning GENESIS, ~A~%" @@ -3034,13 +3058,14 @@ 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))) - - (let* ((*cold-foreign-symbol-table* (make-hash-table :test 'equal))) + (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. - (when symbol-table-file-name - (load-cold-foreign-symbol-table symbol-table-file-name)) + (when core-file-name + (if symbol-table-file-name + (load-cold-foreign-symbol-table symbol-table-file-name) + (error "can't output a core file without symbol table file input"))) ;; Now that we've successfully read our only input file (by ;; loading the symbol table, if any), it's a good time to ensure @@ -3050,8 +3075,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 @@ -3121,6 +3145,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))) @@ -3150,7 +3175,7 @@ initially undefined function references:~2%") ;; Tidy up loose ends left by cold loading. ("Postpare from cold load?") (resolve-assembler-fixups) #!+x86 (output-load-time-code-fixups) - (linkage-info-to-core) + (foreign-symbols-to-core) (finish-symbols) (/show "back from FINISH-SYMBOLS") (finalize-load-time-value-noise) @@ -3177,15 +3202,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))))))