X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=fac1eb4e4bb49438cb05bba6f618ec0bf0943031;hb=6d36f2d6954cb79e3c88fef33fe0c3ad63deaea8;hp=9adf27bef532c9ce11071183b733b71d86988228;hpb=1589f3076965a68c07efa77539137673fed17e3c;p=sbcl.git diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 9adf27b..fac1eb4 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -86,7 +86,8 @@ `(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 ;;; @@ -280,7 +281,7 @@ (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 @@ -400,21 +401,31 @@ ;;; (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) @@ -422,6 +433,8 @@ (<= 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) @@ -430,8 +443,7 @@ (- 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)) @@ -498,6 +510,10 @@ ;;; 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) @@ -529,7 +545,7 @@ (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) @@ -543,19 +559,13 @@ *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) @@ -567,7 +577,7 @@ (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)." @@ -727,10 +737,17 @@ core and return a descriptor to it." (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) @@ -795,14 +812,10 @@ core and return a descriptor to it." ;;;; 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))) @@ -911,46 +924,8 @@ core and return a descriptor to it." ;; 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 @@ -961,6 +936,7 @@ core and return a descriptor to it." (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*) @@ -1119,8 +1095,9 @@ core and return a descriptor to it." ;;; 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)) @@ -1144,7 +1121,7 @@ core and return a descriptor to it." (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)) @@ -1211,40 +1188,48 @@ core and return a descriptor to it." (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. ;;; @@ -1281,7 +1266,15 @@ core and return a descriptor to it." (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*) @@ -1354,6 +1347,7 @@ core and return a descriptor to it." (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 @@ -1452,27 +1446,33 @@ core and return a descriptor to it." ;;; 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*) @@ -1496,7 +1496,7 @@ core and return a descriptor to it." ;;; 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) @@ -1534,12 +1534,23 @@ core and return a descriptor to it." 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)))) ;;;; fixups and related stuff @@ -1587,6 +1598,13 @@ core and return a descriptor to it." (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 @@ -1594,7 +1612,19 @@ core and return a descriptor to it." (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) @@ -1649,23 +1679,29 @@ core and return a descriptor to it." #!+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 @@ -1889,15 +1925,19 @@ core and return a descriptor to it." ;;; 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)) @@ -1913,8 +1953,6 @@ core and return a descriptor to it." ;; 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 @@ -1958,8 +1996,7 @@ core and return a descriptor to it." (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))))) @@ -1973,17 +2010,8 @@ core and return a descriptor to it." (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) @@ -2082,7 +2110,7 @@ core and return a descriptor to it." (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) @@ -2111,6 +2139,15 @@ core and return a descriptor to it." (let ((symbol-des (allocate-symbol name))) (push-fop-table symbol-des)))) +;;;; 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)))) + ;;;; cold fops for loading lists ;;; Make a list of the top LENGTH things on the fop stack. The last @@ -2257,6 +2294,7 @@ core and return a descriptor to it." (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))) @@ -2329,7 +2367,7 @@ core and return a descriptor to it." *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*) @@ -2400,6 +2438,10 @@ core and return a descriptor to it." (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))) @@ -2479,7 +2521,7 @@ core and return a descriptor to it." (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)) @@ -2537,7 +2579,7 @@ core and return a descriptor to it." (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) @@ -2758,7 +2800,8 @@ core and return a descriptor to it." (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 @@ -2787,7 +2830,9 @@ core and return a descriptor to it." (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) @@ -2809,7 +2854,9 @@ core and return a descriptor to it." (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 @@ -2845,7 +2892,36 @@ core and return a descriptor to it." (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 @@ -3213,6 +3289,7 @@ initially undefined function references:~2%") #!-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)) @@ -3271,7 +3348,7 @@ initially undefined function references:~2%") ;; 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)) @@ -3332,6 +3409,8 @@ initially undefined function references:~2%") (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 @@ -3364,5 +3443,3 @@ initially undefined function references:~2%") (when core-file-name (write-initial-core-file core-file-name)))))) - -