+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)))
+(defun write-bigvec-as-sequence (bigvec stream &key (start 0) end pad-with-zeros)
+ (let* ((bvlength (bvlength bigvec))
+ (data-length (min (or end bvlength) bvlength)))
+ (loop for i of-type index from start below data-length do
+ (write-byte (bvref bigvec i)
+ stream))
+ (when (and pad-with-zeros (< bvlength data-length))
+ (loop repeat (- data-length bvlength) do (write-byte 0 stream)))))
;;; analogous to READ-SEQUENCE-OR-DIE, but for a BIGVEC
(defun read-bigvec-as-sequence-or-die (bigvec stream &key (start 0) end)
(defvar *read-only*)
(defconstant read-only-core-space-id 3)
+(defconstant max-core-space-id 3)
+(defconstant deflated-core-space-id-flag 4)
+
(defconstant descriptor-low-bits 16
"the number of bits in the low half of the descriptor")
(defconstant target-space-alignment (ash 1 descriptor-low-bits)
\f
;;;; representation of descriptors
+(defun is-fixnum-lowtag (lowtag)
+ (zerop (logand lowtag sb!vm:fixnum-tag-mask)))
+
+(defun is-other-immediate-lowtag (lowtag)
+ ;; The other-immediate lowtags are similar to the fixnum lowtags, in
+ ;; that they have an "effective length" that is shorter than is used
+ ;; for the pointer lowtags. Unlike the fixnum lowtags, however, the
+ ;; other-immediate lowtags are always effectively two bits wide.
+ (= (logand lowtag 3) sb!vm:other-immediate-0-lowtag))
+
(defstruct (descriptor
(:constructor make-descriptor
(high low &optional gspace word-offset))
(def!method print-object ((des descriptor) stream)
(let ((lowtag (descriptor-lowtag des)))
(print-unreadable-object (des stream :type t)
- (cond ((or (= lowtag sb!vm:even-fixnum-lowtag)
- (= lowtag sb!vm:odd-fixnum-lowtag))
+ (cond ((is-fixnum-lowtag lowtag)
(let ((unsigned (logior (ash (descriptor-high des)
(1+ (- descriptor-low-bits
sb!vm:n-lowtag-bits)))
(if (> unsigned #x1FFFFFFF)
(- unsigned #x40000000)
unsigned))))
- ((or (= lowtag sb!vm:other-immediate-0-lowtag)
- (= lowtag sb!vm:other-immediate-1-lowtag)
- #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
- (= lowtag sb!vm:other-immediate-2-lowtag)
- #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
- (= lowtag sb!vm:other-immediate-3-lowtag))
+ ((is-other-immediate-lowtag lowtag)
(format stream
"for other immediate: #X~X, type #b~8,'0B"
(ash (descriptor-bits des) (- sb!vm:n-widetag-bits))
;; it's hard to see how it could have been wrong, since CMU CL
;; genesis worked. It would be nice to understand how this came
;; to be.. -- WHN 19990901
- (logior (ash bits (- 1 sb!vm:n-lowtag-bits))
+ (logior (ash bits (- sb!vm:n-fixnum-tag-bits))
(ash -1 (1+ sb!vm:n-positive-fixnum-bits)))
- (ash bits (- 1 sb!vm:n-lowtag-bits)))))
+ (ash bits (- sb!vm:n-fixnum-tag-bits)))))
(defun descriptor-word-sized-integer (des)
;; Extract an (unsigned-byte 32), from either its fixnum or bignum
;; representation.
(let ((lowtag (descriptor-lowtag des)))
- (if (or (= lowtag sb!vm:even-fixnum-lowtag)
- (= lowtag sb!vm:odd-fixnum-lowtag))
+ (if (is-fixnum-lowtag lowtag)
(make-random-descriptor (descriptor-fixnum des))
(read-wordindexed des 1))))
(defun make-fixnum-descriptor (num)
(when (>= (integer-length num)
- (1+ (- sb!vm:n-word-bits sb!vm:n-lowtag-bits)))
+ (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits))
(error "~W is too big for a fixnum." num))
- (make-random-descriptor (ash num (1- sb!vm:n-lowtag-bits))))
+ (make-random-descriptor (ash num sb!vm:n-fixnum-tag-bits)))
(defun make-other-immediate-descriptor (data type)
(make-descriptor (ash data (- sb!vm:n-widetag-bits descriptor-low-bits))
;;; the cold core starts up
(defvar *current-debug-sources*)
+;;; foreign symbol references
+(defparameter *cold-foreign-undefined-symbols* nil)
+
;;; the name of the object file currently being cold loaded (as a string, not a
;;; pathname), or NIL if we're not currently cold loading any object file
(defvar *cold-load-filename* nil)
*current-reversed-cold-toplevels*)
(values))
-(declaim (ftype (function (descriptor sb!vm:word (or descriptor symbol))) write-wordindexed))
+(declaim (ftype (function (descriptor sb!vm:word (or symbol descriptor))) write-wordindexed))
(defun write-wordindexed (address index value)
#!+sb-doc
"Write VALUE displaced INDEX words from ADDRESS."
(setf (bvref-word bytes byte-index)
(descriptor-bits value)))))
-(declaim (ftype (function (descriptor (or descriptor symbol))) write-memory))
+(declaim (ftype (function (descriptor (or symbol descriptor))) write-memory))
(defun write-memory (address value)
#!+sb-doc
"Write VALUE (a DESCRIPTOR) at ADDRESS (also a DESCRIPTOR)."
(defun number-to-core (number)
(typecase number
(integer (if (< (integer-length number)
- (- (1+ sb!vm:n-word-bits) sb!vm:n-lowtag-bits))
+ (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits))
(make-fixnum-descriptor number)
(bignum-to-core number)))
(ratio (number-pair-to-core (number-to-core (numerator number))
;;; descriptor of a cold symbol or (in an abbreviation for the
;;; most common usage pattern) an ordinary symbol, which will be
;;; automatically cold-interned.
-(declaim (ftype (function ((or descriptor symbol) descriptor)) cold-set))
+(declaim (ftype (function ((or symbol descriptor) descriptor)) cold-set))
(defun cold-set (symbol-or-symbol-des value)
(let ((symbol-des (etypecase symbol-or-symbol-des
(descriptor symbol-or-symbol-des)
;;; Given a cold representation of a function name, return a warm
;;; representation.
-(declaim (ftype (function ((or descriptor symbol)) (or symbol list)) warm-fun-name))
+(declaim (ftype (function ((or symbol descriptor)) (or symbol list)) warm-fun-name))
(defun warm-fun-name (des)
(let ((result
(if (symbolp des)
result))
(defun cold-fdefinition-object (cold-name &optional leave-fn-raw)
- (declare (type (or descriptor symbol) cold-name))
+ (declare (type (or symbol descriptor) cold-name))
(/show0 "/cold-fdefinition-object")
(let ((warm-name (warm-fun-name cold-name)))
(or (gethash warm-name *cold-fdefn-objects*)
;;; Handle the at-cold-init-time, fset-for-static-linkage operation
;;; requested by FOP-FSET.
(defun static-fset (cold-name defn)
- (declare (type (or descriptor symbol) cold-name))
+ (declare (type (or symbol descriptor) cold-name))
(let ((fdefn (cold-fdefinition-object cold-name t))
(type (logand (descriptor-low (read-memory defn)) sb!vm:widetag-mask)))
(write-wordindexed fdefn sb!vm:fdefn-fun-slot defn)
(warn "redefining ~S from #X~X to #X~X"
name old-value value)))
(/show "adding to *cold-foreign-symbol-table*:" name value)
- (setf (gethash name *cold-foreign-symbol-table*) value))))))
+ (setf (gethash name *cold-foreign-symbol-table*) value)
+ #!+win32
+ (let ((at-position (position #\@ name)))
+ (when at-position
+ (let ((name (subseq name 0 at-position)))
+ (multiple-value-bind (old-value found)
+ (gethash name *cold-foreign-symbol-table*)
+ (when (and found
+ (not (= old-value value)))
+ (warn "redefining ~S from #X~X to #X~X"
+ name old-value value)))
+ (setf (gethash name *cold-foreign-symbol-table*)
+ value)))))))))
(values)) ;; PROGN
(defun cold-foreign-symbol-address (name)
(when value
(do-cold-fixup (second fixup) (third fixup) value (fourth fixup))))))
+#!+sb-dynamic-core
+(progn
+ (defparameter *dyncore-address* sb!vm::linkage-table-space-start)
+ (defparameter *dyncore-linkage-keys* nil)
+ (defparameter *dyncore-table* (make-hash-table :test 'equal))
+
+ (defun dyncore-note-symbol (symbol-name datap)
+ "Register a symbol and return its address in proto-linkage-table."
+ (let ((key (cons symbol-name datap)))
+ (symbol-macrolet ((entry (gethash key *dyncore-table*)))
+ (or entry
+ (setf entry
+ (prog1 *dyncore-address*
+ (push key *dyncore-linkage-keys*)
+ (incf *dyncore-address* sb!vm::linkage-table-entry-size))))))))
+
;;; *COLD-FOREIGN-SYMBOL-TABLE* becomes *!INITIAL-FOREIGN-SYMBOLS* in
;;; the core. When the core is loaded, !LOADER-COLD-INIT uses this to
;;; create *STATIC-FOREIGN-SYMBOLS*, which the code in
(defun foreign-symbols-to-core ()
(let ((symbols nil)
(result *nil-descriptor*))
- (maphash (lambda (symbol value)
- (push (cons symbol value) symbols))
- *cold-foreign-symbol-table*)
- (setq symbols (sort symbols #'string< :key #'car))
- (dolist (symbol symbols)
- (cold-push (cold-cons (base-string-to-core (car symbol))
- (number-to-core (cdr symbol)))
- result))
- (cold-set (cold-intern 'sb!kernel:*!initial-foreign-symbols*) result))
+ #!-sb-dynamic-core
+ (progn
+ (maphash (lambda (symbol value)
+ (push (cons symbol value) symbols))
+ *cold-foreign-symbol-table*)
+ (setq symbols (sort symbols #'string< :key #'car))
+ (dolist (symbol symbols)
+ (cold-push (cold-cons (base-string-to-core (car symbol))
+ (number-to-core (cdr symbol)))
+ result)))
+ (cold-set (cold-intern 'sb!kernel:*!initial-foreign-symbols*) result)
+ #!+sb-dynamic-core
+ (let ((runtime-linking-list *nil-descriptor*))
+ (dolist (symbol *dyncore-linkage-keys*)
+ (cold-push (cold-cons (base-string-to-core (car symbol))
+ (cdr symbol))
+ runtime-linking-list))
+ (cold-set (cold-intern 'sb!vm::*required-runtime-c-symbols*)
+ runtime-linking-list)))
(let ((result *nil-descriptor*))
(dolist (rtn (sort (copy-list *cold-assembler-routines*) #'string< :key #'car))
(cold-push (cold-cons (cold-intern (car rtn))
(let ((index (read-arg ,package-len)))
(push-fop-table
(cold-load-symbol (read-arg ,pname-len)
- (svref *current-fop-table* index)))))))
+ (ref-fop-table index)))))))
(frob fop-symbol-in-package-save #.sb!vm:n-word-bytes #.sb!vm:n-word-bytes)
(frob fop-small-symbol-in-package-save 1 #.sb!vm:n-word-bytes)
(frob fop-symbol-in-byte-package-save #.sb!vm:n-word-bytes 1)
(pop-stack)))
result))
-(define-cold-fop (fop-int-vector)
+(define-cold-fop (fop-spec-vector)
(let* ((len (read-word-arg))
- (sizebits (read-byte-arg))
- (type (case sizebits
- (0 sb!vm:simple-array-nil-widetag)
- (1 sb!vm:simple-bit-vector-widetag)
- (2 sb!vm:simple-array-unsigned-byte-2-widetag)
- (4 sb!vm:simple-array-unsigned-byte-4-widetag)
- (7 (prog1 sb!vm:simple-array-unsigned-byte-7-widetag
- (setf sizebits 8)))
- (8 sb!vm:simple-array-unsigned-byte-8-widetag)
- (15 (prog1 sb!vm:simple-array-unsigned-byte-15-widetag
- (setf sizebits 16)))
- (16 sb!vm:simple-array-unsigned-byte-16-widetag)
- (31 (prog1 sb!vm:simple-array-unsigned-byte-31-widetag
- (setf sizebits 32)))
- (32 sb!vm:simple-array-unsigned-byte-32-widetag)
- #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
- (63 (prog1 sb!vm:simple-array-unsigned-byte-63-widetag
- (setf sizebits 64)))
- #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
- (64 sb!vm:simple-array-unsigned-byte-64-widetag)
- (t (error "losing element size: ~W" sizebits))))
- (result (allocate-vector-object *dynamic* sizebits len type))
+ (type (read-byte-arg))
+ (sizebits (aref **saetp-bits-per-length** type))
+ (result (progn (aver (< sizebits 255))
+ (allocate-vector-object *dynamic* sizebits len type)))
(start (+ (descriptor-byte-offset result)
(ash sb!vm:vector-data-offset sb!vm:word-shift)))
(end (+ start
:end end)
result))
-(define-cold-fop (fop-single-float-vector)
- (let* ((len (read-word-arg))
- (result (allocate-vector-object
- *dynamic*
- sb!vm:n-word-bits
- len
- sb!vm:simple-array-single-float-widetag))
- (start (+ (descriptor-byte-offset result)
- (ash sb!vm:vector-data-offset sb!vm:word-shift)))
- (end (+ start (* len 4))))
- (read-bigvec-as-sequence-or-die (descriptor-bytes result)
- *fasl-input-stream*
- :start start
- :end end)
- result))
-
-(not-cold-fop fop-double-float-vector)
-#!+long-float (not-cold-fop fop-long-float-vector)
-(not-cold-fop fop-complex-single-float-vector)
-(not-cold-fop fop-complex-double-float-vector)
-#!+long-float (not-cold-fop fop-complex-long-float-vector)
-
(define-cold-fop (fop-array)
(let* ((rank (read-word-arg))
(data-vector (pop-stack))
(let ((total-elements 1))
(dotimes (axis rank)
(let ((dim (pop-stack)))
- (unless (or (= (descriptor-lowtag dim) sb!vm:even-fixnum-lowtag)
- (= (descriptor-lowtag dim) sb!vm:odd-fixnum-lowtag))
+ (unless (is-fixnum-lowtag (descriptor-lowtag dim))
(error "non-fixnum dimension? (~S)" dim))
(setf total-elements
(* total-elements
(logior (ash (descriptor-high dim)
(- descriptor-low-bits
- (1- sb!vm:n-lowtag-bits)))
+ sb!vm:n-fixnum-tag-bits))
(ash (descriptor-low dim)
- (- 1 sb!vm:n-lowtag-bits)))))
+ sb!vm:n-fixnum-tag-bits))))
(write-wordindexed result
(+ sb!vm:array-dimensions-offset axis)
dim)))
;;;; cold fops for fixing up circularities
(define-cold-fop (fop-rplaca :pushp nil)
- (let ((obj (svref *current-fop-table* (read-word-arg)))
+ (let ((obj (ref-fop-table (read-word-arg)))
(idx (read-word-arg)))
(write-memory (cold-nthcdr idx obj) (pop-stack))))
(define-cold-fop (fop-rplacd :pushp nil)
- (let ((obj (svref *current-fop-table* (read-word-arg)))
+ (let ((obj (ref-fop-table (read-word-arg)))
(idx (read-word-arg)))
(write-wordindexed (cold-nthcdr idx obj) 1 (pop-stack))))
(define-cold-fop (fop-svset :pushp nil)
- (let ((obj (svref *current-fop-table* (read-word-arg)))
+ (let ((obj (ref-fop-table (read-word-arg)))
(idx (read-word-arg)))
(write-wordindexed obj
(+ idx
(pop-stack))))
(define-cold-fop (fop-structset :pushp nil)
- (let ((obj (svref *current-fop-table* (read-word-arg)))
+ (let ((obj (ref-fop-table (read-word-arg)))
(idx (read-word-arg)))
(write-wordindexed obj (1+ idx) (pop-stack))))
(len (read-byte-arg))
(sym (make-string len)))
(read-string-as-bytes *fasl-input-stream* sym)
+ #!+sb-dynamic-core
+ (let ((offset (read-word-arg))
+ (value (dyncore-note-symbol sym nil)))
+ (do-cold-fixup code-object offset value kind))
+ #!- (and) (format t "Bad non-plt fixup: ~S~S~%" sym code-object)
+ #!-sb-dynamic-core
(let ((offset (read-word-arg))
(value (cold-foreign-symbol-address sym)))
(do-cold-fixup code-object offset value kind))
(code-object (pop-stack))
(len (read-byte-arg))
(sym (make-string len)))
+ #!-sb-dynamic-core (declare (ignore code-object))
(read-string-as-bytes *fasl-input-stream* sym)
- (maphash (lambda (k v)
- (format *error-output* "~&~S = #X~8X~%" k v))
- *cold-foreign-symbol-table*)
- (error "shared foreign symbol in cold load: ~S (~S)" sym kind)))
+ #!+sb-dynamic-core
+ (let ((offset (read-word-arg))
+ (value (dyncore-note-symbol sym t)))
+ (do-cold-fixup code-object offset value kind)
+ code-object)
+ #!-sb-dynamic-core
+ (progn
+ (maphash (lambda (k v)
+ (format *error-output* "~&~S = #X~8X~%" k v))
+ *cold-foreign-symbol-table*)
+ (error "shared foreign symbol in cold load: ~S (~S)" sym kind))))
(define-cold-fop (fop-assembler-code)
(let* ((length (read-word-arg))
priority)))
;; machinery for new-style SBCL Lisp-to-C naming
(record-with-translated-name (priority large)
- (record (c-name name) priority (if large "LU" "")))
+ (record (c-name name) priority
+ (if large
+ #!+(and win32 x86-64) "LLU"
+ #!-(and win32 x86-64) "LU"
+ "")))
(maybe-record-with-translated-name (suffixes priority &key large)
(when (some (lambda (suffix)
(tailwise-equal name suffix))
(maybe-record-with-munged-name "-SUBTYPE" "subtype_" 4)
(maybe-record-with-munged-name "-SC-NUMBER" "sc_" 5)
(maybe-record-with-translated-name '("-SIZE") 6)
- (maybe-record-with-translated-name '("-START" "-END" "-PAGE-BYTES") 7 :large t)
+ (maybe-record-with-translated-name '("-START" "-END" "-PAGE-BYTES"
+ "-CARD-BYTES" "-GRANULARITY")
+ 7 :large t)
(maybe-record-with-translated-name '("-CORE-ENTRY-TYPE-CODE") 8)
(maybe-record-with-translated-name '("-CORE-SPACE-ID") 9)
+ (maybe-record-with-translated-name '("-CORE-SPACE-ID-FLAG") 9)
(maybe-record-with-translated-name '("-GENERATION+") 10))))))
;; KLUDGE: these constants are sort of important, but there's no
;; pleasing way to inform the code above about them. So we fake
(push (list (c-symbol-name c)
9
(symbol-value c)
- "LU"
+ #!+(and win32 x86-64) "LLU"
+ #!-(and win32 x86-64) "LU"
nil)
constants))
(setf constants
;; pseudo-atomic-trap-number or pseudo-atomic-magic-constant
;; [possibly applicable to other platforms])
+ #!+sb-safepoint
+ (format t "#define GC_SAFEPOINT_PAGE_ADDR ((void*)0x~XUL) /* ~:*~A */~%"
+ sb!vm:gc-safepoint-page-addr)
+
(dolist (symbol '(sb!vm::float-traps-byte
sb!vm::float-exceptions-byte
sb!vm::float-sticky-bits
(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)))
+ (lowtag (or (symbol-value (sb!vm:primitive-object-lowtag obj))
+ 0)))
+ (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%"))
(defun write-structure-object (dd)
(setf undefs (sort undefs #'string< :key #'fun-name-block-name))
(dolist (name undefs)
- (format t "~S~%" name)))
+ (format t "~8,'0X: ~S~%"
+ (descriptor-bits (gethash name *cold-fdefn-objects*))
+ name)))
(format t "~%~|~%layout names:~2%")
(collect ((stuff))
(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))
;; 8K).
(write-bigvec-as-sequence (gspace-bytes gspace)
*core-file*
- :end total-bytes)
+ :end total-bytes
+ :pad-with-zeros t)
(force-output *core-file*)
(file-position *core-file* posn)
symbol-table-file-name
core-file-name
map-file-name
- c-header-dir-name)
+ c-header-dir-name
+ #+nil (list-objects t))
+ #!+sb-dynamic-core
+ (declare (ignorable symbol-table-file-name))
(format t
"~&beginning GENESIS, ~A~%"
(let ((*cold-foreign-symbol-table* (make-hash-table :test 'equal)))
+ #!-sb-dynamic-core
(when core-file-name
(if symbol-table-file-name
(load-cold-foreign-symbol-table symbol-table-file-name)
(error "can't output a core file without symbol table file input")))
+ #!+sb-dynamic-core
+ (progn
+ (setf (gethash (extern-alien-name "undefined_tramp")
+ *cold-foreign-symbol-table*)
+ (dyncore-note-symbol "undefined_tramp" nil))
+ (dyncore-note-symbol "undefined_alien_function" nil))
+
;; Now that we've successfully read our only input file (by
;; loading the symbol table, if any), it's a good time to ensure
;; that there'll be someplace for our output files to go when
projects / sbcl.git / blobdiff