X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=db3ca48423d846ce8de1fcbbbb5396f7aba079ee;hb=95591ed483dbb8c0846c129953acac1554f28809;hp=ef67095a3cce017617f3880d433cf5bc77cbdb82;hpb=a160917364f85b38dc0826a5e3dcef87e3c4c62c;p=sbcl.git diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index ef67095..db3ca48 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -86,7 +86,8 @@ `(simple-array (unsigned-byte 8) (,+smallvec-length+))) (defun make-smallvec () - (make-array +smallvec-length+ :element-type '(unsigned-byte 8))) + (make-array +smallvec-length+ :element-type '(unsigned-byte 8) + :initial-element 0)) ;;; a big vector, implemented as a vector of SMALLVECs ;;; @@ -734,10 +735,17 @@ core and return a descriptor to it." (let ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits (1- sb!vm:complex-single-float-size) sb!vm:complex-single-float-widetag))) - (write-wordindexed des sb!vm:complex-single-float-real-slot - (make-random-descriptor (single-float-bits (realpart num)))) - (write-wordindexed des sb!vm:complex-single-float-imag-slot - (make-random-descriptor (single-float-bits (imagpart num)))) + #!-x86-64 + (progn + (write-wordindexed des sb!vm:complex-single-float-real-slot + (make-random-descriptor (single-float-bits (realpart num)))) + (write-wordindexed des sb!vm:complex-single-float-imag-slot + (make-random-descriptor (single-float-bits (imagpart num))))) + #!+x86-64 + (write-wordindexed des sb!vm:complex-single-float-data-slot + (make-random-descriptor + (logior (ldb (byte 32 0) (single-float-bits (realpart num))) + (ash (single-float-bits (imagpart num)) 32)))) des)) (defun complex-double-float-to-core (num) @@ -918,46 +926,8 @@ core and return a descriptor to it." ;; Set slot 0 = the layout of the layout. (write-wordindexed result sb!vm:instance-slots-offset *layout-layout*) - ;; Set the CLOS hash value. + ;; Don't set the CLOS hash value: done in cold-init instead. ;; - ;; Note: CMU CL didn't set these in genesis, but instead arranged - ;; for them to be set at cold init time. That resulted in slightly - ;; kludgy-looking code, but there were at least two things to be - ;; said for it: - ;; 1. It put the hash values under the control of the target Lisp's - ;; RANDOM function, so that CLOS behavior would be nearly - ;; deterministic (instead of depending on the implementation of - ;; RANDOM in the cross-compilation host, and the state of its - ;; RNG when genesis begins). - ;; 2. It automatically ensured that all hash values in the target Lisp - ;; were part of the same sequence, so that we didn't have to worry - ;; about the possibility of the first hash value set in genesis - ;; being precisely equal to the some hash value set in cold init time - ;; (because the target Lisp RNG has advanced to precisely the same - ;; state that the host Lisp RNG was in earlier). - ;; Point 1 should not be an issue in practice because of the way we do our - ;; build procedure in two steps, so that the SBCL that we end up with has - ;; been created by another SBCL (whose RNG is under our control). - ;; Point 2 is more of an issue. If ANSI had provided a way to feed - ;; entropy into an RNG, we would have no problem: we'd just feed - ;; some specialized genesis-time-only pattern into the RNG state - ;; before using it. However, they didn't, so we have a slight - ;; problem. We address it by generating the hash values using a - ;; different algorithm than we use in ordinary operation. - (let (;; The expression here is pretty arbitrary, we just want - ;; to make sure that it's not something which is (1) - ;; evenly distributed and (2) not foreordained to arise in - ;; the target Lisp's (RANDOM-LAYOUT-CLOS-HASH) sequence - ;; and show up as the CLOS-HASH value of some other - ;; LAYOUT. - (hash-value - (1+ (mod (logxor (logand (random-layout-clos-hash) 15253) - (logandc2 (random-layout-clos-hash) 15253) - 1) - (1- sb!kernel:layout-clos-hash-limit))))) - (cold-set-layout-slot result 'clos-hash - (make-fixnum-descriptor hash-value))) - ;; Set other slot values. ;; ;; leave CLASSOID uninitialized for now @@ -1245,13 +1215,21 @@ core and return a descriptor to it." ;;; a helper function for FINISH-SYMBOLS: Return a cold alist suitable ;;; to be stored in *!INITIAL-LAYOUTS*. (defun cold-list-all-layouts () - (let ((result *nil-descriptor*)) + (let ((layouts nil) + (result *nil-descriptor*)) (maphash (lambda (key stuff) - (cold-push (cold-cons (cold-intern key) - (first stuff)) - result)) + (push (cons key (first stuff)) layouts)) *cold-layouts*) - result)) + (flet ((sorter (x y) + (let ((xpn (package-name (symbol-package-for-target-symbol x))) + (ypn (package-name (symbol-package-for-target-symbol y)))) + (cond + ((string= x y) (string< xpn ypn)) + (t (string< x y)))))) + (setq layouts (sort layouts #'sorter :key #'car))) + (dolist (layout layouts result) + (cold-push (cold-cons (cold-intern (car layout)) (cdr layout)) + result)))) ;;; Establish initial values for magic symbols. ;;; @@ -1288,7 +1266,15 @@ core and return a descriptor to it." (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))) + (documentation (base-string-to-core + ;; KLUDGE: NIL punned as 0-length string. + (unless + ;; don't propagate the arbitrary + ;; docstring from host packages into + ;; the core + (or (eql cold-package *cl-package*) + (eql cold-package *keyword-package*)) + (documentation cold-package t)))) (internal-count 0) (external-count 0) (internal *nil-descriptor*) @@ -1542,12 +1528,23 @@ core and return a descriptor to it." sym nil offset desired)))))) (defun list-all-fdefn-objects () - (let ((result *nil-descriptor*)) + (let ((fdefns nil) + (result *nil-descriptor*)) (maphash (lambda (key value) - (declare (ignore key)) - (cold-push value result)) + (push (cons key value) fdefns)) *cold-fdefn-objects*) - result)) + (flet ((sorter (x y) + (let* ((xbn (fun-name-block-name x)) + (ybn (fun-name-block-name y)) + (xbnpn (package-name (symbol-package-for-target-symbol xbn))) + (ybnpn (package-name (symbol-package-for-target-symbol ybn)))) + (cond + ((eql xbn ybn) (consp x)) + ((string= xbn ybn) (string< xbnpn ybnpn)) + (t (string< xbn ybn)))))) + (setq fdefns (sort fdefns #'sorter :key #'car))) + (dolist (fdefn fdefns result) + (cold-push (cdr fdefn) result)))) ;;;; fixups and related stuff @@ -1657,23 +1654,29 @@ core and return a descriptor to it." #!+x86 (defun output-load-time-code-fixups () - (maphash - (lambda (code-object-address fixup-offsets) - (let ((fixup-vector - (allocate-vector-object - *dynamic* sb!vm:n-word-bits (length fixup-offsets) - sb!vm:simple-array-unsigned-byte-32-widetag))) - (do ((index sb!vm:vector-data-offset (1+ index)) - (fixups fixup-offsets (cdr fixups))) - ((null fixups)) - (write-wordindexed fixup-vector index - (make-random-descriptor (car fixups)))) - ;; KLUDGE: The fixup vector is stored as the first constant, - ;; not as a separately-named slot. - (write-wordindexed (make-random-descriptor code-object-address) - sb!vm:code-constants-offset - fixup-vector))) - *load-time-code-fixups*)) + (let ((fixup-infos nil)) + (maphash + (lambda (code-object-address fixup-offsets) + (push (cons code-object-address fixup-offsets) fixup-infos)) + *load-time-code-fixups*) + (setq fixup-infos (sort fixup-infos #'< :key #'car)) + (dolist (fixup-info fixup-infos) + (let ((code-object-address (car fixup-info)) + (fixup-offsets (cdr fixup-info))) + (let ((fixup-vector + (allocate-vector-object + *dynamic* sb!vm:n-word-bits (length fixup-offsets) + sb!vm:simple-array-unsigned-byte-32-widetag))) + (do ((index sb!vm:vector-data-offset (1+ index)) + (fixups fixup-offsets (cdr fixups))) + ((null fixups)) + (write-wordindexed fixup-vector index + (make-random-descriptor (car fixups)))) + ;; KLUDGE: The fixup vector is stored as the first constant, + ;; not as a separately-named slot. + (write-wordindexed (make-random-descriptor code-object-address) + sb!vm:code-constants-offset + fixup-vector)))))) ;;; Given a pointer to a code object and an offset relative to the ;;; tail of the code object's header, return an offset relative to the @@ -1897,15 +1900,19 @@ core and return a descriptor to it." ;;; create *STATIC-FOREIGN-SYMBOLS*, which the code in ;;; target-load.lisp refers to. (defun foreign-symbols-to-core () - (let ((result *nil-descriptor*)) + (let ((symbols nil) + (result *nil-descriptor*)) (maphash (lambda (symbol value) - (cold-push (cold-cons (base-string-to-core symbol) - (number-to-core value)) - result)) + (push (cons symbol value) symbols)) *cold-foreign-symbol-table*) + (setq symbols (sort symbols #'string< :key #'car)) + (dolist (symbol symbols) + (cold-push (cold-cons (base-string-to-core (car symbol)) + (number-to-core (cdr symbol))) + result)) (cold-set (cold-intern 'sb!kernel:*!initial-foreign-symbols*) result)) (let ((result *nil-descriptor*)) - (dolist (rtn *cold-assembler-routines*) + (dolist (rtn (sort (copy-list *cold-assembler-routines*) #'string< :key #'car)) (cold-push (cold-cons (cold-intern (car rtn)) (number-to-core (cdr rtn))) result)) @@ -2265,6 +2272,7 @@ core and return a descriptor to it." (write-wordindexed result sb!vm:array-data-slot data-vector) (write-wordindexed result sb!vm:array-displacement-slot *nil-descriptor*) (write-wordindexed result sb!vm:array-displaced-p-slot *nil-descriptor*) + (write-wordindexed result sb!vm:array-displaced-from-slot *nil-descriptor*) (let ((total-elements 1)) (dotimes (axis rank) (let ((dim (pop-stack))) @@ -2491,7 +2499,7 @@ core and return a descriptor to it." (write-wordindexed code slot value))) (define-cold-fop (fop-fun-entry) - (let* ((xrefs (pop-stack)) + (let* ((info (pop-stack)) (type (pop-stack)) (arglist (pop-stack)) (name (pop-stack)) @@ -2549,7 +2557,7 @@ core and return a descriptor to it." (write-wordindexed fn sb!vm:simple-fun-name-slot name) (write-wordindexed fn sb!vm:simple-fun-arglist-slot arglist) (write-wordindexed fn sb!vm:simple-fun-type-slot type) - (write-wordindexed fn sb!vm::simple-fun-xrefs-slot xrefs) + (write-wordindexed fn sb!vm::simple-fun-info-slot info) fn)) (define-cold-fop (fop-foreign-fixup) @@ -2859,7 +2867,36 @@ core and return a descriptor to it." (c-symbol-name symbol) (sb!xc:mask-field (symbol-value symbol) -1)))) - +#!+sb-ldb +(defun write-tagnames-h (&optional (out *standard-output*)) + (labels + ((pretty-name (symbol strip) + (let ((name (string-downcase symbol))) + (substitute #\Space #\- + (subseq name 0 (- (length name) (length strip)))))) + (list-sorted-tags (tail) + (loop for symbol being the external-symbols of "SB!VM" + when (and (constantp symbol) + (tailwise-equal (string symbol) tail)) + collect symbol into tags + finally (return (sort tags #'< :key #'symbol-value)))) + (write-tags (kind limit ash-count) + (format out "~%static const char *~(~A~)_names[] = {~%" + (subseq kind 1)) + (let ((tags (list-sorted-tags kind))) + (dotimes (i limit) + (if (eql i (ash (or (symbol-value (first tags)) -1) ash-count)) + (format out " \"~A\"" (pretty-name (pop tags) kind)) + (format out " \"unknown [~D]\"" i)) + (unless (eql i (1- limit)) + (write-string "," out)) + (terpri out))) + (write-line "};" out))) + (write-tags "-LOWTAG" sb!vm:lowtag-limit 0) + ;; this -2 shift depends on every OTHER-IMMEDIATE-?-LOWTAG + ;; ending with the same 2 bits. (#b10) + (write-tags "-WIDETAG" (ash (1+ sb!vm:widetag-mask) -2) -2)) + (values)) (defun write-primitive-object (obj) ;; writing primitive object layouts @@ -3347,6 +3384,8 @@ initially undefined function references:~2%") (write-map))) (out-to "config" (write-config-h)) (out-to "constants" (write-constants-h)) + #!+sb-ldb + (out-to "tagnames" (write-tagnames-h)) (let ((structs (sort (copy-list sb!vm:*primitive-objects*) #'string< :key (lambda (obj) (symbol-name @@ -3379,5 +3418,3 @@ initially undefined function references:~2%") (when core-file-name (write-initial-core-file core-file-name)))))) - -