"the alignment requirement for spaces in the target.
Must be at least (ASH 1 DESCRIPTOR-LOW-BITS)")
-;;; a GENESIS-time representation of a memory space (e.g. read-only space,
-;;; dynamic space, or static space)
+;;; a GENESIS-time representation of a memory space (e.g. read-only
+;;; space, dynamic space, or static space)
(defstruct (gspace (:constructor %make-gspace)
(:copier nil))
;; name and identifier for this GSPACE
,(* i 8))))
(ash-list-be
(loop for i from 0 to (1- number-octets)
- collect `(ash (aref byte-vector (+ byte-index
- ,(- number-octets 1 i)))
+ collect `(ash (aref byte-vector
+ (+ byte-index
+ ,(- number-octets 1 i)))
,(* i 8))))
(setf-list-le
(loop for i from 0 to (1- number-octets)
(aver (= sb!vm:n-word-bits 32))
(aver (= sb!vm:n-byte-bits 8))
(logior ,@(ecase sb!c:*backend-byte-order*
- (:little-endian ash-list-le)
- (:big-endian ash-list-be))))
- (defun (setf ,name) (new-value byte-vector byte-index)
- (aver (= sb!vm:n-word-bits 32))
- (aver (= sb!vm:n-byte-bits 8))
- (setf ,@(ecase sb!c:*backend-byte-order*
- (:little-endian setf-list-le)
- (:big-endian setf-list-be))))))))
+ (:little-endian ash-list-le)
+ (:big-endian ash-list-be))))
+ (defun (setf ,name) (new-value byte-vector byte-index)
+ (aver (= sb!vm:n-word-bits 32))
+ (aver (= sb!vm:n-byte-bits 8))
+ (setf ,@(ecase sb!c:*backend-byte-order*
+ (:little-endian setf-list-le)
+ (:big-endian setf-list-be))))))))
(make-byte-vector-ref-n 8)
(make-byte-vector-ref-n 16)
(make-byte-vector-ref-n 32))
(write-wordindexed des (1+ sb!vm:complex-double-float-imag-slot) low-bits))))
des))
+;;; Copy the given number to the core.
(defun number-to-core (number)
- #!+sb-doc
- "Copy the given number to the core, or flame out if we can't deal with it."
(typecase number
(integer (if (< (integer-length number) 30)
(make-fixnum-descriptor number)
(write-wordindexed dest 1 cdr)
dest))
-;;; Make a simple-vector that holds the specified OBJECTS, and return its
-;;; descriptor.
+;;; Make a simple-vector on the target that holds the specified
+;;; OBJECTS, and return its descriptor.
(defun vector-in-core (&rest objects)
(let* ((size (length objects))
(result (allocate-vector-object *dynamic* sb!vm:n-word-bits size
(defvar *cold-symbols*)
(declaim (type hash-table *cold-symbols*))
+;;; sanity check for a symbol we're about to create on the target
+;;;
+;;; Make sure that the symbol has an appropriate package. In
+;;; particular, catch the so-easy-to-make error of typing something
+;;; like SB-KERNEL:%BYTE-BLT in cold sources when what you really
+;;; need is SB!KERNEL:%BYTE-BLT.
+(defun package-ok-for-target-symbol-p (package)
+ (let ((package-name (package-name package)))
+ (or
+ ;; Cold interning things in these standard packages is OK. (Cold
+ ;; interning things in the other standard package, CL-USER, isn't
+ ;; OK. We just use CL-USER to expose symbols whose homes are in
+ ;; other packages. Thus, trying to cold intern a symbol whose
+ ;; home package is CL-USER probably means that a coding error has
+ ;; been made somewhere.)
+ (find package-name '("COMMON-LISP" "KEYWORD") :test #'string=)
+ ;; Cold interning something in one of our target-code packages,
+ ;; which are ever-so-rigorously-and-elegantly distinguished by
+ ;; this prefix on their names, is OK too.
+ (string= package-name "SB!" :end1 3 :end2 3)
+ ;; This one is OK too, since it ends up being COMMON-LISP on the
+ ;; target.
+ (string= package-name "SB-XC")
+ ;; Anything else looks bad. (maybe COMMON-LISP-USER? maybe an extension
+ ;; package in the xc host? something we can't think of
+ ;; a valid reason to cold intern, anyway...)
+ )))
+
+;;; like SYMBOL-PACKAGE, but safe for symbols which end up on the target
+;;;
+;;; Most host symbols we dump onto the target are created by SBCL
+;;; itself, so that as long as we avoid gratuitously
+;;; cross-compilation-unfriendly hacks, it just happens that their
+;;; SYMBOL-PACKAGE in the host system corresponds to their
+;;; SYMBOL-PACKAGE in the target system. However, that's not the case
+;;; in the COMMON-LISP package, where we don't get to create the
+;;; symbols but instead have to use the ones that the xc host created.
+;;; In particular, while ANSI specifies which symbols are exported
+;;; from COMMON-LISP, it doesn't specify that their home packages are
+;;; COMMON-LISP, so the xc host can keep them in random packages which
+;;; don't exist on the target (e.g. CLISP keeping some CL-exported
+;;; symbols in the CLOS package).
+(defun symbol-package-for-target-symbol (symbol)
+ ;; We want to catch weird symbols like CLISP's
+ ;; CL:FIND-METHOD=CLOS::FIND-METHOD, but we don't want to get
+ ;; sidetracked by ordinary symbols like :CHARACTER which happen to
+ ;; have the same SYMBOL-NAME as exports from COMMON-LISP.
+ (multiple-value-bind (cl-symbol cl-status)
+ (find-symbol (symbol-name symbol) *cl-package*)
+ (if (and (eq symbol cl-symbol)
+ (eq cl-status :external))
+ ;; special case, to work around possible xc host weirdness
+ ;; in COMMON-LISP package
+ *cl-package*
+ ;; ordinary case
+ (let ((result (symbol-package symbol)))
+ (aver (package-ok-for-target-symbol-p result))
+ result))))
+
;;; Return a handle on an interned symbol. If necessary allocate the
;;; symbol and record which package the symbol was referenced in. When
;;; 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 symbol)))
+(defun cold-intern (symbol
+ &optional
+ (package (symbol-package-for-target-symbol symbol)))
+
+ (aver (package-ok-for-target-symbol-p package))
;; Anything on the cross-compilation host which refers to the target
;; machinery through the host SB-XC package should be translated to
(when (eq (symbol-package symbol) p)
(setf symbol (intern (symbol-name symbol) *cl-package*))))
- ;; Make sure that the symbol has an appropriate package. In
- ;; particular, catch the so-easy-to-make error of typing something
- ;; like SB-KERNEL:%BYTE-BLT in cold sources when what you really
- ;; need is SB!KERNEL:%BYTE-BLT.
- (let ((package-name (package-name package)))
- (cond ((find package-name '("COMMON-LISP" "KEYWORD") :test #'string=)
- ;; Cold interning things in these standard packages is OK.
- ;; (Cold interning things in the other standard package,
- ;; CL-USER, isn't OK. We just use CL-USER to expose symbols
- ;; whose homes are in other packages. Thus, trying to cold
- ;; intern a symbol whose home package is CL-USER probably
- ;; means that a coding error has been made somewhere.)
- (values))
- ((string= package-name "SB!" :end1 3 :end2 3)
- ;; That looks OK, too. (All the target-code packages
- ;; have names like that.)
- (values))
- (t
- ;; looks bad: maybe COMMON-LISP-USER? maybe an extension
- ;; package in the xc host? something we can't think of
- ;; a valid reason to cold intern, anyway...
- (bug
- "internal error: PACKAGE-NAME=~S looks too much like a typo."
- package-name))))
-
(let (;; Information about each cold-interned symbol is stored
;; in COLD-INTERN-INFO.
;; (CAR COLD-INTERN-INFO) = descriptor of symbol
;; (CDR COLD-INTERN-INFO) = list of packages, other than symbol's
- ;; own package, referring to symbol
+ ;; 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-intern-info (get symbol 'cold-intern-info)))
(unless cold-intern-info
- (cond ((eq (symbol-package symbol) package)
+ (cond ((eq (symbol-package-for-target-symbol symbol) package)
(let ((handle (allocate-symbol (symbol-name symbol))))
(setf (gethash (descriptor-bits handle) *cold-symbols*) symbol)
(when (eq package *keyword-package*)
(imported-internal *nil-descriptor*)
(imported-external *nil-descriptor*)
(shadowing *nil-descriptor*))
+ (declare (type package cold-package)) ; i.e. not a target descriptor
(/show "dumping" cold-package symbols)
;; FIXME: Add assertions here to make sure that inappropriate stuff
(dolist (symbol symbols)
(let ((handle (car (get symbol 'cold-intern-info)))
- (imported-p (not (eq (symbol-package symbol) cold-package))))
+ (imported-p (not (eq (symbol-package-for-target-symbol symbol)
+ cold-package))))
(multiple-value-bind (found where)
(find-symbol (symbol-name symbol) cold-package)
(unless (and where (eq found symbol))
(progn
(cold-set 'sb!vm::*fp-constant-0d0* (number-to-core 0d0))
(cold-set 'sb!vm::*fp-constant-1d0* (number-to-core 1d0))
- (cold-set 'sb!vm::*fp-constant-0s0* (number-to-core 0s0))
- (cold-set 'sb!vm::*fp-constant-1s0* (number-to-core 1s0))
+ (cold-set 'sb!vm::*fp-constant-0f0* (number-to-core 0f0))
+ (cold-set 'sb!vm::*fp-constant-1f0* (number-to-core 1f0))
#!+long-float
(progn
(cold-set 'sb!vm::*fp-constant-0l0* (number-to-core 0L0))
sb!vm:fdefn-raw-addr-slot
(make-random-descriptor
(cold-foreign-symbol-address-as-integer
- "undefined_tramp"))))
+ (sb!vm:extern-alien-name "undefined_tramp")))))
fdefn))))
;;; Handle the at-cold-init-time, fset-for-static-linkage operation
(#.sb!vm:closure-header-widetag
(make-random-descriptor
(cold-foreign-symbol-address-as-integer
- "closure_tramp")))))
+ (sb!vm:extern-alien-name "closure_tramp"))))))
fdefn))
(defun initialize-static-fns ()
(dolist (obj structs)
(format t
"struct ~A {~%"
- (nsubstitute #\_ #\-
+ (substitute #\_ #\-
(string-downcase (string (sb!vm:primitive-object-name obj)))))
(when (sb!vm:primitive-object-widetag obj)
(format t " lispobj header;~%"))
(dolist (slot (sb!vm:primitive-object-slots obj))
(format t " ~A ~A~@[[1]~];~%"
(getf (sb!vm:slot-options slot) :c-type "lispobj")
- (nsubstitute #\_ #\-
- (string-downcase (string (sb!vm:slot-name slot))))
+ (substitute #\_ #\-
+ (string-downcase (string (sb!vm:slot-name slot))))
(sb!vm:slot-rest-p slot)))
(format t "};~2%"))
(format t "#else /* LANGUAGE_ASSEMBLY */~2%")
;; FIXME: It would be nice to use longer names than NIL and
;; (particularly) T in #define statements.
(format t "#define ~A LISPOBJ(0x~X)~%"
- (nsubstitute #\_ #\-
- (remove-if (lambda (char)
- (member char '(#\% #\* #\. #\!)))
- (symbol-name symbol)))
+ (substitute #\_ #\-
+ (remove-if (lambda (char)
+ (member char '(#\% #\* #\. #\!)))
+ (symbol-name symbol)))
(if *static* ; if we ran GENESIS
;; We actually ran GENESIS, use the real value.
(descriptor-bits (cold-intern symbol))
projects / sbcl.git / blobdiff