X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=624f8b25f76383b0169f478436426992308bf718;hb=a3649ba68e298d9203e8bb1de5629ff788586fe1;hp=4bff9138ec930355e661f8ef21ae575027282da3;hpb=4ae1b794a5d6a90794468cf8017f5307f2c30dfe;p=sbcl.git diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 4bff913..624f8b2 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -34,10 +34,10 @@ ;;; a magic number used to identify our core files (defconstant core-magic - (logior (ash (char-code #\S) 24) - (ash (char-code #\B) 16) - (ash (char-code #\C) 8) - (char-code #\L))) + (logior (ash (sb!xc:char-code #\S) 24) + (ash (sb!xc:char-code #\B) 16) + (ash (sb!xc:char-code #\C) 8) + (sb!xc:char-code #\L))) ;;; the current version of SBCL core files ;;; @@ -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) @@ -418,7 +444,7 @@ type))) (defun make-character-descriptor (data) - (make-other-immediate-descriptor data sb!vm:base-char-widetag)) + (make-other-immediate-descriptor data sb!vm:character-widetag)) (defun descriptor-beyond (des offset type) (let* ((low (logior (+ (logandc2 (descriptor-low des) sb!vm:lowtag-mask) @@ -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)) @@ -582,16 +608,17 @@ ;;;; copying simple objects into the cold core -(defun string-to-core (string &optional (gspace *dynamic*)) +(defun base-string-to-core (string &optional (gspace *dynamic*)) #!+sb-doc - "Copy string into the cold core and return a descriptor to it." + "Copy STRING (which must only contain STANDARD-CHARs) into the cold +core and return a descriptor to it." ;; (Remember that the system convention for storage of strings leaves an ;; extra null byte at the end to aid in call-out to C.) (let* ((length (length string)) (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)))) @@ -600,14 +627,7 @@ (make-fixnum-descriptor length)) (dotimes (i length) (setf (bvref bytes (+ offset i)) - ;; KLUDGE: There's no guarantee that the character - ;; encoding here will be the same as the character - ;; encoding on the target machine, so using CHAR-CODE as - ;; we do, or a bitwise copy as CMU CL code did, is sleazy. - ;; (To make this more portable, perhaps we could use - ;; indices into the sequence which is used to test whether - ;; a character is a STANDARD-CHAR?) -- WHN 19990817 - (char-code (aref string i)))) + (sb!xc:char-code (aref string i)))) (setf (bvref bytes (+ offset length)) 0) ; null string-termination character for C des)) @@ -643,9 +663,38 @@ (write-wordindexed des 2 second) des)) +(defun write-double-float-bits (address index x) + (let ((hi (double-float-high-bits x)) + (lo (double-float-low-bits x))) + (ecase sb!vm::n-word-bits + (32 + (let ((high-bits (make-random-descriptor hi)) + (low-bits (make-random-descriptor lo))) + (ecase sb!c:*backend-byte-order* + (:little-endian + (write-wordindexed address index low-bits) + (write-wordindexed address (1+ index) high-bits)) + (:big-endian + (write-wordindexed address index high-bits) + (write-wordindexed address (1+ index) low-bits))))) + (64 + (let ((bits (make-random-descriptor + (ecase sb!c:*backend-byte-order* + (:little-endian (logior lo (ash hi 32))) + ;; Just guessing. + #+nil (:big-endian (logior (logand hi #xffffffff) + (ash lo 32))))))) + (write-wordindexed address index bits)))) + address)) + (defun float-to-core (x) (etypecase x (single-float + ;; 64-bit platforms have immediate single-floats. + #!+#.(cl:if (cl:= sb!vm:n-word-bits 64) '(and) '(or)) + (make-random-descriptor (logior (ash (single-float-bits x) 32) + sb!vm::single-float-widetag)) + #!-#.(cl:if (cl:= sb!vm:n-word-bits 64) '(and) '(or)) (let ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits (1- sb!vm:single-float-size) @@ -658,34 +707,8 @@ (let ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits (1- sb!vm:double-float-size) - sb!vm:double-float-widetag)) - (high-bits (make-random-descriptor (double-float-high-bits x))) - (low-bits (make-random-descriptor (double-float-low-bits x)))) - (ecase sb!c:*backend-byte-order* - (:little-endian - (write-wordindexed des sb!vm:double-float-value-slot low-bits) - (write-wordindexed des (1+ sb!vm:double-float-value-slot) high-bits)) - (: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)))) + sb!vm:double-float-widetag))) + (write-double-float-bits des sb!vm:double-float-value-slot x))))) (defun complex-single-float-to-core (num) (declare (type (complex single-float) num)) @@ -703,32 +726,16 @@ (let ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits (1- sb!vm:complex-double-float-size) sb!vm:complex-double-float-widetag))) - (let* ((real (realpart num)) - (high-bits (make-random-descriptor (double-float-high-bits real))) - (low-bits (make-random-descriptor (double-float-low-bits real)))) - (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)) - (: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)))) - (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)) - (: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)))) - des)) + (write-double-float-bits des sb!vm:complex-double-float-real-slot + (realpart num)) + (write-double-float-bits des sb!vm:complex-double-float-imag-slot + (imagpart num)))) ;;; 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,14 +795,12 @@ (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*)) + (base-string-to-core name *dynamic*)) (write-wordindexed symbol sb!vm:symbol-package-slot *nil-descriptor*) symbol)) @@ -1021,7 +1026,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 @@ -1180,7 +1186,7 @@ ;; because that's the way CMU CL did it; I'm ;; not sure whether there's an underlying ;; reason. -- WHN 1990826 - (string-to-core "NIL" *dynamic*)) + (base-string-to-core "NIL" *dynamic*)) (write-wordindexed des (+ 1 sb!vm:symbol-package-slot) result) @@ -1245,14 +1251,18 @@ (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!kernel::undefined-alien-variable-error) + (frob sb!kernel::undefined-alien-function-error) + (frob sb!kernel::memory-fault-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 +1274,7 @@ (let* ((cold-package (car cold-package-symbols-entry)) (symbols (cdr cold-package-symbols-entry)) (shadows (package-shadowing-symbols cold-package)) + (documentation (base-string-to-core (documentation cold-package t))) (internal *nil-descriptor*) (external *nil-descriptor*) (imported-internal *nil-descriptor*) @@ -1310,6 +1321,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) @@ -1327,26 +1339,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. @@ -1356,7 +1354,7 @@ (res *nil-descriptor*)) (dolist (u (package-use-list pkg)) (when (assoc u *cold-package-symbols*) - (cold-push (string-to-core (package-name u)) use))) + (cold-push (base-string-to-core (package-name u)) use))) (let* ((pkg-name (package-name pkg)) ;; Make the package nickname lists for the standard packages ;; be the minimum specified by ANSI, regardless of what value @@ -1377,7 +1375,7 @@ (t (package-nicknames pkg))))) (dolist (warm-nickname warm-nicknames) - (cold-push (string-to-core warm-nickname) cold-nicknames))) + (cold-push (base-string-to-core warm-nickname) cold-nicknames))) (cold-push (number-to-core (truncate (package-internal-symbol-count pkg) 0.8)) @@ -1394,7 +1392,7 @@ (cold-push use res) (cold-push (cold-intern :use) res) - (cold-push (string-to-core (package-name pkg)) res) + (cold-push (base-string-to-core (package-name pkg)) res) res)) ;;;; functions and fdefinition objects @@ -1458,6 +1456,7 @@ (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 +1488,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 +1498,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 +1515,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 +1532,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 +1619,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 +1631,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)) @@ -1749,12 +1750,14 @@ (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)) + (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)) + (logior (mask-field (byte 16 16) + (bvref-32 gspace-bytes gspace-byte-offset)) (ldb (byte 16 0) value)))))) (:ppc (ecase kind @@ -1784,8 +1787,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))) @@ -1815,7 +1818,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 @@ -1825,7 +1828,7 @@ (note-load-time-code-fixup code-object after-header value - kind)))))) )) + kind)))))))) (values)) (defun resolve-assembler-fixups () @@ -1839,20 +1842,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) + (cold-push (cold-cons (base-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 @@ -1886,13 +1890,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. @@ -1918,10 +1924,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)) @@ -1982,21 +1986,21 @@ (depthoid (descriptor-fixnum depthoid-des))) (unless (= length old-length) (error "cold loading a reference to class ~S when the compile~%~ - time length was ~S and current length is ~S" + time length was ~S and current length is ~S" name length old-length)) (unless (equal inherits-list old-inherits-list) (error "cold loading a reference to class ~S when the compile~%~ - time inherits were ~S~%~ - and current inherits are ~S" + time inherits were ~S~%~ + and current inherits are ~S" name inherits-list old-inherits-list)) (unless (= depthoid old-depthoid) (error "cold loading a reference to class ~S when the compile~%~ - time inheritance depthoid was ~S and current inheritance~%~ - depthoid is ~S" + time inheritance depthoid was ~S and current inheritance~%~ + depthoid is ~S" name depthoid old-depthoid))) @@ -2011,7 +2015,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) @@ -2019,9 +2023,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) @@ -2051,9 +2055,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) @@ -2089,12 +2093,17 @@ ;;;; cold fops for loading vectors -(clone-cold-fop (fop-string) - (fop-small-string) +(clone-cold-fop (fop-base-string) + (fop-small-base-string) (let* ((len (clone-arg)) (string (make-string len))) (read-string-as-bytes *fasl-input-stream* string) - (string-to-core string))) + (base-string-to-core string))) + +#!+sb-unicode +(clone-cold-fop (fop-character-string) + (fop-small-character-string) + (bug "CHARACTER-STRING dumped by cross-compiler.")) (clone-cold-fop (fop-vector) (fop-small-vector) @@ -2112,15 +2121,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) @@ -2135,7 +2156,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 @@ -2143,7 +2164,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 @@ -2157,7 +2178,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) @@ -2189,6 +2210,7 @@ sb!vm:array-elements-slot (make-fixnum-descriptor total-elements))) result)) + ;;;; cold fops for loading numbers @@ -2212,117 +2234,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))) @@ -2339,7 +2250,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 @@ -2361,7 +2272,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."))) @@ -2369,18 +2280,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) @@ -2389,14 +2300,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) @@ -2489,9 +2400,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) @@ -2505,7 +2416,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)) @@ -2537,12 +2448,12 @@ ;; itself.) Ask on the mailing list whether ;; this is documented somewhere, and if not, ;; try to reverse engineer some documentation. - #!-x86 + #!-(or x86 x86-64) ;; a pointer back to the function object, as ;; described in CMU CL ;; src/docs/internals/object.tex fn - #!+x86 + #!+(or x86 x86-64) ;; KLUDGE: a pointer to the actual code of the ;; object, as described nowhere that I can find ;; -- WHN 19990907 @@ -2563,16 +2474,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. @@ -2605,7 +2528,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)) @@ -2615,14 +2538,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)) @@ -2633,12 +2556,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" @@ -2648,11 +2570,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*) @@ -2661,15 +2581,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 @@ -2723,9 +2648,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) @@ -2787,28 +2728,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 #\_ #\- @@ -2821,10 +2764,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 @@ -2833,10 +2774,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. @@ -2852,10 +2793,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 @@ -2922,7 +2861,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) @@ -2931,11 +2881,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 () @@ -3017,6 +2968,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 (sb!xc: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. @@ -3074,11 +3041,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~%" @@ -3088,13 +3051,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 @@ -3104,8 +3068,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 @@ -3136,7 +3099,7 @@ initially undefined function references:~2%") sb!vm:unbound-marker-widetag)) *cold-assembler-fixups* *cold-assembler-routines* - #!+x86 *load-time-code-fixups*) + #!+(or x86 x86-64) *load-time-code-fixups*) ;; Prepare for cold load. (initialize-non-nil-symbols) @@ -3175,6 +3138,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))) @@ -3203,8 +3167,8 @@ 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) + #!+(or x86 x86-64) (output-load-time-code-fixups) + (foreign-symbols-to-core) (finish-symbols) (/show "back from FINISH-SYMBOLS") (finalize-load-time-value-noise) @@ -3231,15 +3195,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))))))