;;; 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.
(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
;; 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
;; 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
;; 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..
;; ..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))))
\f
;;;; interning symbols in the cold image
*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
(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
(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))
(do-cold-fixup code-object offset value kind)
code-object))
\f
+;;;; 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))))
+\f
;;;; emitting C header file
(defun tailwise-equal (string tail)
(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
'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
(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
(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.
(push (list (c-symbol-name c)
9
(symbol-value c)
+ "LU"
nil)
constants))
-
(setf constants
(sort constants
(lambda (const1 const2)
(< (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
;; 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)
(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
(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)
(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))
projects / sbcl.git / blobdiff