(gspace nil :type (or gspace null))
;; the offset in words from the start of GSPACE, or NIL if not set yet
(word-offset nil :type (or (unsigned-byte #.sb!vm:word-bits) null))
- ;; the high and low halves of the descriptor KLUDGE: Judging from
- ;; the comments in genesis.lisp of the CMU CL old-rt compiler, this
- ;; split dates back from a very early version of genesis where
- ;; 32-bit integers were represented as conses of two 16-bit
- ;; integers. In any system with nice (UNSIGNED-BYTE 32) structure
- ;; slots, like CMU CL >= 17 or any version of SBCL, there seems to
- ;; be no reason to persist in this. -- WHN 19990917
- high low)
+ ;; the high and low halves of the descriptor
+ ;;
+ ;; KLUDGE: Judging from the comments in genesis.lisp of the CMU CL
+ ;; old-rt compiler, this split dates back from a very early version
+ ;; of genesis where 32-bit integers were represented as conses of
+ ;; two 16-bit integers. In any system with nice (UNSIGNED-BYTE 32)
+ ;; structure slots, like CMU CL >= 17 or any version of SBCL, there
+ ;; seems to be no reason to persist in this. -- WHN 19990917
+ high
+ low)
(def!method print-object ((des descriptor) stream)
(let ((lowtag (descriptor-lowtag des)))
(print-unreadable-object (des stream :type t)
(let ((lowtag (descriptor-lowtag des))
(high (descriptor-high des))
(low (descriptor-low des)))
- (if (or (eql lowtag sb!vm:function-pointer-type)
+ (if (or (eql lowtag sb!vm:fun-pointer-type)
(eql lowtag sb!vm:instance-pointer-type)
(eql lowtag sb!vm:list-pointer-type)
(eql lowtag sb!vm:other-pointer-type))
;; (CAR COLD-INTERN-INFO) = descriptor of symbol
;; (CDR COLD-INTERN-INFO) = list of packages, other than symbol's
;; own package, referring to symbol
- ;; (*COLD-PACKAGE-SYMBOLS* and *COLD-SYMBOLS* store basically the same
- ;; information, but with the mapping running the opposite way.)
+ ;; (*COLD-PACKAGE-SYMBOLS* and *COLD-SYMBOLS* store basically the
+ ;; same information, but with the mapping running the opposite way.)
(cold-intern-info (get symbol 'cold-intern-info)))
(unless cold-intern-info
(cond ((eq (symbol-package symbol) package)
;; section at all? Is it because all the FDEFINITION stuff gets in
;; the way of reading function values and is too hairy to rely on at
;; cold boot? FIXME: Most of these are in *STATIC-SYMBOLS* in
- ;; parms.lisp, but %HANDLE-FUNCTION-END-BREAKPOINT is not. Why?
+ ;; parms.lisp, but %HANDLE-FUN-END-BREAKPOINT is not. Why?
;; Explain.
(macrolet ((frob (symbol)
`(cold-set ',symbol
(frob maybe-gc)
(frob internal-error)
(frob sb!di::handle-breakpoint)
- (frob sb!di::handle-function-end-breakpoint))
+ (frob sb!di::handle-fun-end-breakpoint))
(cold-set '*current-catch-block* (make-fixnum-descriptor 0))
(cold-set '*current-unwind-protect-block* (make-fixnum-descriptor 0))
(cold-push (string-to-core (package-name pkg)) res)
res))
\f
-;;;; fdefinition objects
+;;;; functions and fdefinition objects
;;; a hash table mapping from fdefinition names to descriptors of cold
-;;; objects. Note: Since fdefinition names can be lists like '(SETF
-;;; FOO), and we want to have only one entry per name, this must be an
-;;; 'EQUAL hash table, not the default 'EQL.
+;;; objects
+;;;
+;;; Note: Since fdefinition names can be lists like '(SETF FOO), and
+;;; we want to have only one entry per name, this must be an 'EQUAL
+;;; hash table, not the default 'EQL.
(defvar *cold-fdefn-objects*)
(defvar *cold-fdefn-gspace* nil)
-;;; Given a cold representation of an FDEFN name, return a warm representation.
-;;;
-;;; Note: Despite the name, this actually has little to do with
-;;; FDEFNs, it's just a function for warming up values, and the only
-;;; values it knows how to warm up are symbols and lists. (The
-;;; connection to FDEFNs is that symbols and lists are the only
-;;; possible names for functions.)
-(declaim (ftype (function (descriptor) (or symbol list)) warm-fdefn-name))
-(defun warm-fdefn-name (des)
- (ecase (descriptor-lowtag des)
- (#.sb!vm:list-pointer-type ; FIXME: no #.
- (if (= (descriptor-bits des) (descriptor-bits *nil-descriptor*))
- nil
- ;; FIXME: If we cold-intern this again, we might get a different
- ;; name. Check to make sure that any hash tables along the way
- ;; are 'EQUAL not 'EQL.
- (cons (warm-fdefn-name (read-wordindexed des sb!vm:cons-car-slot))
- (warm-fdefn-name (read-wordindexed des sb!vm:cons-cdr-slot)))))
- (#.sb!vm:other-pointer-type ; FIXME: no #.
- (or (gethash (descriptor-bits des) *cold-symbols*)
- (descriptor-bits des)))))
+;;; Given a cold representation of a symbol, return a warm
+;;; representation.
+(defun warm-symbol (des)
+ ;; Note that COLD-INTERN is responsible for keeping the
+ ;; *COLD-SYMBOLS* table up to date, so if DES happens to refer to an
+ ;; uninterned symbol, the code below will fail. But as long as we
+ ;; don't need to look up uninterned symbols during bootstrapping,
+ ;; that's OK..
+ (multiple-value-bind (symbol found-p)
+ (gethash (descriptor-bits des) *cold-symbols*)
+ (declare (type symbol symbol))
+ (unless found-p
+ (error "no warm symbol"))
+ symbol))
+
+;;; like CL:CAR, CL:CDR, and CL:NULL but for cold values
+(defun cold-car (des)
+ (aver (= (descriptor-lowtag des) sb!vm:list-pointer-type))
+ (read-wordindexed des sb!vm:cons-car-slot))
+(defun cold-cdr (des)
+ (aver (= (descriptor-lowtag des) sb!vm:list-pointer-type))
+ (read-wordindexed des sb!vm:cons-cdr-slot))
+(defun cold-null (des)
+ (= (descriptor-bits des)
+ (descriptor-bits *nil-descriptor*)))
+
+;;; Given a cold representation of a function name, return a warm
+;;; representation.
+(declaim (ftype (function (descriptor) (or symbol list)) warm-fun-name))
+(defun warm-fun-name (des)
+ (let ((result
+ (ecase (descriptor-lowtag des)
+ (#.sb!vm:list-pointer-type
+ (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-type
+ (warm-symbol des)))))
+ (unless (legal-function-name-p result)
+ (error "not a legal function name: ~S" result))
+ result))
(defun cold-fdefinition-object (cold-name &optional leave-fn-raw)
(declare (type descriptor cold-name))
- (let ((warm-name (warm-fdefn-name cold-name)))
+ (let ((warm-name (warm-fun-name cold-name)))
(or (gethash warm-name *cold-fdefn-objects*)
(let ((fdefn (allocate-boxed-object (or *cold-fdefn-gspace* *dynamic*)
(1- sb!vm:fdefn-size)
(1- sb!vm:fdefn-size) sb!vm:fdefn-type))
(write-wordindexed fdefn sb!vm:fdefn-name-slot cold-name)
(unless leave-fn-raw
- (write-wordindexed fdefn sb!vm:fdefn-function-slot
+ (write-wordindexed fdefn sb!vm:fdefn-fun-slot
*nil-descriptor*)
(write-wordindexed fdefn
sb!vm:fdefn-raw-addr-slot
(make-random-descriptor
- (cold-foreign-symbol-address-as-integer "undefined_tramp"))))
+ (cold-foreign-symbol-address-as-integer
+ "undefined_tramp"))))
fdefn))))
-(defun cold-fset (cold-name defn)
+;;; 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))
(let ((fdefn (cold-fdefinition-object cold-name t))
(type (logand (descriptor-low (read-memory defn)) sb!vm:type-mask)))
- (write-wordindexed fdefn sb!vm:fdefn-function-slot defn)
+ (write-wordindexed fdefn sb!vm:fdefn-fun-slot defn)
(write-wordindexed fdefn
sb!vm:fdefn-raw-addr-slot
(ecase type
- (#.sb!vm:function-header-type
+ (#.sb!vm:simple-fun-header-type
#!+sparc
defn
#!-sparc
(make-random-descriptor
(+ (logandc2 (descriptor-bits defn)
sb!vm:lowtag-mask)
- (ash sb!vm:function-code-offset
+ (ash sb!vm:simple-fun-code-offset
sb!vm:word-shift))))
(#.sb!vm:closure-header-type
(make-random-descriptor
\f
;;;; cold fops for loading symbols
-;;; Load a symbol SIZE characters long from *FASL-INPUT-STREAM* and intern
-;;; that symbol in PACKAGE.
+;;; Load a symbol SIZE characters long from *FASL-INPUT-STREAM* and
+;;; intern that symbol in PACKAGE.
(defun cold-load-symbol (size package)
(let ((string (make-string size)))
(read-string-as-bytes *fasl-input-stream* string)
(let* ((size (clone-arg))
(name (make-string size)))
(read-string-as-bytes *fasl-input-stream* name)
- (let ((symbol (allocate-symbol name)))
- (push-fop-table symbol))))
+ (let ((symbol-des (allocate-symbol name)))
+ (push-fop-table symbol-des))))
\f
;;;; cold fops for loading lists
\f
;;;; cold fops for loading code objects and functions
+;;; the names of things which have had COLD-FSET used on them already
+;;; (used to make sure that we don't try to statically link a name to
+;;; more than one definition)
+(defparameter *cold-fset-warm-names*
+ ;; This can't be an EQL hash table because names can be conses, e.g.
+ ;; (SETF CAR).
+ (make-hash-table :test 'equal))
+
(define-cold-fop (fop-fset nil)
- (let ((fn (pop-stack))
- (name (pop-stack)))
- (cold-fset name fn)))
+ (let* ((fn (pop-stack))
+ (cold-name (pop-stack))
+ (warm-name (warm-fun-name cold-name)))
+ (if (gethash warm-name *cold-fset-warm-names*)
+ (error "duplicate COLD-FSET for ~S" warm-name)
+ (setf (gethash warm-name *cold-fset-warm-names*) t))
+ (static-fset cold-name fn)))
(define-cold-fop (fop-fdefinition)
(cold-fdefinition-object (pop-stack)))
(define-cold-fop (fop-sanctify-for-execution)
(pop-stack))
-(not-cold-fop fop-make-byte-compiled-function)
-
;;; Setting this variable shows what code looks like before any
;;; fixups (or function headers) are applied.
#!+sb-show (defvar *show-pre-fixup-code-p* nil)
(offset (calc-offset code-object (read-arg 4)))
(fn (descriptor-beyond code-object
offset
- sb!vm:function-pointer-type))
+ sb!vm:fun-pointer-type))
(next (read-wordindexed code-object sb!vm:code-entry-points-slot)))
(unless (zerop (logand offset sb!vm:lowtag-mask))
;; FIXME: This should probably become a fatal error.
(warn "unaligned function entry: ~S at #X~X" name offset))
(write-wordindexed code-object sb!vm:code-entry-points-slot fn)
(write-memory fn
- (make-other-immediate-descriptor (ash offset
- (- sb!vm:word-shift))
- sb!vm:function-header-type))
+ (make-other-immediate-descriptor
+ (ash offset (- sb!vm:word-shift))
+ sb!vm:simple-fun-header-type))
(write-wordindexed fn
- sb!vm:function-self-slot
+ sb!vm:simple-fun-self-slot
;; KLUDGE: Wiring decisions like this in at
;; this level ("if it's an x86") instead of a
;; higher level of abstraction ("if it has such
;; -- WHN 19990907
(make-random-descriptor
(+ (descriptor-bits fn)
- (- (ash sb!vm:function-code-offset sb!vm:word-shift)
+ (- (ash sb!vm:simple-fun-code-offset
+ sb!vm:word-shift)
;; FIXME: We should mask out the type
;; bits, not assume we know what they
;; are and subtract them out this way.
- sb!vm:function-pointer-type))))
- (write-wordindexed fn sb!vm:function-next-slot next)
- (write-wordindexed fn sb!vm:function-name-slot name)
- (write-wordindexed fn sb!vm:function-arglist-slot arglist)
- (write-wordindexed fn sb!vm:function-type-slot type)
+ sb!vm:fun-pointer-type))))
+ (write-wordindexed fn sb!vm:simple-fun-next-slot next)
+ (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)
fn))
(define-cold-fop (fop-foreign-fixup)
;; writing beginning boilerplate
(format t "/*~%")
(dolist (line
- '("This is a machine-generated file. Do not edit it by hand."
+ '("This is a machine-generated file. Please do not edit it by hand."
""
"This file contains low-level information about the"
"internals of a particular version and configuration"
(format t "#ifndef _SBCL_H_~%#define _SBCL_H_~%")
(terpri)
+ ;; propagating *SHEBANG-FEATURES* into C-level #define's
+ (dolist (shebang-feature-name (sort (mapcar #'symbol-name
+ sb-cold:*shebang-features*)
+ #'string<))
+ (format t
+ "#define LISP_FEATURE_~A~%"
+ (substitute #\_ #\- shebang-feature-name)))
+ (terpri)
+
;; writing miscellaneous constants
(format t "#define SBCL_CORE_VERSION_INTEGER ~D~%" sbcl-core-version-integer)
(format t
;; writing codes/strings for internal errors
(format t "#define ERRORS { \\~%")
- ;; FIXME: Is this just DO-VECTOR?
+ ;; FIXME: Is this just DOVECTOR?
(let ((internal-errors sb!c:*backend-internal-errors*))
(dotimes (i (length internal-errors))
(format t " ~S, /*~D*/ \\~%" (cdr (aref internal-errors i)) i)))
(undefs nil))
(maphash #'(lambda (name fdefn)
(let ((fun (read-wordindexed fdefn
- sb!vm:fdefn-function-slot)))
+ sb!vm:fdefn-fun-slot)))
(if (= (descriptor-bits fun)
(descriptor-bits *nil-descriptor*))
(push name undefs)
- (let ((addr (read-wordindexed fdefn
- sb!vm:fdefn-raw-addr-slot)))
+ (let ((addr (read-wordindexed
+ fdefn sb!vm:fdefn-raw-addr-slot)))
(push (cons name (descriptor-bits addr))
funs)))))
*cold-fdefn-objects*)
(format t "~%~|~%initially defined functions:~2%")
- (dolist (info (sort funs #'< :key #'cdr))
+ (setf funs (sort funs #'< :key #'cdr))
+ (dolist (info funs)
(format t "0x~8,'0X: ~S #X~8,'0X~%" (cdr info) (car info)
(- (cdr info) #x17)))
(format t
that they were called before the out-of-line definition is installed,
as is fairly common for structure accessors.)
initially undefined function references:~2%")
- (labels ((key (name)
- (etypecase name
- (symbol (symbol-name name))
- ;; FIXME: should use standard SETF-function parsing logic
- (list (key (second name))))))
- (dolist (name (sort undefs #'string< :key #'key))
- (format t "~S" name)
- ;; FIXME: This ACCESSOR-FOR stuff should go away when the
- ;; code has stabilized. (It's only here to help me
- ;; categorize the flood of undefined functions caused by
- ;; completely rewriting the bootstrap process. Hopefully any
- ;; future maintainers will mostly have small numbers of
- ;; undefined functions..)
- (let ((accessor-for (info :function :accessor-for name)))
- (when accessor-for
- (format t " (accessor for ~S)" accessor-for)))
- (format t "~%")))))
-
- (format t "~%~|~%layout names:~2%")
- (collect ((stuff))
- (maphash #'(lambda (name gorp)
- (declare (ignore name))
- (stuff (cons (descriptor-bits (car gorp))
- (cdr gorp))))
- *cold-layouts*)
- (dolist (x (sort (stuff) #'< :key #'car))
- (apply #'format t "~8,'0X: ~S[~D]~%~10T~S~%" x)))
+
+ (setf undefs (sort undefs #'string< :key #'function-name-block-name))
+ (dolist (name undefs)
+ (format t "~S" name)
+ ;; FIXME: This ACCESSOR-FOR stuff should go away when the
+ ;; code has stabilized. (It's only here to help me
+ ;; categorize the flood of undefined functions caused by
+ ;; completely rewriting the bootstrap process. Hopefully any
+ ;; future maintainers will mostly have small numbers of
+ ;; undefined functions..)
+ (let ((accessor-for (info :function :accessor-for name)))
+ (when accessor-for
+ (format t " (accessor for ~S)" accessor-for)))
+ (format t "~%")))
+
+ (format t "~%~|~%layout names:~2%")
+ (collect ((stuff))
+ (maphash #'(lambda (name gorp)
+ (declare (ignore name))
+ (stuff (cons (descriptor-bits (car gorp))
+ (cdr gorp))))
+ *cold-layouts*)
+ (dolist (x (sort (stuff) #'< :key #'car))
+ (apply #'format t "~8,'0X: ~S[~D]~%~10T~S~%" x))))
(values))
\f
(let* ((cold-name (cold-intern '!cold-init))
(cold-fdefn (cold-fdefinition-object cold-name))
(initial-function (read-wordindexed cold-fdefn
- sb!vm:fdefn-function-slot)))
+ sb!vm:fdefn-fun-slot)))
(format t
"~&/(DESCRIPTOR-BITS INITIAL-FUNCTION)=#X~X~%"
(descriptor-bits initial-function))
projects / sbcl.git / blobdiff