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