`(simple-array (unsigned-byte 8) (,+smallvec-length+)))
(defun make-smallvec ()
- (make-array +smallvec-length+ :element-type '(unsigned-byte 8)))
+ (make-array +smallvec-length+ :element-type '(unsigned-byte 8)
+ :initial-element 0))
;;; a big vector, implemented as a vector of SMALLVECs
;;;
(high low &optional gspace word-offset))
(:copier nil))
;; the GSPACE that this descriptor is allocated in, or NIL if not set yet.
- (gspace nil :type (or gspace null))
+ (gspace nil :type (or gspace (eql :load-time-value) null))
;; the offset in words from the start of GSPACE, or NIL if not set yet
(word-offset nil :type (or sb!vm:word null))
;; the high and low halves of the descriptor
;;; (DESCRIPTOR-WORD-OFFSET DES), and return the GSPACE.
(declaim (ftype (function (descriptor) gspace) descriptor-intuit-gspace))
(defun descriptor-intuit-gspace (des)
- (if (descriptor-gspace des)
- (descriptor-gspace des)
- ;; KLUDGE: It's not completely clear to me what's going on here;
- ;; this is a literal translation from of some rather mysterious
- ;; code from CMU CL's DESCRIPTOR-SAP function. Some explanation
- ;; would be nice. -- WHN 19990817
- (let ((lowtag (descriptor-lowtag des))
- (high (descriptor-high des))
- (low (descriptor-low des)))
- (if (or (eql lowtag sb!vm:fun-pointer-lowtag)
- (eql lowtag sb!vm:instance-pointer-lowtag)
- (eql lowtag sb!vm:list-pointer-lowtag)
- (eql lowtag sb!vm:other-pointer-lowtag))
+ (or (descriptor-gspace des)
+
+ ;; gspace wasn't set, now we have to search for it.
+ (let ((lowtag (descriptor-lowtag des))
+ (high (descriptor-high des))
+ (low (descriptor-low des)))
+
+ ;; Non-pointer objects don't have a gspace.
+ (unless (or (eql lowtag sb!vm:fun-pointer-lowtag)
+ (eql lowtag sb!vm:instance-pointer-lowtag)
+ (eql lowtag sb!vm:list-pointer-lowtag)
+ (eql lowtag sb!vm:other-pointer-lowtag))
+ (error "don't even know how to look for a GSPACE for ~S" des))
+
(dolist (gspace (list *dynamic* *static* *read-only*)
- (error "couldn't find a GSPACE for ~S" des))
+ (error "couldn't find a GSPACE for ~S" des))
+ ;; Bounds-check the descriptor against the allocated area
+ ;; within each gspace.
+ ;;
+ ;; Most of the faffing around in here involving ash and
+ ;; various computed shift counts is due to the high/low
+ ;; split representation of the descriptor bits and an
+ ;; apparent disinclination to create intermediate values
+ ;; larger than a target fixnum.
+ ;;
;; This code relies on the fact that GSPACEs are aligned
;; such that the descriptor-low-bits low bits are zero.
(when (and (>= high (ash (gspace-word-address gspace)
(<= high (ash (+ (gspace-word-address gspace)
(gspace-free-word-index gspace))
(- sb!vm:word-shift descriptor-low-bits))))
+ ;; Update the descriptor with the correct gspace and the
+ ;; offset within the gspace and return the gspace.
(setf (descriptor-gspace des) gspace)
(setf (descriptor-word-offset des)
(+ (ash (- high (ash (gspace-word-address gspace)
(- descriptor-low-bits sb!vm:word-shift))
(ash (logandc2 low sb!vm:lowtag-mask)
(- sb!vm:word-shift))))
- (return gspace)))
- (error "don't even know how to look for a GSPACE for ~S" des)))))
+ (return gspace))))))
(defun make-random-descriptor (value)
(make-descriptor (logand (ash value (- descriptor-low-bits))
;;; purposes.
(defvar *current-reversed-cold-toplevels*)
+;;; the head of a list of DEBUG-SOURCEs which need to be patched when
+;;; the cold core starts up
+(defvar *current-debug-sources*)
+
;;; 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)
(read-wordindexed address 0))
;;; (Note: In CMU CL, this function expected a SAP-typed ADDRESS
-;;; value, instead of the SAP-INT we use here.)
+;;; value, instead of the object-and-offset we use here.)
(declaim (ftype (function (descriptor sb!vm:word descriptor) (values))
note-load-time-value-reference))
(defun note-load-time-value-reference (address offset marker)
*current-reversed-cold-toplevels*)
(values))
-(declaim (ftype (function (descriptor sb!vm:word descriptor)) write-wordindexed))
+(declaim (ftype (function (descriptor sb!vm:word (or descriptor symbol))) write-wordindexed))
(defun write-wordindexed (address index value)
#!+sb-doc
"Write VALUE displaced INDEX words from ADDRESS."
- ;; KLUDGE: There is an algorithm (used in DESCRIPTOR-INTUIT-GSPACE)
- ;; for calculating the value of the GSPACE slot from scratch. It
- ;; doesn't work for all values, only some of them, but mightn't it
- ;; be reasonable to see whether it works on VALUE before we give up
- ;; because (DESCRIPTOR-GSPACE VALUE) isn't set? (Or failing that,
- ;; perhaps write a comment somewhere explaining why it's not a good
- ;; idea?) -- WHN 19990817
- (if (and (null (descriptor-gspace value))
- (not (null (descriptor-word-offset value))))
+ ;; If we're passed a symbol as a value then it needs to be interned.
+ (when (symbolp value) (setf value (cold-intern value)))
+ (if (eql (descriptor-gspace value) :load-time-value)
(note-load-time-value-reference address
(- (ash index sb!vm:word-shift)
(logand (descriptor-bits address)
(setf (bvref-word bytes byte-index)
(descriptor-bits value)))))
-(declaim (ftype (function (descriptor descriptor)) write-memory))
+(declaim (ftype (function (descriptor (or descriptor symbol))) write-memory))
(defun write-memory (address value)
#!+sb-doc
"Write VALUE (a DESCRIPTOR) at ADDRESS (also a DESCRIPTOR)."
(let ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits
(1- sb!vm:complex-single-float-size)
sb!vm:complex-single-float-widetag)))
- (write-wordindexed des sb!vm:complex-single-float-real-slot
- (make-random-descriptor (single-float-bits (realpart num))))
- (write-wordindexed des sb!vm:complex-single-float-imag-slot
- (make-random-descriptor (single-float-bits (imagpart num))))
+ #!-x86-64
+ (progn
+ (write-wordindexed des sb!vm:complex-single-float-real-slot
+ (make-random-descriptor (single-float-bits (realpart num))))
+ (write-wordindexed des sb!vm:complex-single-float-imag-slot
+ (make-random-descriptor (single-float-bits (imagpart num)))))
+ #!+x86-64
+ (write-wordindexed des sb!vm:complex-single-float-data-slot
+ (make-random-descriptor
+ (logior (ldb (byte 32 0) (single-float-bits (realpart num)))
+ (ash (single-float-bits (imagpart num)) 32))))
des))
(defun complex-double-float-to-core (num)
\f
;;;; symbol magic
-;;; FIXME: This should be a &KEY argument of ALLOCATE-SYMBOL.
-(defvar *cold-symbol-allocation-gspace* nil)
-
;;; Allocate (and initialize) a symbol.
-(defun allocate-symbol (name)
+(defun allocate-symbol (name &key (gspace *dynamic*))
(declare (simple-string name))
- (let ((symbol (allocate-unboxed-object (or *cold-symbol-allocation-gspace*
- *dynamic*)
+ (let ((symbol (allocate-unboxed-object gspace
sb!vm:n-word-bits
(1- sb!vm:symbol-size)
sb!vm:symbol-header-widetag)))
;; Set slot 0 = the layout of the layout.
(write-wordindexed result sb!vm:instance-slots-offset *layout-layout*)
- ;; Set the CLOS hash value.
+ ;; Don't set the CLOS hash value: done in cold-init instead.
;;
- ;; 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
- ;; kludgy-looking code, but there were at least two things to be
- ;; said for it:
- ;; 1. It put the hash values under the control of the target Lisp's
- ;; RANDOM function, so that CLOS behavior would be nearly
- ;; deterministic (instead of depending on the implementation of
- ;; RANDOM in the cross-compilation host, and the state of its
- ;; RNG when genesis begins).
- ;; 2. It automatically ensured that all hash values in the target Lisp
- ;; were part of the same sequence, so that we didn't have to worry
- ;; about the possibility of the first hash value set in genesis
- ;; being precisely equal to the some hash value set in cold init time
- ;; (because the target Lisp RNG has advanced to precisely the same
- ;; state that the host Lisp RNG was in earlier).
- ;; Point 1 should not be an issue in practice because of the way we do our
- ;; build procedure in two steps, so that the SBCL that we end up with has
- ;; been created by another SBCL (whose RNG is under our control).
- ;; Point 2 is more of an issue. If ANSI had provided a way to feed
- ;; entropy into an RNG, we would have no problem: we'd just feed
- ;; some specialized genesis-time-only pattern into the RNG state
- ;; 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.
- (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.
;;
;; leave CLASSOID uninitialized for now
(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 'source-location *nil-descriptor*)
(cold-set-layout-slot result 'for-std-class-p *nil-descriptor*)
(setf (gethash name *cold-layouts*)
;;; we allocate the symbol, make sure we record a reference to the
;;; symbol in the home package so that the package gets set.
(defun cold-intern (symbol
- &optional
- (package (symbol-package-for-target-symbol symbol)))
+ &key
+ (package (symbol-package-for-target-symbol symbol))
+ (gspace *dynamic*))
(aver (package-ok-for-target-symbol-p package))
(cold-intern-info (get symbol 'cold-intern-info)))
(unless cold-intern-info
(cond ((eq (symbol-package-for-target-symbol symbol) package)
- (let ((handle (allocate-symbol (symbol-name symbol))))
+ (let ((handle (allocate-symbol (symbol-name symbol) :gspace gspace)))
(setf (gethash (descriptor-bits handle) *cold-symbols*) symbol)
(when (eq package *keyword-package*)
(cold-set handle handle))
(defun initialize-non-nil-symbols ()
#!+sb-doc
"Initialize the cold load symbol-hacking data structures."
- (let ((*cold-symbol-allocation-gspace* *static*))
- ;; Intern the others.
- (dolist (symbol sb!vm:*static-symbols*)
- (let* ((des (cold-intern symbol))
- (offset-wanted (sb!vm:static-symbol-offset symbol))
- (offset-found (- (descriptor-low des)
- (descriptor-low *nil-descriptor*))))
- (unless (= offset-wanted offset-found)
- ;; FIXME: should be fatal
- (warn "Offset from ~S to ~S is ~W, not ~W"
- symbol
- nil
- offset-found
- offset-wanted))))
- ;; Establish the value of T.
- (let ((t-symbol (cold-intern t)))
- (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)))))
+ ;; Intern the others.
+ (dolist (symbol sb!vm:*static-symbols*)
+ (let* ((des (cold-intern symbol :gspace *static*))
+ (offset-wanted (sb!vm:static-symbol-offset symbol))
+ (offset-found (- (descriptor-low des)
+ (descriptor-low *nil-descriptor*))))
+ (unless (= offset-wanted offset-found)
+ ;; FIXME: should be fatal
+ (warn "Offset from ~S to ~S is ~W, not ~W"
+ symbol
+ nil
+ offset-found
+ offset-wanted))))
+ ;; Establish the value of T.
+ (let ((t-symbol (cold-intern t :gspace *static*)))
+ (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*
+ :gspace *static*)))
+ (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*.
(defun cold-list-all-layouts ()
- (let ((result *nil-descriptor*))
+ (let ((layouts nil)
+ (result *nil-descriptor*))
(maphash (lambda (key stuff)
- (cold-push (cold-cons (cold-intern key)
- (first stuff))
- result))
+ (push (cons key (first stuff)) layouts))
*cold-layouts*)
- result))
+ (flet ((sorter (x y)
+ (let ((xpn (package-name (symbol-package-for-target-symbol x)))
+ (ypn (package-name (symbol-package-for-target-symbol y))))
+ (cond
+ ((string= x y) (string< xpn ypn))
+ (t (string< x y))))))
+ (setq layouts (sort layouts #'sorter :key #'car)))
+ (dolist (layout layouts result)
+ (cold-push (cold-cons (cold-intern (car layout)) (cdr layout))
+ result))))
;;; Establish initial values for magic symbols.
;;;
(let* ((cold-package (car cold-package-symbols-entry))
(symbols (cdr cold-package-symbols-entry))
(shadows (package-shadowing-symbols cold-package))
- (documentation (base-string-to-core (documentation cold-package t)))
+ (documentation (base-string-to-core
+ ;; KLUDGE: NIL punned as 0-length string.
+ (unless
+ ;; don't propagate the arbitrary
+ ;; docstring from host packages into
+ ;; the core
+ (or (eql cold-package *cl-package*)
+ (eql cold-package *keyword-package*))
+ (documentation cold-package t))))
(internal-count 0)
(external-count 0)
(internal *nil-descriptor*)
(cold-set '*!initial-fdefn-objects* (list-all-fdefn-objects))
(cold-set '*!reversed-cold-toplevels* *current-reversed-cold-toplevels*)
+ (cold-set '*!initial-debug-sources* *current-debug-sources*)
#!+(or x86 x86-64)
(progn
;;; Given a cold representation of a function name, return a warm
;;; representation.
-(declaim (ftype (function (descriptor) (or symbol list)) warm-fun-name))
+(declaim (ftype (function ((or descriptor symbol)) (or symbol list)) warm-fun-name))
(defun warm-fun-name (des)
(let ((result
- (ecase (descriptor-lowtag des)
- (#.sb!vm:list-pointer-lowtag
- (aver (not (cold-null des))) ; function named NIL? please no..
- ;; Do cold (DESTRUCTURING-BIND (COLD-CAR COLD-CADR) DES ..).
- (let* ((car-des (cold-car des))
- (cdr-des (cold-cdr des))
- (cadr-des (cold-car cdr-des))
- (cddr-des (cold-cdr cdr-des)))
- (aver (cold-null cddr-des))
- (list (warm-symbol car-des)
- (warm-symbol cadr-des))))
- (#.sb!vm:other-pointer-lowtag
- (warm-symbol des)))))
+ (if (symbolp des)
+ ;; This parallels the logic at the start of COLD-INTERN
+ ;; which re-homes symbols in SB-XC to COMMON-LISP.
+ (if (eq (symbol-package des) (find-package "SB-XC"))
+ (intern (symbol-name des) *cl-package*)
+ des)
+ (ecase (descriptor-lowtag des)
+ (#.sb!vm:list-pointer-lowtag
+ (aver (not (cold-null des))) ; function named NIL? please no..
+ ;; Do cold (DESTRUCTURING-BIND (COLD-CAR COLD-CADR) DES ..).
+ (let* ((car-des (cold-car des))
+ (cdr-des (cold-cdr des))
+ (cadr-des (cold-car cdr-des))
+ (cddr-des (cold-cdr cdr-des)))
+ (aver (cold-null cddr-des))
+ (list (warm-symbol car-des)
+ (warm-symbol cadr-des))))
+ (#.sb!vm:other-pointer-lowtag
+ (warm-symbol des))))))
(legal-fun-name-or-type-error result)
result))
(defun cold-fdefinition-object (cold-name &optional leave-fn-raw)
- (declare (type descriptor cold-name))
+ (declare (type (or descriptor symbol) 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 descriptor cold-name))
+ (declare (type (or descriptor symbol) 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)
sym nil offset desired))))))
(defun list-all-fdefn-objects ()
- (let ((result *nil-descriptor*))
+ (let ((fdefns nil)
+ (result *nil-descriptor*))
(maphash (lambda (key value)
- (declare (ignore key))
- (cold-push value result))
+ (push (cons key value) fdefns))
*cold-fdefn-objects*)
- result))
+ (flet ((sorter (x y)
+ (let* ((xbn (fun-name-block-name x))
+ (ybn (fun-name-block-name y))
+ (xbnpn (package-name (symbol-package-for-target-symbol xbn)))
+ (ybnpn (package-name (symbol-package-for-target-symbol ybn))))
+ (cond
+ ((eql xbn ybn) (consp x))
+ ((string= xbn ybn) (string< xbnpn ybnpn))
+ (t (string< xbn ybn))))))
+ (setq fdefns (sort fdefns #'sorter :key #'car)))
+ (dolist (fdefn fdefns result)
+ (cold-push (cdr fdefn) result))))
\f
;;;; fixups and related stuff
(subseq line (1+ p2)))
(values (parse-integer line :end p1 :radix 16)
(subseq line (1+ p2))))
+ ;; KLUDGE CLH 2010-05-31: on darwin, nm gives us
+ ;; _function but dlsym expects us to look up
+ ;; function, without the leading _ . Therefore, we
+ ;; strip it off here.
+ #!+darwin
+ (when (equal (char name 0) #\_)
+ (setf name (subseq name 1)))
(multiple-value-bind (old-value found)
(gethash name *cold-foreign-symbol-table*)
(when (and found
(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)
#!+x86
(defun output-load-time-code-fixups ()
- (maphash
- (lambda (code-object-address fixup-offsets)
- (let ((fixup-vector
- (allocate-vector-object
- *dynamic* sb-vm:n-word-bits (length fixup-offsets)
- sb!vm:simple-array-unsigned-byte-32-widetag)))
- (do ((index sb!vm:vector-data-offset (1+ index))
- (fixups fixup-offsets (cdr fixups)))
- ((null fixups))
- (write-wordindexed fixup-vector index
- (make-random-descriptor (car fixups))))
- ;; KLUDGE: The fixup vector is stored as the first constant,
- ;; not as a separately-named slot.
- (write-wordindexed (make-random-descriptor code-object-address)
- sb!vm:code-constants-offset
- fixup-vector)))
- *load-time-code-fixups*))
+ (let ((fixup-infos nil))
+ (maphash
+ (lambda (code-object-address fixup-offsets)
+ (push (cons code-object-address fixup-offsets) fixup-infos))
+ *load-time-code-fixups*)
+ (setq fixup-infos (sort fixup-infos #'< :key #'car))
+ (dolist (fixup-info fixup-infos)
+ (let ((code-object-address (car fixup-info))
+ (fixup-offsets (cdr fixup-info)))
+ (let ((fixup-vector
+ (allocate-vector-object
+ *dynamic* sb!vm:n-word-bits (length fixup-offsets)
+ sb!vm:simple-array-unsigned-byte-32-widetag)))
+ (do ((index sb!vm:vector-data-offset (1+ index))
+ (fixups fixup-offsets (cdr fixups)))
+ ((null fixups))
+ (write-wordindexed fixup-vector index
+ (make-random-descriptor (car fixups))))
+ ;; KLUDGE: The fixup vector is stored as the first constant,
+ ;; not as a separately-named slot.
+ (write-wordindexed (make-random-descriptor code-object-address)
+ sb!vm:code-constants-offset
+ fixup-vector))))))
;;; Given a pointer to a code object and an offset relative to the
;;; tail of the code object's header, return an offset relative to the
;;; create *STATIC-FOREIGN-SYMBOLS*, which the code in
;;; target-load.lisp refers to.
(defun foreign-symbols-to-core ()
- (let ((result *nil-descriptor*))
+ (let ((symbols nil)
+ (result *nil-descriptor*))
(maphash (lambda (symbol value)
- (cold-push (cold-cons (base-string-to-core symbol)
- (number-to-core value))
- result))
+ (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))
(let ((result *nil-descriptor*))
- (dolist (rtn *cold-assembler-routines*)
+ (dolist (rtn (sort (copy-list *cold-assembler-routines*) #'string< :key #'car))
(cold-push (cold-cons (cold-intern (car rtn))
(number-to-core (cdr rtn)))
result))
;; modified.
(copy-seq *fop-funs*))
-(defvar *normal-fop-funs*)
-
;;; Cause a fop to have a special definition for cold load.
;;;
;;; This is similar to DEFINE-FOP, but unlike DEFINE-FOP, this version
(defun cold-load (filename)
#!+sb-doc
"Load the file named by FILENAME into the cold load image being built."
- (let* ((*normal-fop-funs* *fop-funs*)
- (*fop-funs* *cold-fop-funs*)
+ (let* ((*fop-funs* *cold-fop-funs*)
(*cold-load-filename* (etypecase filename
(string filename)
(pathname (namestring filename)))))
(define-cold-fop (fop-short-character)
(make-character-descriptor (read-byte-arg)))
-(define-cold-fop (fop-empty-list) *nil-descriptor*)
-(define-cold-fop (fop-truth) (cold-intern t))
-
-(define-cold-fop (fop-normal-load :stackp nil)
- (setq *fop-funs* *normal-fop-funs*))
-
-(define-fop (fop-maybe-cold-load 82 :stackp nil)
- (when *cold-load-filename*
- (setq *fop-funs* *cold-fop-funs*)))
-
-(define-cold-fop (fop-maybe-cold-load :stackp nil))
+(define-cold-fop (fop-empty-list) nil)
+(define-cold-fop (fop-truth) t)
(clone-cold-fop (fop-struct)
(fop-small-struct)
(defun cold-load-symbol (size package)
(let ((string (make-string size)))
(read-string-as-bytes *fasl-input-stream* string)
- (cold-intern (intern string package))))
+ (intern string package)))
(macrolet ((frob (name pname-len package-len)
`(define-cold-fop (,name)
(let ((symbol-des (allocate-symbol name)))
(push-fop-table symbol-des))))
\f
+;;;; cold fops for loading packages
+
+(clone-cold-fop (fop-named-package-save :stackp nil)
+ (fop-small-named-package-save)
+ (let* ((size (clone-arg))
+ (name (make-string size)))
+ (read-string-as-bytes *fasl-input-stream* name)
+ (push-fop-table (find-package name))))
+\f
;;;; cold fops for loading lists
;;; Make a list of the top LENGTH things on the fop stack. The last
(write-wordindexed result sb!vm:array-data-slot data-vector)
(write-wordindexed result sb!vm:array-displacement-slot *nil-descriptor*)
(write-wordindexed result sb!vm:array-displaced-p-slot *nil-descriptor*)
+ (write-wordindexed result sb!vm:array-displaced-from-slot *nil-descriptor*)
(let ((total-elements 1))
(dotimes (axis rank)
(let ((dim (pop-stack)))
*nil-descriptor*)))
*current-reversed-cold-toplevels*)
(setf *load-time-value-counter* (1+ counter))
- (make-descriptor 0 0 nil counter)))
+ (make-descriptor 0 0 :load-time-value counter)))
(defun finalize-load-time-value-noise ()
(cold-set (cold-intern '*!load-time-values*)
(setf (gethash warm-name *cold-fset-warm-names*) t))
(static-fset cold-name fn)))
+(define-cold-fop (fop-note-debug-source :pushp nil)
+ (let ((debug-source (pop-stack)))
+ (cold-push debug-source *current-debug-sources*)))
+
(define-cold-fop (fop-fdefinition)
(cold-fdefinition-object (pop-stack)))
(write-wordindexed code slot value)))
(define-cold-fop (fop-fun-entry)
- (let* ((xrefs (pop-stack))
+ (let* ((info (pop-stack))
(type (pop-stack))
(arglist (pop-stack))
(name (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)
+ (write-wordindexed fn sb!vm::simple-fun-info-slot info)
fn))
(define-cold-fop (fop-foreign-fixup)
(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))))))
+ (maybe-record-with-translated-name '("-CORE-SPACE-ID") 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
;; it for now. nikodemus on #lisp (2004-08-09) suggested simply
(sort constants
(lambda (const1 const2)
(if (= (second const1) (second const2))
- (< (third const1) (third const2))
+ (if (= (third const1) (third const2))
+ (string< (first const1) (first const2))
+ (< (third const1) (third const2)))
(< (second const1) (second const2))))))
(let ((prev-priority (second (car constants))))
(dolist (const constants)
(unless (eq nil (car current-error))
(format t "#define ~A ~D~%"
(c-symbol-name (car current-error))
- i)))))
+ i))))
+ (format t "#define INTERNAL_ERROR_NAMES \\~%~{~S~#[~:;, \\~%~]~}~%"
+ (map 'list #'cdr internal-errors)))
(terpri)
;; I'm not really sure why this is in SB!C, since it seems
(c-symbol-name symbol)
(sb!xc:mask-field (symbol-value symbol) -1))))
-
+#!+sb-ldb
+(defun write-tagnames-h (&optional (out *standard-output*))
+ (labels
+ ((pretty-name (symbol strip)
+ (let ((name (string-downcase symbol)))
+ (substitute #\Space #\-
+ (subseq name 0 (- (length name) (length strip))))))
+ (list-sorted-tags (tail)
+ (loop for symbol being the external-symbols of "SB!VM"
+ when (and (constantp symbol)
+ (tailwise-equal (string symbol) tail))
+ collect symbol into tags
+ finally (return (sort tags #'< :key #'symbol-value))))
+ (write-tags (kind limit ash-count)
+ (format out "~%static const char *~(~A~)_names[] = {~%"
+ (subseq kind 1))
+ (let ((tags (list-sorted-tags kind)))
+ (dotimes (i limit)
+ (if (eql i (ash (or (symbol-value (first tags)) -1) ash-count))
+ (format out " \"~A\"" (pretty-name (pop tags) kind))
+ (format out " \"unknown [~D]\"" i))
+ (unless (eql i (1- limit))
+ (write-string "," out))
+ (terpri out)))
+ (write-line "};" out)))
+ (write-tags "-LOWTAG" sb!vm:lowtag-limit 0)
+ ;; this -2 shift depends on every OTHER-IMMEDIATE-?-LOWTAG
+ ;; ending with the same 2 bits. (#b10)
+ (write-tags "-WIDETAG" (ash (1+ sb!vm:widetag-mask) -2) -2))
+ (values))
(defun write-primitive-object (obj)
;; writing primitive object layouts
#!-gencgc sb!vm:dynamic-0-space-start))
(*nil-descriptor* (make-nil-descriptor))
(*current-reversed-cold-toplevels* *nil-descriptor*)
+ (*current-debug-sources* *nil-descriptor*)
(*unbound-marker* (make-other-immediate-descriptor
0
sb!vm:unbound-marker-widetag))
;; nothing if NAME is NIL.
(chill (name)
(when name
- (cold-intern (intern name package) package))))
+ (cold-intern (intern name package) :package package))))
(mapc-on-tree #'chill (sb-cold:package-data-export pd))
(mapc #'chill (sb-cold:package-data-reexport pd))
(dolist (sublist (sb-cold:package-data-import-from pd))
(write-map)))
(out-to "config" (write-config-h))
(out-to "constants" (write-constants-h))
+ #!+sb-ldb
+ (out-to "tagnames" (write-tagnames-h))
(let ((structs (sort (copy-list sb!vm:*primitive-objects*) #'string<
:key (lambda (obj)
(symbol-name
(when core-file-name
(write-initial-core-file core-file-name))))))
-
-
projects / sbcl.git / blobdiff