X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=ecf2735a3739449fd17ac546242911adf5faa214;hb=7c406887c08477181e869b1b98142d99b52990ac;hp=523f20c409cead4c37169116bf1df1d11e52f0c7;hpb=722590dece877ac9c8caca81453a81efb47977cb;p=sbcl.git diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 523f20c..ecf2735 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -851,10 +851,27 @@ core and return a descriptor to it." ;;; the descriptor for layout's layout (needed when making layouts) (defvar *layout-layout*) -;;; FIXME: This information should probably be pulled out of the -;;; cross-compiler's tables at genesis time instead of inserted by -;;; hand here as a bare numeric constant. -(defconstant target-layout-length 18) +(defconstant target-layout-length + (layout-length (find-layout 'layout))) + +(defun target-layout-index (slot-name) + ;; KLUDGE: this is a little bit sleazy, but the tricky thing is that + ;; structure slots don't have a terribly firm idea of their names. + ;; At least here if we change LAYOUT's package of definition, we + ;; only have to change one thing... + (let* ((name (find-symbol (symbol-name slot-name) "SB!KERNEL")) + (layout (find-layout 'layout)) + (dd (layout-info layout)) + (slots (dd-slots dd)) + (dsd (find name slots :key #'dsd-name))) + (aver dsd) + (dsd-index dsd))) + +(defun cold-set-layout-slot (cold-layout slot-name value) + (write-wordindexed + cold-layout + (+ sb!vm:instance-slots-offset (target-layout-index slot-name)) + value)) ;;; Return a list of names created from the cold layout INHERITS data ;;; in X. @@ -878,6 +895,7 @@ core and return a descriptor to it." (defun make-cold-layout (name length inherits depthoid nuntagged) (let ((result (allocate-boxed-object *dynamic* ;; KLUDGE: Why 1+? -- WHN 19990901 + ;; header word? -- CSR 20051204 (1+ target-layout-length) sb!vm:instance-pointer-lowtag))) (write-memory result @@ -891,7 +909,7 @@ 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 immediately following slots = CLOS hash values. + ;; Set the CLOS hash value. ;; ;; 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 @@ -917,41 +935,31 @@ core and return a descriptor to it." ;; 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. - (dotimes (i sb!kernel:layout-clos-hash-length) - (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) - ;; (The MOD here is defensive programming - ;; to make sure we never write an - ;; out-of-range value even if some joker - ;; sets LAYOUT-CLOS-HASH-MAX to other - ;; than 2^n-1 at some time in the - ;; future.) - sb!kernel:layout-clos-hash-max)))) - (write-wordindexed result - (+ i sb!vm:instance-slots-offset 1) - (make-fixnum-descriptor hash-value)))) + (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. - (let ((base (+ sb!vm:instance-slots-offset - sb!kernel:layout-clos-hash-length - 1))) - ;; (Offset 0 is CLASS, "the class this is a layout for", which - ;; is uninitialized at this point.) - (write-wordindexed result (+ base 1) *nil-descriptor*) ; marked invalid - (write-wordindexed result (+ base 2) inherits) - (write-wordindexed result (+ base 3) depthoid) - (write-wordindexed result (+ base 4) length) - (write-wordindexed result (+ base 5) *nil-descriptor*) ; info - (write-wordindexed result (+ base 6) *nil-descriptor*) ; pure - (write-wordindexed result (+ base 7) nuntagged)) + ;; + ;; leave CLASSOID uninitialized for now + (cold-set-layout-slot result 'invalid *nil-descriptor*) + (cold-set-layout-slot result 'inherits inherits) + (cold-set-layout-slot result 'depthoid depthoid) + (cold-set-layout-slot result 'length length) + (cold-set-layout-slot result 'info *nil-descriptor*) + (cold-set-layout-slot result 'pure *nil-descriptor*) + (cold-set-layout-slot result 'n-untagged-slots nuntagged) + (cold-set-layout-slot result 'for-std-class-p *nil-descriptor*) (setf (gethash name *cold-layouts*) (list result @@ -971,17 +979,16 @@ core and return a descriptor to it." ;; We initially create the layout of LAYOUT itself with NIL as the LAYOUT and ;; #() as INHERITS, (setq *layout-layout* *nil-descriptor*) - (setq *layout-layout* - (make-cold-layout 'layout - (number-to-core target-layout-length) - (vector-in-core) - ;; FIXME: hard-coded LAYOUT-DEPTHOID of LAYOUT.. - (number-to-core 3) - ;; no raw slots in LAYOUT: - (number-to-core 0))) - (write-wordindexed *layout-layout* - sb!vm:instance-slots-offset - *layout-layout*) + (let ((xlayout-layout (find-layout 'layout))) + (aver (= 0 (layout-n-untagged-slots xlayout-layout))) + (setq *layout-layout* + (make-cold-layout 'layout + (number-to-core target-layout-length) + (vector-in-core) + (number-to-core (layout-depthoid xlayout-layout)) + (number-to-core 0))) + (write-wordindexed + *layout-layout* sb!vm:instance-slots-offset *layout-layout*) ;; Then we create the layouts that we'll need to make a correct INHERITS ;; vector for the layout of LAYOUT itself.. @@ -1013,13 +1020,7 @@ core and return a descriptor to it." ;; ..and return to backpatch the layout of LAYOUT. (setf (fourth (gethash 'layout *cold-layouts*)) (listify-cold-inherits layout-inherits)) - (write-wordindexed *layout-layout* - ;; FIXME: hardcoded offset into layout struct - (+ sb!vm:instance-slots-offset - layout-clos-hash-length - 1 - 2) - layout-inherits))) + (cold-set-layout-slot *layout-layout* 'inherits layout-inherits)))) ;;;; interning symbols in the cold image @@ -1107,7 +1108,8 @@ core and return a descriptor to it." *cl-package* ;; ordinary case (let ((result (symbol-package symbol))) - (aver (package-ok-for-target-symbol-p result)) + (unless (package-ok-for-target-symbol-p result) + (bug "~A in bad package for target: ~A" symbol result)) result)))) ;;; Return a handle on an interned symbol. If necessary allocate the @@ -1726,32 +1728,44 @@ core and return a descriptor to it." (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)))) + (logior (mask-field (byte 18 14) + (bvref-32 gspace-bytes gspace-byte-offset)) + (if (< value 0) + (1+ (ash (ldb (byte 13 0) value) 1)) + (ash (ldb (byte 13 0) value) 1))))) + (:load11u + (setf (bvref-32 gspace-bytes gspace-byte-offset) + (logior (mask-field (byte 18 14) + (bvref-32 gspace-bytes gspace-byte-offset)) + (if (< value 0) + (1+ (ash (ldb (byte 10 0) value) 1)) + (ash (ldb (byte 11 0) value) 1))))) (: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))))) + (assert (<= 0 low-bits (1- (ash 1 4))))) + (setf (bvref-32 gspace-bytes gspace-byte-offset) + (logior (ash (dpb (ldb (byte 4 0) value) + (byte 4 1) + (ldb (byte 1 4) value)) 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) + (logior (mask-field (byte 11 21) + (bvref-32 gspace-bytes gspace-byte-offset)) + (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)))) + (ldb (byte 1 31) value)))) (: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))))))) + (mask-field (byte 1 1) (bvref-32 gspace-bytes gspace-byte-offset)) + (mask-field (byte 3 13) (bvref-32 gspace-bytes gspace-byte-offset)) + (mask-field (byte 11 21) (bvref-32 gspace-bytes gspace-byte-offset)))))))) (:mips (ecase kind (:jump @@ -1967,7 +1981,10 @@ core and return a descriptor to it." (layout (pop-stack)) (nuntagged (descriptor-fixnum - (read-wordindexed layout (+ sb!vm:instance-slots-offset 16)))) + (read-wordindexed + layout + (+ sb!vm:instance-slots-offset + (target-layout-index 'n-untagged-slots))))) (ntagged (- size nuntagged))) (write-memory result (make-other-immediate-descriptor size sb!vm:instance-header-widetag)) @@ -2589,6 +2606,30 @@ core and return a descriptor to it." (do-cold-fixup code-object offset value kind) code-object)) +;;;; sanity checking space layouts + +(defun check-spaces () + ;;; Co-opt type machinery to check for intersections... + (let (types) + (flet ((check (start end space) + (unless (< start end) + (error "Bogus space: ~A" space)) + (let ((type (specifier-type `(integer ,start ,end)))) + (dolist (other types) + (unless (eq *empty-type* (type-intersection (cdr other) type)) + (error "Space overlap: ~A with ~A" space (car other)))) + (push (cons space type) types)))) + (check sb!vm:read-only-space-start sb!vm:read-only-space-end :read-only) + (check sb!vm:static-space-start sb!vm:static-space-end :static) + #!+gencgc + (check sb!vm:dynamic-space-start sb!vm:dynamic-space-end :dynamic) + #!-gencgc + (progn + (check sb!vm:dynamic-0-space-start sb!vm:dynamic-0-space-end :dynamic-0) + (check sb!vm:dynamic-1-space-start sb!vm:dynamic-1-space-end :dynamic-1)) + #!+linkage-table + (check sb!vm:linkage-table-space-start sb!vm:linkage-table-space-end :linkage-table)))) + ;;;; emitting C header file (defun tailwise-equal (string tail) @@ -2613,9 +2654,9 @@ core and return a descriptor to it." (defun c-name (string &optional strip) (delete #\+ - (nsubstitute-if #\_ (lambda (c) (member c '(#\- #\/ #\%))) - (remove-if (lambda (c) (position c strip)) - string)))) + (substitute-if #\_ (lambda (c) (member c '(#\- #\/ #\%))) + (remove-if (lambda (c) (position c strip)) + string)))) (defun c-symbol-name (symbol &optional strip) (c-name (symbol-name symbol) strip)) @@ -2662,10 +2703,11 @@ core and return a descriptor to it." (when (constantp symbol) (let ((name (symbol-name symbol))) (labels ( ;; shared machinery - (record (string priority) + (record (string priority suffix) (push (list string priority (symbol-value symbol) + suffix (documentation symbol 'variable)) constants)) ;; machinery for old-style CMU CL Lisp-to-C @@ -2677,7 +2719,8 @@ core and return a descriptor to it." 'simple-string prefix (delete #\- (string-capitalize string))) - priority)) + priority + "")) (maybe-record-with-munged-name (tail prefix priority) (when (tailwise-equal name tail) (record-with-munged-name prefix @@ -2686,23 +2729,23 @@ core and return a descriptor to it." (length tail))) priority))) ;; machinery for new-style SBCL Lisp-to-C naming - (record-with-translated-name (priority) - (record (c-name name) priority)) - (maybe-record-with-translated-name (suffixes priority) + (record-with-translated-name (priority large) + (record (c-name name) priority (if large "LU" ""))) + (maybe-record-with-translated-name (suffixes priority &key large) (when (some (lambda (suffix) (tailwise-equal name suffix)) suffixes) - (record-with-translated-name priority)))) - + (record-with-translated-name priority large)))) (maybe-record-with-translated-name '("-LOWTAG") 0) - (maybe-record-with-translated-name '("-WIDETAG") 1) + (maybe-record-with-translated-name '("-WIDETAG" "-SHIFT") 1) (maybe-record-with-munged-name "-FLAG" "flag_" 2) (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" "-SIZE") 6) - (maybe-record-with-translated-name '("-CORE-ENTRY-TYPE-CODE") 7) - (maybe-record-with-translated-name '("-CORE-SPACE-ID") 8)))))) + (maybe-record-with-translated-name '("-SIZE") 6) + (maybe-record-with-translated-name '("-START" "-END" "-PAGE-BYTES") 7 :large t) + (maybe-record-with-translated-name '("-CORE-ENTRY-TYPE-CODE") 8) + (maybe-record-with-translated-name '("-CORE-SPACE-ID") 9)))))) ;; 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 @@ -2716,6 +2759,7 @@ core and return a descriptor to it." (push (list (c-symbol-name c) -1 ; invent a new priority (symbol-value c) + "" nil) constants)) ;; One more symbol that doesn't fit into the code above. @@ -2723,9 +2767,9 @@ core and return a descriptor to it." (push (list (c-symbol-name c) 9 (symbol-value c) + "LU" nil) constants)) - (setf constants (sort constants (lambda (const1 const2) @@ -2734,33 +2778,13 @@ core and return a descriptor to it." (< (second const1) (second const2)))))) (let ((prev-priority (second (car constants)))) (dolist (const constants) - (destructuring-bind (name priority value doc) const + (destructuring-bind (name priority value suffix doc) const (unless (= prev-priority priority) (terpri) (setf prev-priority priority)) - (format t "#define ~A " name) - (format t - ;; KLUDGE: We're dumping two different kinds of - ;; values here, (1) small codes and (2) machine - ;; addresses. The small codes can be dumped as bare - ;; integer values. The large machine addresses might - ;; cause problems if they're large and represented - ;; as (signed) C integers, so we want to force them - ;; to be unsigned by appending an U to the - ;; literal. We can't dump all the values using the - ;; literal-U syntax, since the assembler doesn't - ;; support that syntax and some of the small - ;; constants can be used in assembler files. - (let ( ;; cutoff for treatment as a small code - (cutoff (expt 2 16))) - (cond ((minusp value) - (error "stub: negative values unsupported")) - ((< value cutoff) - "~D") - (t - "~DU"))) - value) - (format t " /* 0x~X */~@[ /* ~A */~]~%" value doc)))) + (when (minusp value) + (error "stub: negative values unsupported")) + (format t "#define ~A ~A~A /* 0x~X ~@[ -- ~A ~]*/~%" name value suffix value doc)))) (terpri)) ;; writing information about internal errors @@ -2778,7 +2802,7 @@ core and return a descriptor to it." ;; I'm not really sure why this is in SB!C, since it seems ;; conceptually like something that belongs to SB!VM. In any case, ;; it's needed C-side. - (format t "#define BACKEND_PAGE_SIZE ~DU~%" sb!c:*backend-page-size*) + (format t "#define BACKEND_PAGE_BYTES ~DLU~%" sb!c:*backend-page-bytes*) (terpri) @@ -2973,17 +2997,17 @@ initially undefined function references:~2%") (force-output *core-file*) (file-position *core-file* (round-up (file-position *core-file*) - sb!c:*backend-page-size*))) + sb!c:*backend-page-bytes*))) (defun output-gspace (gspace) (force-output *core-file*) (let* ((posn (file-position *core-file*)) (bytes (* (gspace-free-word-index gspace) sb!vm:n-word-bytes)) - (pages (ceiling bytes sb!c:*backend-page-size*)) - (total-bytes (* pages sb!c:*backend-page-size*))) + (pages (ceiling bytes sb!c:*backend-page-bytes*)) + (total-bytes (* pages sb!c:*backend-page-bytes*))) (file-position *core-file* - (* sb!c:*backend-page-size* (1+ *data-page*))) + (* sb!c:*backend-page-bytes* (1+ *data-page*))) (format t "writing ~S byte~:P [~S page~:P] from ~S~%" total-bytes @@ -3013,7 +3037,7 @@ initially undefined function references:~2%") (write-word (gspace-free-word-index gspace)) (write-word *data-page*) (multiple-value-bind (floor rem) - (floor (gspace-byte-address gspace) sb!c:*backend-page-size*) + (floor (gspace-byte-address gspace) sb!c:*backend-page-bytes*) (aver (zerop rem)) (write-word floor)) (write-word pages) @@ -3157,6 +3181,8 @@ initially undefined function references:~2%") (do-all-symbols (sym) (remprop sym 'cold-intern-info)) + (check-spaces) + (let* ((*foreign-symbol-placeholder-value* (if core-file-name nil 0)) (*load-time-value-counter* 0) (*cold-fdefn-objects* (make-hash-table :test 'equal))