;;; 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
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)
- #!+win32 (frob handle-win32-exception)
- (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))
(symbols (cdr cold-package-symbols-entry))
(shadows (package-shadowing-symbols cold-package))
(documentation (base-string-to-core (documentation cold-package t)))
+ (internal-count 0)
+ (external-count 0)
(internal *nil-descriptor*)
(external *nil-descriptor*)
(imported-internal *nil-descriptor*)
(case where
(:internal (if imported-p
(cold-push handle imported-internal)
- (cold-push handle internal)))
+ (progn
+ (cold-push handle internal)
+ (incf internal-count))))
(:external (if imported-p
(cold-push handle imported-external)
- (cold-push handle external)))))))
+ (progn
+ (cold-push handle external)
+ (incf external-count))))))))
(let ((r *nil-descriptor*))
(cold-push documentation r)
(cold-push shadowing r)
(cold-push imported-internal r)
(cold-push external r)
(cold-push internal r)
- (cold-push (make-make-package-args cold-package) r)
+ (cold-push (make-make-package-args cold-package
+ internal-count
+ external-count)
+ r)
;; FIXME: It would be more space-efficient to use vectors
;; instead of lists here, and space-efficiency here would be
;; nice, since it would reduce the peak memory usage in
(cold-set 'sb!vm::*fp-constant-0f0* (number-to-core 0f0))
(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.
-(defun make-make-package-args (pkg)
+;;; 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.
+(defun make-make-package-args (pkg internal-count external-count)
(let* ((use *nil-descriptor*)
(cold-nicknames *nil-descriptor*)
(res *nil-descriptor*))
(dolist (warm-nickname warm-nicknames)
(cold-push (base-string-to-core warm-nickname) cold-nicknames)))
- (cold-push (number-to-core (truncate (package-internal-symbol-count pkg)
- 0.8))
- res)
+ ;; INTERNAL-COUNT and EXTERNAL-COUNT are the number of symbols that
+ ;; the package contains in the core. We arrange for the package
+ ;; symbol tables to be created somewhat larger so that they don't
+ ;; need to be rehashed so easily when additional symbols are
+ ;; interned during the warm build.
+ (cold-push (number-to-core (truncate internal-count 0.8)) res)
(cold-push (cold-intern :internal-symbols) res)
- (cold-push (number-to-core (truncate (package-external-symbol-count pkg)
- 0.8))
- res)
+ (cold-push (number-to-core (truncate external-count 0.8)) res)
(cold-push (cold-intern :external-symbols) res)
(cold-push cold-nicknames res)
(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
(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))
(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 c-name (string &optional strip)
+ (delete #\+
+ (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))
+
+(defun write-makefile-features ()
+ ;; propagating *SHEBANG-FEATURES* into the Makefiles
+ (dolist (shebang-feature-name (sort (mapcar #'c-symbol-name
+ sb-cold:*shebang-features*)
+ #'string<))
+ (format t "LISP_FEATURE_~A=1~%" shebang-feature-name)))
+
(defun write-config-h ()
;; propagating *SHEBANG-FEATURES* into C-level #define's
- (dolist (shebang-feature-name (sort (mapcar #'symbol-name
+ (dolist (shebang-feature-name (sort (mapcar #'c-symbol-name
sb-cold:*shebang-features*)
#'string<))
- (format t
- "#define LISP_FEATURE_~A~%"
- (substitute #\_ #\- shebang-feature-name)))
+ (format t "#define LISP_FEATURE_~A~%" shebang-feature-name))
(terpri)
;; and miscellaneous constants
(format t "#define SBCL_CORE_VERSION_INTEGER ~D~%" sbcl-core-version-integer)
(defun write-constants-h ()
;; writing entire families of named constants
(let ((constants nil))
- (dolist (package-name '(;; Even in CMU CL, constants from VM
+ (dolist (package-name '( ;; Even in CMU CL, constants from VM
;; were automatically propagated
;; into the runtime.
"SB!VM"
(do-external-symbols (symbol (find-package package-name))
(when (constantp symbol)
(let ((name (symbol-name symbol)))
- (labels (;; shared machinery
- (record (string priority)
+ (labels ( ;; shared machinery
+ (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 (substitute #\_ #\- 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
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))
+ (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.
- (flet ((translate (name)
- (delete #\+ (substitute #\_ #\- name))))
- (let ((c 'sb!impl::+magic-hash-vector-value+))
- (push (list (translate (symbol-name c))
- 9
- (symbol-value c)
- nil)
- constants)))
-
+ (let ((c 'sb!impl::+magic-hash-vector-value+))
+ (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: As of sbcl-0.6.7.14, 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. We do that by
- ;; wrapping them in the LISPOBJ macro. (We could do
- ;; it with a bare "(unsigned)" cast, except that
- ;; this header file is used not only in C files, but
- ;; also in assembly files, which don't understand
- ;; the cast syntax. The LISPOBJ macro goes away in
- ;; assembly files, but that shouldn't matter because
- ;; we don't do arithmetic on address constants in
- ;; assembly files. See? It really is a kludge..) --
- ;; WHN 2000-10-18
- (let (;; cutoff for treatment as a small code
- (cutoff (expt 2 16)))
- (cond ((minusp value)
- (error "stub: negative values unsupported"))
- ((< value cutoff)
- "~D")
- (t
- "LISPOBJ(~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
;; interr.lisp) -- APD, 2002-03-05
(unless (eq nil (car current-error))
(format t "#define ~A ~D~%"
- (substitute #\_ #\- (symbol-name (car current-error)))
+ (c-symbol-name (car current-error))
i)))))
(terpri)
+ ;; 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_BYTES ~DLU~%" sb!c:*backend-page-bytes*)
+
+ (terpri)
+
;; FIXME: The SPARC has a PSEUDO-ATOMIC-TRAP that differs between
;; platforms. If we export this from the SB!VM package, it gets
;; written out as #define trap_PseudoAtomic, which is confusing as
sb!vm::float-sticky-bits
sb!vm::float-rounding-mode))
(format t "#define ~A_POSITION ~A /* ~:*0x~X */~%"
- (substitute #\_ #\- (symbol-name symbol))
+ (c-symbol-name symbol)
(sb!xc:byte-position (symbol-value symbol)))
(format t "#define ~A_MASK 0x~X /* ~:*~A */~%"
- (substitute #\_ #\- (symbol-name symbol))
+ (c-symbol-name symbol)
(sb!xc:mask-field (symbol-value symbol) -1))))
(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 {~%"
+ (c-name (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")
+ (c-name (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~%"
+ (c-symbol-name name)
+ (c-symbol-name (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)
- (substitute
- #\_ #\%
- (substitute #\_ #\- (string-downcase (string designator))))))
+ (c-name (string-downcase (string designator)))))
(format t "#ifndef LANGUAGE_ASSEMBLY~2%")
(format t "struct ~A {~%" (cstring (dd-name dd)))
(format t " lispobj header;~%")
(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%")))
;; FIXME: It would be nice to use longer names than NIL and
;; (particularly) T in #define statements.
(format t "#define ~A LISPOBJ(0x~X)~%"
- (substitute #\_ #\-
- (remove-if (lambda (char)
- (member char '(#\% #\* #\. #\!)))
- (symbol-name symbol)))
+ ;; FIXME: It would be nice not to need to strip anything
+ ;; that doesn't get stripped always by C-SYMBOL-NAME.
+ (c-symbol-name symbol "%*.!")
(if *static* ; if we ran GENESIS
;; We actually ran GENESIS, use the real value.
(descriptor-bits (cold-intern symbol))
(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))
(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)
(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.
(with-open-file (*standard-output* fn
:if-exists :supersede :direction :output)
(write-boilerplate)
- (let ((n (substitute #\_ #\- (string-upcase ,name))))
+ (let ((n (c-name (string-upcase ,name))))
(format
t
"#ifndef SBCL_GENESIS_~A~%#define SBCL_GENESIS_~A 1~%"
(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