(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))
*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."
+ ;; 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)
(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)."
(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))
\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)))
(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*.
;;; 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)
(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)
;; 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 ((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)
(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
(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))))
(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
(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
(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)
(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))
;; 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))
projects / sbcl.git / blobdiff