"Round NUMBER up to be an integral multiple of SIZE."
(* size (ceiling number size)))
\f
+;;;; implementing the concept of "vector" in (almost) portable
+;;;; Common Lisp
+;;;;
+;;;; "If you only need to do such simple things, it doesn't really
+;;;; matter which language you use." -- _ANSI Common Lisp_, p. 1, Paul
+;;;; Graham (evidently not considering the abstraction "vector" to be
+;;;; such a simple thing:-)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defconstant +smallvec-length+
+ (expt 2 16)))
+
+;;; an element of a BIGVEC -- a vector small enough that we have
+;;; a good chance of it being portable to other Common Lisps
+(deftype smallvec ()
+ `(simple-array (unsigned-byte 8) (,+smallvec-length+)))
+
+(defun make-smallvec ()
+ (make-array +smallvec-length+ :element-type '(unsigned-byte 8)))
+
+;;; a big vector, implemented as a vector of SMALLVECs
+;;;
+;;; KLUDGE: This implementation seems portable enough for our
+;;; purposes, since realistically every modern implementation is
+;;; likely to support vectors of at least 2^16 elements. But if you're
+;;; masochistic enough to read this far into the contortions imposed
+;;; on us by ANSI and the Lisp community, for daring to use the
+;;; abstraction of a large linearly addressable memory space, which is
+;;; after all only directly supported by the underlying hardware of at
+;;; least 99% of the general-purpose computers in use today, then you
+;;; may be titillated to hear that in fact this code isn't really
+;;; portable, because as of sbcl-0.7.4 we need somewhat more than
+;;; 16Mbytes to represent a core, and ANSI only guarantees that
+;;; ARRAY-DIMENSION-LIMIT is not less than 1024. -- WHN 2002-06-13
+(defstruct bigvec
+ (outer-vector (vector (make-smallvec)) :type (vector smallvec)))
+
+;;; analogous to SVREF, but into a BIGVEC
+(defun bvref (bigvec index)
+ (multiple-value-bind (outer-index inner-index)
+ (floor index +smallvec-length+)
+ (aref (the smallvec
+ (svref (bigvec-outer-vector bigvec) outer-index))
+ inner-index)))
+(defun (setf bvref) (new-value bigvec index)
+ (multiple-value-bind (outer-index inner-index)
+ (floor index +smallvec-length+)
+ (setf (aref (the smallvec
+ (svref (bigvec-outer-vector bigvec) outer-index))
+ inner-index)
+ new-value)))
+
+;;; analogous to LENGTH, but for a BIGVEC
+;;;
+;;; the length of BIGVEC, measured in the number of BVREFable bytes it
+;;; can hold
+(defun bvlength (bigvec)
+ (* (length (bigvec-outer-vector bigvec))
+ +smallvec-length+))
+
+;;; analogous to WRITE-SEQUENCE, but for a BIGVEC
+(defun write-bigvec-as-sequence (bigvec stream &key (start 0) end)
+ (loop for i of-type index from start below (or end (bvlength bigvec)) do
+ (write-byte (bvref bigvec i)
+ stream)))
+
+;;; analogous to READ-SEQUENCE-OR-DIE, but for a BIGVEC
+(defun read-bigvec-as-sequence-or-die (bigvec stream &key (start 0) end)
+ (loop for i of-type index from start below (or end (bvlength bigvec)) do
+ (setf (bvref bigvec i)
+ (read-byte stream))))
+
+;;; Grow BIGVEC (exponentially, so that large increases in size have
+;;; asymptotic logarithmic cost per byte).
+(defun expand-bigvec (bigvec)
+ (let* ((old-outer-vector (bigvec-outer-vector bigvec))
+ (length-old-outer-vector (length old-outer-vector))
+ (new-outer-vector (make-array (* 2 length-old-outer-vector))))
+ (dotimes (i length-old-outer-vector)
+ (setf (svref new-outer-vector i)
+ (svref old-outer-vector i)))
+ (loop for i from length-old-outer-vector below (length new-outer-vector) do
+ (setf (svref new-outer-vector i)
+ (make-smallvec)))
+ (setf (bigvec-outer-vector bigvec)
+ new-outer-vector))
+ bigvec)
+\f
+;;;; looking up bytes and multi-byte values in a BIGVEC (considering
+;;;; it as an image of machine memory)
+
+;;; BVREF-32 and friends. These are like SAP-REF-n, except that
+;;; instead of a SAP we use a BIGVEC.
+(macrolet ((make-bvref-n
+ (n)
+ (let* ((name (intern (format nil "BVREF-~A" n)))
+ (number-octets (/ n 8))
+ (ash-list-le
+ (loop for i from 0 to (1- number-octets)
+ collect `(ash (bvref bigvec (+ byte-index ,i))
+ ,(* i 8))))
+ (ash-list-be
+ (loop for i from 0 to (1- number-octets)
+ collect `(ash (bvref bigvec
+ (+ byte-index
+ ,(- number-octets 1 i)))
+ ,(* i 8))))
+ (setf-list-le
+ (loop for i from 0 to (1- number-octets)
+ append
+ `((bvref bigvec (+ byte-index ,i))
+ (ldb (byte 8 ,(* i 8)) new-value))))
+ (setf-list-be
+ (loop for i from 0 to (1- number-octets)
+ append
+ `((bvref bigvec (+ byte-index ,i))
+ (ldb (byte 8 ,(- n 8 (* i 8))) new-value)))))
+ `(progn
+ (defun ,name (bigvec byte-index)
+ (aver (= sb!vm:n-word-bits 32))
+ (aver (= sb!vm:n-byte-bits 8))
+ (logior ,@(ecase sb!c:*backend-byte-order*
+ (:little-endian ash-list-le)
+ (:big-endian ash-list-be))))
+ (defun (setf ,name) (new-value bigvec byte-index)
+ (aver (= sb!vm:n-word-bits 32))
+ (aver (= sb!vm:n-byte-bits 8))
+ (setf ,@(ecase sb!c:*backend-byte-order*
+ (:little-endian setf-list-le)
+ (:big-endian setf-list-be))))))))
+ (make-bvref-n 8)
+ (make-bvref-n 16)
+ (make-bvref-n 32))
+\f
;;;; representation of spaces in the core
;;; If there is more than one dynamic space in memory (i.e., if a
;;; copying GC is in use), then only the active dynamic space gets
;;; dumped to core.
(defvar *dynamic*)
-(defconstant dynamic-space-id 1)
+(defconstant dynamic-core-space-id 1)
(defvar *static*)
-(defconstant static-space-id 2)
+(defconstant static-core-space-id 2)
(defvar *read-only*)
-(defconstant read-only-space-id 3)
+(defconstant read-only-core-space-id 3)
(defconstant descriptor-low-bits 16
"the number of bits in the low half of the descriptor")
"the alignment requirement for spaces in the target.
Must be at least (ASH 1 DESCRIPTOR-LOW-BITS)")
-;;; a GENESIS-time representation of a memory space (e.g. read-only space,
-;;; dynamic space, or static space)
+;;; a GENESIS-time representation of a memory space (e.g. read-only
+;;; space, dynamic space, or static space)
(defstruct (gspace (:constructor %make-gspace)
(:copier nil))
;; name and identifier for this GSPACE
(identifier (missing-arg) :type fixnum :read-only t)
;; the word address where the data will be loaded
(word-address (missing-arg) :type unsigned-byte :read-only t)
- ;; the data themselves. (Note that in CMU CL this was a pair
- ;; of fields SAP and WORDS-ALLOCATED, but that wasn't very portable.)
- (bytes (make-array target-space-alignment :element-type '(unsigned-byte 8))
- :type (simple-array (unsigned-byte 8) 1))
+ ;; the data themselves. (Note that in CMU CL this was a pair of
+ ;; fields SAP and WORDS-ALLOCATED, but that wasn't very portable.)
+ ;; (And then in SBCL this was a VECTOR, but turned out to be
+ ;; unportable too, since ANSI doesn't think that arrays longer than
+ ;; 1024 (!) should needed by portable CL code...)
+ (bytes (make-bigvec) :read-only t)
;; the index of the next unwritten word (i.e. chunk of
;; SB!VM:N-WORD-BYTES bytes) in BYTES, or equivalently the number of
;; words actually written in BYTES. In order to convert to an actual
(%make-gspace :name name
:identifier identifier
:word-address (ash byte-address (- sb!vm:word-shift))))
-
-;;; KLUDGE: Doing it this way seems to partly replicate the
-;;; functionality of Common Lisp adjustable arrays. Is there any way
-;;; to do this stuff in one line of code by using standard Common Lisp
-;;; stuff? -- WHN 19990816
-(defun expand-gspace-bytes (gspace)
- (let* ((old-bytes (gspace-bytes gspace))
- (old-length (length old-bytes))
- (new-length (* 2 old-length))
- (new-bytes (make-array new-length :element-type '(unsigned-byte 8))))
- (replace new-bytes old-bytes :end1 old-length)
- (setf (gspace-bytes gspace)
- new-bytes))
- (values))
\f
;;;; representation of descriptors
;; Grow GSPACE as necessary until it's big enough to handle
;; NEW-FREE-WORD-INDEX.
(do ()
- ((>= (length (gspace-bytes gspace))
+ ((>= (bvlength (gspace-bytes gspace))
(* new-free-word-index sb!vm:n-word-bytes)))
- (expand-gspace-bytes gspace))
+ (expand-bigvec (gspace-bytes gspace)))
;; Now that GSPACE is big enough, we can meaningfully grab a chunk of it.
(setf (gspace-free-word-index gspace) new-free-word-index)
(let ((ptr (+ (gspace-word-address gspace) old-free-word-index)))
"Push THING onto the given cold-load LIST."
`(setq ,list (cold-cons ,thing ,list)))
-;;; BYTE-VECTOR-REF-32 and friends. These are like SAP-REF-n, except
-;;; that instead of a SAP we use a byte vector
-(macrolet ((make-byte-vector-ref-n
- (n)
- (let* ((name (intern (format nil "BYTE-VECTOR-REF-~A" n)))
- (number-octets (/ n 8))
- (ash-list-le
- (loop for i from 0 to (1- number-octets)
- collect `(ash (aref byte-vector (+ byte-index ,i))
- ,(* i 8))))
- (ash-list-be
- (loop for i from 0 to (1- number-octets)
- collect `(ash (aref byte-vector (+ byte-index
- ,(- number-octets 1 i)))
- ,(* i 8))))
- (setf-list-le
- (loop for i from 0 to (1- number-octets)
- append
- `((aref byte-vector (+ byte-index ,i))
- (ldb (byte 8 ,(* i 8)) new-value))))
- (setf-list-be
- (loop for i from 0 to (1- number-octets)
- append
- `((aref byte-vector (+ byte-index ,i))
- (ldb (byte 8 ,(- n 8 (* i 8))) new-value)))))
- `(progn
- (defun ,name (byte-vector byte-index)
- (aver (= sb!vm:n-word-bits 32))
- (aver (= sb!vm:n-byte-bits 8))
- (logior ,@(ecase sb!c:*backend-byte-order*
- (:little-endian ash-list-le)
- (:big-endian ash-list-be))))
- (defun (setf ,name) (new-value byte-vector byte-index)
- (aver (= sb!vm:n-word-bits 32))
- (aver (= sb!vm:n-byte-bits 8))
- (setf ,@(ecase sb!c:*backend-byte-order*
- (:little-endian setf-list-le)
- (:big-endian setf-list-be))))))))
- (make-byte-vector-ref-n 8)
- (make-byte-vector-ref-n 16)
- (make-byte-vector-ref-n 32))
-
(declaim (ftype (function (descriptor sb!vm:word) descriptor) read-wordindexed))
(defun read-wordindexed (address index)
#!+sb-doc
(bytes (gspace-bytes gspace))
(byte-index (ash (+ index (descriptor-word-offset address))
sb!vm:word-shift))
- (value (byte-vector-ref-32 bytes byte-index)))
+ (value (bvref-32 bytes byte-index)))
(make-random-descriptor value)))
(declaim (ftype (function (descriptor) descriptor) read-memory))
(let* ((bytes (gspace-bytes (descriptor-intuit-gspace address)))
(byte-index (ash (+ index (descriptor-word-offset address))
sb!vm:word-shift)))
- (setf (byte-vector-ref-32 bytes byte-index)
+ (setf (bvref-32 bytes byte-index)
(descriptor-bits value)))))
(declaim (ftype (function (descriptor descriptor)) write-memory))
sb!vm:vector-length-slot
(make-fixnum-descriptor length))
(dotimes (i length)
- (setf (aref bytes (+ offset i))
+ (setf (bvref bytes (+ offset i))
;; KLUDGE: There's no guarantee that the character
;; encoding here will be the same as the character
;; encoding on the target machine, so using CHAR-CODE as
;; indices into the sequence which is used to test whether
;; a character is a STANDARD-CHAR?) -- WHN 19990817
(char-code (aref string i))))
- (setf (aref bytes (+ offset length))
+ (setf (bvref bytes (+ offset length))
0) ; null string-termination character for C
des))
(cold-fdefinition-object (cold-intern ',symbol)))))
(frob maybe-gc)
(frob internal-error)
+ (frob sb!kernel::control-stack-exhausted-error)
(frob sb!di::handle-breakpoint)
(frob sb!di::handle-fun-end-breakpoint))
(warm-symbol cadr-des))))
(#.sb!vm:other-pointer-lowtag
(warm-symbol des)))))
- (unless (legal-fun-name-p result)
- (error "not a legal function name: ~S" result))
+ (legal-fun-name-or-type-error result)
result))
(defun cold-fdefinition-object (cold-name &optional leave-fn-raw)
(defun note-load-time-code-fixup (code-object offset value kind)
;; If CODE-OBJECT might be moved
(when (= (gspace-identifier (descriptor-intuit-gspace code-object))
- dynamic-space-id)
+ dynamic-core-space-id)
;; FIXME: pushed thing should be a structure, not just a list
(push (list code-object offset value kind) *load-time-code-fixups*))
(values))
(let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))
(value (if (logbitp 31 value) (+ value (ash 1 32)) value))
(value (if (logbitp 47 value) (+ value (ash 1 48)) value)))
- (setf (byte-vector-ref-8 gspace-bytes gspace-byte-offset)
+ (setf (bvref-8 gspace-bytes gspace-byte-offset)
(ldb (byte 8 48) value)
- (byte-vector-ref-8 gspace-bytes (1+ gspace-byte-offset))
+ (bvref-8 gspace-bytes (1+ gspace-byte-offset))
(ldb (byte 8 56) value))))
(:bits-47-32
(let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))
(value (if (logbitp 31 value) (+ value (ash 1 32)) value)))
- (setf (byte-vector-ref-8 gspace-bytes gspace-byte-offset)
+ (setf (bvref-8 gspace-bytes gspace-byte-offset)
(ldb (byte 8 32) value)
- (byte-vector-ref-8 gspace-bytes (1+ gspace-byte-offset))
+ (bvref-8 gspace-bytes (1+ gspace-byte-offset))
(ldb (byte 8 40) value))))
(:ldah
(let ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)))
- (setf (byte-vector-ref-8 gspace-bytes gspace-byte-offset)
+ (setf (bvref-8 gspace-bytes gspace-byte-offset)
(ldb (byte 8 16) value)
- (byte-vector-ref-8 gspace-bytes (1+ gspace-byte-offset))
+ (bvref-8 gspace-bytes (1+ gspace-byte-offset))
(ldb (byte 8 24) value))))
(:lda
- (setf (byte-vector-ref-8 gspace-bytes gspace-byte-offset)
+ (setf (bvref-8 gspace-bytes gspace-byte-offset)
(ldb (byte 8 0) value)
- (byte-vector-ref-8 gspace-bytes (1+ gspace-byte-offset))
+ (bvref-8 gspace-bytes (1+ gspace-byte-offset))
(ldb (byte 8 8) value)))))
(:ppc
(ecase kind
(:ba
- (setf (byte-vector-ref-32 gspace-bytes gspace-byte-offset)
+ (setf (bvref-32 gspace-bytes gspace-byte-offset)
(dpb (ash value -2) (byte 24 2)
- (byte-vector-ref-32 gspace-bytes gspace-byte-offset))))
+ (bvref-32 gspace-bytes gspace-byte-offset))))
(:ha
(let* ((h (ldb (byte 16 16) value))
(l (ldb (byte 16 0) value)))
- (setf (byte-vector-ref-16 gspace-bytes (+ gspace-byte-offset 2))
+ (setf (bvref-16 gspace-bytes (+ gspace-byte-offset 2))
(if (logbitp 15 l) (ldb (byte 16 0) (1+ h)) h))))
(:l
- (setf (byte-vector-ref-16 gspace-bytes (+ gspace-byte-offset 2))
+ (setf (bvref-16 gspace-bytes (+ gspace-byte-offset 2))
(ldb (byte 16 0) value)))))
(:sparc
(ecase kind
(:call
- (error "Can't deal with call fixups yet."))
+ (error "can't deal with call fixups yet"))
(:sethi
- (setf (byte-vector-ref-32 gspace-bytes gspace-byte-offset)
+ (setf (bvref-32 gspace-bytes gspace-byte-offset)
(dpb (ldb (byte 22 10) value)
(byte 22 0)
- (byte-vector-ref-32 gspace-bytes gspace-byte-offset))))
+ (bvref-32 gspace-bytes gspace-byte-offset))))
(:add
- (setf (byte-vector-ref-32 gspace-bytes gspace-byte-offset)
+ (setf (bvref-32 gspace-bytes gspace-byte-offset)
(dpb (ldb (byte 10 0) value)
(byte 10 0)
- (byte-vector-ref-32 gspace-bytes gspace-byte-offset))))))
+ (bvref-32 gspace-bytes gspace-byte-offset))))))
(:x86
- (let* ((un-fixed-up (byte-vector-ref-32 gspace-bytes
+ (let* ((un-fixed-up (bvref-32 gspace-bytes
gspace-byte-offset))
(code-object-start-addr (logandc2 (descriptor-bits code-object)
sb!vm:lowtag-mask)))
(ecase kind
(:absolute
(let ((fixed-up (+ value un-fixed-up)))
- (setf (byte-vector-ref-32 gspace-bytes gspace-byte-offset)
+ (setf (bvref-32 gspace-bytes gspace-byte-offset)
fixed-up)
;; comment from CMU CL sources:
;;
gspace-byte-address
gspace-byte-offset
sb!vm:n-word-bytes))) ; length of CALL argument
- (setf (byte-vector-ref-32 gspace-bytes gspace-byte-offset)
+ (setf (bvref-32 gspace-bytes gspace-byte-offset)
fixed-up)
;; Note relative fixups that point outside the code
;; object, which is to say all relative fixups, since
(end (+ start
(ceiling (* len sizebits)
sb!vm:n-byte-bits))))
- (read-sequence-or-die (descriptor-bytes result)
- *fasl-input-stream*
- :start start
- :end end)
+ (read-bigvec-as-sequence-or-die (descriptor-bytes result)
+ *fasl-input-stream*
+ :start start
+ :end end)
result))
(define-cold-fop (fop-single-float-vector)
(start (+ (descriptor-byte-offset result)
(ash sb!vm:vector-data-offset sb!vm:word-shift)))
(end (+ start (* len sb!vm:n-word-bytes))))
- (read-sequence-or-die (descriptor-bytes result)
- *fasl-input-stream*
- :start start
- :end end)
+ (read-bigvec-as-sequence-or-die (descriptor-bytes result)
+ *fasl-input-stream*
+ :start start
+ :end end)
result))
(not-cold-fop fop-double-float-vector)
(let* ((start (+ (descriptor-byte-offset des)
(ash header-n-words sb!vm:word-shift)))
(end (+ start code-size)))
- (read-sequence-or-die (descriptor-bytes des)
- *fasl-input-stream*
- :start start
- :end end)
+ (read-bigvec-as-sequence-or-die (descriptor-bytes des)
+ *fasl-input-stream*
+ :start start
+ :end end)
#!+sb-show
(when *show-pre-fixup-code-p*
(format *trace-output*
(format *trace-output*
"/#X~8,'0x: #X~8,'0x~%"
(+ i (gspace-byte-address (descriptor-gspace des)))
- (byte-vector-ref-32 (descriptor-bytes des) i)))))
+ (bvref-32 (descriptor-bytes des) i)))))
des)))
(define-cold-code-fop fop-code (read-arg 4) (read-arg 4))
(let* ((start (+ (descriptor-byte-offset des)
(ash header-n-words sb!vm:word-shift)))
(end (+ start length)))
- (read-sequence-or-die (descriptor-bytes des)
- *fasl-input-stream*
- :start start
- :end end))
+ (read-bigvec-as-sequence-or-die (descriptor-bytes des)
+ *fasl-input-stream*
+ :start start
+ :end end))
des))
(define-cold-fop (fop-assembler-routine)
(sb!xc:lisp-implementation-version))
(format t "#define CORE_MAGIC 0x~X~%" core-magic)
(terpri)
- ;; FIXME: Other things from core.h should be defined here too:
- ;; #define CORE_END 3840
- ;; #define CORE_NDIRECTORY 3861
- ;; #define CORE_VALIDATE 3845
- ;; #define CORE_VERSION 3860
- ;; #define CORE_MACHINE_STATE 3862
- ;; (Except that some of them are obsolete and should be deleted instead.)
- ;; also
- ;; #define DYNAMIC_SPACE_ID (1)
- ;; #define STATIC_SPACE_ID (2)
- ;; #define READ_ONLY_SPACE_ID (3)
-
- ;; writing entire families of named constants from SB!VM
+
+ ;; writing entire families of named constants
(let ((constants nil))
- (do-external-symbols (symbol (find-package "SB!VM"))
- (when (constantp symbol)
- (let ((name (symbol-name symbol)))
- (labels (;; shared machinery
- (record (string priority)
- (push (list string
- priority
- (symbol-value symbol)
- (documentation symbol 'variable))
- constants))
- ;; machinery for old-style CMU CL Lisp-to-C
- ;; arbitrary renaming, being phased out in favor of
- ;; the newer systematic RECORD-WITH-TRANSLATED-NAME
- ;; renaming
- (record-with-munged-name (prefix string priority)
- (record (concatenate
- 'simple-string
- prefix
- (delete #\- (string-capitalize string)))
- priority))
- (maybe-record-with-munged-name (tail prefix priority)
- (when (tailwise-equal name tail)
- (record-with-munged-name prefix
- (subseq name 0
- (- (length name)
- (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)
- (when (some (lambda (suffix)
- (tailwise-equal name suffix))
- suffixes)
- (record-with-translated-name priority))))
-
- (maybe-record-with-translated-name '("-LOWTAG") 0)
- (maybe-record-with-translated-name '("-WIDETAG") 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") 6)))))
+ (dolist (package-name '(;; Even in CMU CL, constants from VM
+ ;; were automatically propagated
+ ;; into the runtime.
+ "SB!VM"
+ ;; In SBCL, we also propagate various
+ ;; magic numbers related to file format,
+ ;; which live here instead of SB!VM.
+ "SB!FASL"))
+ (do-external-symbols (symbol (find-package package-name))
+ (when (constantp symbol)
+ (let ((name (symbol-name symbol)))
+ (labels (;; shared machinery
+ (record (string priority)
+ (push (list string
+ priority
+ (symbol-value symbol)
+ (documentation symbol 'variable))
+ constants))
+ ;; machinery for old-style CMU CL Lisp-to-C
+ ;; arbitrary renaming, being phased out in favor of
+ ;; the newer systematic RECORD-WITH-TRANSLATED-NAME
+ ;; renaming
+ (record-with-munged-name (prefix string priority)
+ (record (concatenate
+ 'simple-string
+ prefix
+ (delete #\- (string-capitalize string)))
+ priority))
+ (maybe-record-with-munged-name (tail prefix priority)
+ (when (tailwise-equal name tail)
+ (record-with-munged-name prefix
+ (subseq name 0
+ (- (length name)
+ (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)
+ (when (some (lambda (suffix)
+ (tailwise-equal name suffix))
+ suffixes)
+ (record-with-translated-name priority))))
+
+ (maybe-record-with-translated-name '("-LOWTAG") 0)
+ (maybe-record-with-translated-name '("-WIDETAG") 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") 6)
+ (maybe-record-with-translated-name '("-CORE-ENTRY-TYPE-CODE") 7)
+ (maybe-record-with-translated-name '("-CORE-SPACE-ID") 8))))))
(setf constants
(sort constants
(lambda (const1 const2)
;; pseudo-atomic-trap-number or pseudo-atomic-magic-constant
;; [possibly applicable to other platforms])
+ (dolist (symbol '(sb!vm::float-traps-byte sb!vm::float-exceptions-byte sb!vm::float-sticky-bits sb!vm::float-rounding-mode))
+ (format t "#define ~A_POSITION ~A /* ~:*0x~X */~%"
+ (substitute #\_ #\- (symbol-name symbol))
+ (sb!xc:byte-position (symbol-value symbol)))
+ (format t "#define ~A_MASK 0x~X /* ~:*~A */~%"
+ (substitute #\_ #\- (symbol-name symbol))
+ (sb!xc:mask-field (symbol-value symbol) -1)))
+
;; writing primitive object layouts
(let ((structs (sort (copy-list sb!vm:*primitive-objects*) #'string<
:key (lambda (obj)
(defvar *core-file*)
(defvar *data-page*)
-;;; KLUDGE: These numbers correspond to values in core.h. If they're
-;;; documented anywhere, I haven't found it. (I haven't tried very
-;;; hard yet.) -- WHN 19990826
-(defparameter version-entry-type-code 3860)
-(defparameter validate-entry-type-code 3845)
-(defparameter directory-entry-type-code 3841)
-(defparameter new-directory-entry-type-code 3861)
-(defparameter initial-fun-entry-type-code 3863)
-(defparameter end-entry-type-code 3840)
+(defconstant version-core-entry-type-code 3860)
+(defconstant new-directory-core-entry-type-code 3861)
+(defconstant initial-fun-core-entry-type-code 3863)
+(defconstant end-core-entry-type-code 3840)
(declaim (ftype (function (sb!vm:word) sb!vm:word) write-word))
(defun write-word (num)
;; be zero-filled. This will always be true under Mach on machines
;; where the page size is equal. (RT is 4K, PMAX is 4K, Sun 3 is
;; 8K).
- (write-sequence (gspace-bytes gspace) *core-file* :end total-bytes)
+ (write-bigvec-as-sequence (gspace-bytes gspace)
+ *core-file*
+ :end total-bytes)
(force-output *core-file*)
(file-position *core-file* posn)
(write-word core-magic)
;; Write the Version entry.
- (write-word version-entry-type-code)
+ (write-word version-core-entry-type-code)
(write-word 3)
(write-word sbcl-core-version-integer)
;; Write the New Directory entry header.
- (write-word new-directory-entry-type-code)
+ (write-word new-directory-core-entry-type-code)
(write-word 17) ; length = (5 words/space) * 3 spaces + 2 for header.
(output-gspace *read-only*)
(output-gspace *dynamic*)
;; Write the initial function.
- (write-word initial-fun-entry-type-code)
+ (write-word initial-fun-core-entry-type-code)
(write-word 3)
(let* ((cold-name (cold-intern '!cold-init))
(cold-fdefn (cold-fdefinition-object cold-name))
(write-word (descriptor-bits initial-fun)))
;; Write the End entry.
- (write-word end-entry-type-code)
+ (write-word end-core-entry-type-code)
(write-word 2)))
(format t "done]~%")
(*cold-symbols* (make-hash-table :test 'equal))
(*cold-package-symbols* nil)
(*read-only* (make-gspace :read-only
- read-only-space-id
+ read-only-core-space-id
sb!vm:read-only-space-start))
(*static* (make-gspace :static
- static-space-id
+ static-core-space-id
sb!vm:static-space-start))
(*dynamic* (make-gspace :dynamic
- dynamic-space-id
+ dynamic-core-space-id
#!+gencgc sb!vm:dynamic-space-start
#!-gencgc sb!vm:dynamic-0-space-start))
(*nil-descriptor* (make-nil-descriptor))