offset-wanted))))
;; Establish the value of T.
(let ((t-symbol (cold-intern t)))
- (cold-set t-symbol t-symbol))))
+ (cold-set t-symbol t-symbol))
+ ;; Establish the value of *PSEUDO-ATOMIC-BITS* so that the
+ ;; allocation sequences that expect it to be zero upon entrance
+ ;; actually find it to be so.
+ #!+(or x86-64 x86)
+ (let ((p-a-a-symbol (cold-intern 'sb!kernel:*pseudo-atomic-bits*)))
+ (cold-set p-a-a-symbol (make-fixnum-descriptor 0)))))
;;; a helper function for FINISH-SYMBOLS: Return a cold alist suitable
;;; to be stored in *!INITIAL-LAYOUTS*.
;; the names to highlight that something weird is going on. Perhaps
;; *MAYBE-GC-FUN*, *INTERNAL-ERROR-FUN*, *HANDLE-BREAKPOINT-FUN*,
;; and *HANDLE-FUN-END-BREAKPOINT-FUN*...
- (macrolet ((frob (symbol)
- `(cold-set ',symbol
- (cold-fdefinition-object (cold-intern ',symbol)))))
- (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)
- #!+sb-thread (frob sb!thread::run-interruption))
+ (dolist (symbol sb!vm::*c-callable-static-symbols*)
+ (cold-set symbol (cold-fdefinition-object (cold-intern symbol))))
(cold-set 'sb!vm::*current-catch-block* (make-fixnum-descriptor 0))
(cold-set 'sb!vm::*current-unwind-protect-block* (make-fixnum-descriptor 0))
(setf (bvref-32 gspace-bytes gspace-byte-offset)
(logior (mask-field (byte 16 16)
(bvref-32 gspace-bytes gspace-byte-offset))
- (+ (ash value -16)
- (if (logbitp 15 value) 1 0)))))
+ (ash (1+ (ldb (byte 17 15) value)) -1))))
(:addi
(setf (bvref-32 gspace-bytes gspace-byte-offset)
(logior (mask-field (byte 16 16)
(bvref-32 gspace-bytes gspace-byte-offset))
(ldb (byte 16 0) value))))))
+ ;; FIXME: PowerPC Fixups are not fully implemented. The bit
+ ;; here starts to set things up to work properly, but there
+ ;; needs to be corresponding code in ppc-vm.lisp
(:ppc
- (ecase kind
- (:ba
- (setf (bvref-32 gspace-bytes gspace-byte-offset)
- (dpb (ash value -2) (byte 24 2)
- (bvref-32 gspace-bytes gspace-byte-offset))))
- (:ha
- (let* ((h (ldb (byte 16 16) value))
- (l (ldb (byte 16 0) value)))
- (setf (bvref-16 gspace-bytes (+ gspace-byte-offset 2))
- (if (logbitp 15 l) (ldb (byte 16 0) (1+ h)) h))))
- (:l
- (setf (bvref-16 gspace-bytes (+ gspace-byte-offset 2))
- (ldb (byte 16 0) value)))))
+ (ecase kind
+ (:ba
+ (setf (bvref-32 gspace-bytes gspace-byte-offset)
+ (dpb (ash value -2) (byte 24 2)
+ (bvref-32 gspace-bytes gspace-byte-offset))))
+ (:ha
+ (let* ((un-fixed-up (bvref-16 gspace-bytes
+ (+ gspace-byte-offset 2)))
+ (fixed-up (+ un-fixed-up value))
+ (h (ldb (byte 16 16) fixed-up))
+ (l (ldb (byte 16 0) fixed-up)))
+ (setf (bvref-16 gspace-bytes (+ gspace-byte-offset 2))
+ (if (logbitp 15 l) (ldb (byte 16 0) (1+ h)) h))))
+ (:l
+ (let* ((un-fixed-up (bvref-16 gspace-bytes
+ (+ gspace-byte-offset 2)))
+ (fixed-up (+ un-fixed-up value)))
+ (setf (bvref-16 gspace-bytes (+ gspace-byte-offset 2))
+ (ldb (byte 16 0) fixed-up))))))
(:sparc
(ecase kind
(:call
(write-wordindexed code slot value)))
(define-cold-fop (fop-fun-entry)
- (let* ((type (pop-stack))
+ (let* ((xrefs (pop-stack))
+ (type (pop-stack))
(arglist (pop-stack))
(name (pop-stack))
(code-object (pop-stack))
(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)
fn))
(define-cold-fop (fop-foreign-fixup)
(format t " *~@[ ~A~]~%" line))
(format t " */~%"))
+(defun write-makefile-features ()
+ ;; propagating *SHEBANG-FEATURES* into the Makefiles
+ (dolist (shebang-feature-name (sort (mapcar #'symbol-name
+ sb-cold:*shebang-features*)
+ #'string<))
+ (format t
+ "LISP_FEATURE_~A=1~%"
+ (substitute #\_ #\- shebang-feature-name))))
+
(defun write-config-h ()
;; propagating *SHEBANG-FEATURES* into C-level #define's
(dolist (shebang-feature-name (sort (mapcar #'symbol-name
(defun write-primitive-object (obj)
;; writing primitive object layouts
- (format t "#ifndef LANGUAGE_ASSEMBLY~2%")
- (format t
- "struct ~A {~%"
- (substitute #\_ #\-
- (string-downcase (string (sb!vm:primitive-object-name obj)))))
- (when (sb!vm:primitive-object-widetag obj)
- (format t " lispobj header;~%"))
- (dolist (slot (sb!vm:primitive-object-slots obj))
- (format t " ~A ~A~@[[1]~];~%"
- (getf (sb!vm:slot-options slot) :c-type "lispobj")
- (substitute #\_ #\-
- (string-downcase (string (sb!vm:slot-name slot))))
- (sb!vm:slot-rest-p slot)))
+ (format t "#ifndef LANGUAGE_ASSEMBLY~2%")
+ (format t
+ "struct ~A {~%"
+ (substitute #\_ #\-
+ (string-downcase (string (sb!vm:primitive-object-name obj)))))
+ (when (sb!vm:primitive-object-widetag obj)
+ (format t " lispobj header;~%"))
+ (dolist (slot (sb!vm:primitive-object-slots obj))
+ (format t " ~A ~A~@[[1]~];~%"
+ (getf (sb!vm:slot-options slot) :c-type "lispobj")
+ (substitute #\_ #\-
+ (string-downcase (string (sb!vm:slot-name slot))))
+ (sb!vm:slot-rest-p slot)))
(format t "};~2%")
- (format t "#else /* LANGUAGE_ASSEMBLY */~2%")
- (let ((name (sb!vm:primitive-object-name obj))
- (lowtag (eval (sb!vm:primitive-object-lowtag obj))))
- (when lowtag
- (dolist (slot (sb!vm:primitive-object-slots obj))
- (format t "#define ~A_~A_OFFSET ~D~%"
- (substitute #\_ #\- (string name))
- (substitute #\_ #\- (string (sb!vm:slot-name slot)))
- (- (* (sb!vm:slot-offset slot) sb!vm:n-word-bytes) lowtag)))
+ (format t "#else /* LANGUAGE_ASSEMBLY */~2%")
+ (format t "/* These offsets are SLOT-OFFSET * N-WORD-BYTES - LOWTAG~%")
+ (format t " * so they work directly on tagged addresses. */~2%")
+ (let ((name (sb!vm:primitive-object-name obj))
+ (lowtag (eval (sb!vm:primitive-object-lowtag obj))))
+ (when lowtag
+ (dolist (slot (sb!vm:primitive-object-slots obj))
+ (format t "#define ~A_~A_OFFSET ~D~%"
+ (substitute #\_ #\- (string name))
+ (substitute #\_ #\- (string (sb!vm:slot-name slot)))
+ (- (* (sb!vm:slot-offset slot) sb!vm:n-word-bytes) lowtag)))
(terpri)))
- (format t "#endif /* LANGUAGE_ASSEMBLY */~2%"))
+ (format t "#endif /* LANGUAGE_ASSEMBLY */~2%"))
(defun write-structure-object (dd)
(flet ((cstring (designator)
(when (eq t (dsd-raw-type slot))
(format t " lispobj ~A;~%" (cstring (dsd-name slot)))))
(unless (oddp (+ (dd-length dd) (dd-raw-length dd)))
- (format t " long raw_slot_padding;~%"))
+ (format t " lispobj raw_slot_padding;~%"))
(dotimes (n (dd-raw-length dd))
- (format t " long raw~D;~%" (- (dd-raw-length dd) n 1)))
+ (format t " lispobj raw~D;~%" (- (dd-raw-length dd) n 1)))
(format t "};~2%")
(format t "#endif /* LANGUAGE_ASSEMBLY */~2%")))
(defconstant new-directory-core-entry-type-code 3861)
(defconstant initial-fun-core-entry-type-code 3863)
(defconstant page-table-core-entry-type-code 3880)
+#!+(and sb-lutex sb-thread)
+(defconstant lutex-table-core-entry-type-code 3887)
(defconstant end-core-entry-type-code 3840)
(declaim (ftype (function (sb!vm:word) sb!vm:word) write-word))
(allocate-cold-descriptor *static*
0
sb!vm:even-fixnum-lowtag))
- (cold-set 'sb!vm:*initial-dynamic-space-free-pointer*
- (allocate-cold-descriptor *dynamic*
- 0
- sb!vm:even-fixnum-lowtag))
(/show "done setting free pointers")
;; Write results to files.
(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 map-file-name
+ (with-open-file (*standard-output* map-file-name
+ :direction :output
+ :if-exists :supersede)
+ (write-map)))
(out-to "config" (write-config-h))
(out-to "constants" (write-constants-h))
(let ((structs (sort (copy-list sb!vm:*primitive-objects*) #'string<
(sb!kernel:layout-info (sb!kernel:find-layout class)))))
(out-to "static-symbols" (write-static-symbols))
- (when core-file-name
+ (let ((fn (format nil "~A/Makefile.features" c-header-dir-name)))
+ (ensure-directories-exist fn)
+ (with-open-file (*standard-output* fn :if-exists :supersede
+ :direction :output)
+ (write-makefile-features)))
+
+ (when core-file-name
(write-initial-core-file core-file-name))))))
+
+
projects / sbcl.git / blobdiff