X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=241717de50eefacd23194e44cf91bdc3bc6d8275;hb=dfa55a883f94470267b626dae77ce7e7dfac3df6;hp=ab432921b54d0aa63dc54a7e2ade258835f894d5;hpb=0b5610d8a220a4b20cbeac958953ca4d67c00038;p=sbcl.git diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index ab43292..241717d 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -344,7 +344,7 @@ ;;; comparing the byte order of *BACKEND* to the byte order of ;;; *NATIVE-BACKEND*, a concept which doesn't exist in SBCL. Instead, ;;; in SBCL byte order swapping would need to be explicitly requested -;;; with a keyword argument to GENESIS. +;;; with a &KEY argument to GENESIS. ;;; ;;; I'm not sure whether this is a problem or not, and I don't have a ;;; machine with different byte order to test to find out for sure. @@ -375,8 +375,8 @@ (defun maybe-byte-swap (word) (declare (type (unsigned-byte 32) word)) - (assert (= sb!vm:word-bits 32)) - (assert (= sb!vm:byte-bits 8)) + (aver (= sb!vm:word-bits 32)) + (aver (= sb!vm:byte-bits 8)) (if (not *genesis-byte-order-swap-p*) word (logior (ash (ldb (byte 8 0) word) 24) @@ -386,37 +386,48 @@ (defun maybe-byte-swap-short (short) (declare (type (unsigned-byte 16) short)) - (assert (= sb!vm:word-bits 32)) - (assert (= sb!vm:byte-bits 8)) + (aver (= sb!vm:word-bits 32)) + (aver (= sb!vm:byte-bits 8)) (if (not *genesis-byte-order-swap-p*) short (logior (ash (ldb (byte 8 0) short) 8) (ldb (byte 8 8) short)))) -;;; like SAP-REF-32, except that instead of a SAP we use a byte vector -(defun byte-vector-ref-32 (byte-vector byte-index) - (assert (= sb!vm:word-bits 32)) - (assert (= sb!vm:byte-bits 8)) +;;; BYTE-VECTOR-REF-32 and friends. These are like SAP-REF-n, except +;;; that instead of a SAP we use a byte vector +(macrolet ((make-byte-vector-ref-n + (n) + (let* ((name (intern (format nil "BYTE-VECTOR-REF-~A" n))) + (number-octets (/ n 8)) + (ash-list + (loop for i from 0 to (1- number-octets) + collect `(ash (aref byte-vector (+ byte-index ,i)) + ,(* i 8)))) + (setf-list + (loop for i from 0 to (1- number-octets) + append + `((aref byte-vector (+ byte-index ,i)) + (ldb (byte 8 ,(* i 8)) new-value))))) + `(progn + (defun ,name (byte-vector byte-index) + (aver (= sb!vm:word-bits 32)) + (aver (= sb!vm:byte-bits 8)) (ecase sb!c:*backend-byte-order* (:little-endian - (logior (ash (aref byte-vector (+ byte-index 0)) 0) - (ash (aref byte-vector (+ byte-index 1)) 8) - (ash (aref byte-vector (+ byte-index 2)) 16) - (ash (aref byte-vector (+ byte-index 3)) 24))) + (logior ,@ash-list)) (:big-endian (error "stub: no big-endian ports of SBCL (yet?)")))) -(defun (setf byte-vector-ref-32) (new-value byte-vector byte-index) - (assert (= sb!vm:word-bits 32)) - (assert (= sb!vm:byte-bits 8)) + (defun (setf ,name) (new-value byte-vector byte-index) + (aver (= sb!vm:word-bits 32)) + (aver (= sb!vm:byte-bits 8)) (ecase sb!c:*backend-byte-order* (:little-endian - (setf (aref byte-vector (+ byte-index 0)) (ldb (byte 8 0) new-value) - (aref byte-vector (+ byte-index 1)) (ldb (byte 8 8) new-value) - (aref byte-vector (+ byte-index 2)) (ldb (byte 8 16) new-value) - (aref byte-vector (+ byte-index 3)) (ldb (byte 8 24) new-value))) + (setf ,@setf-list)) (:big-endian - (error "stub: no big-endian ports of SBCL (yet?)"))) - new-value) + (error "stub: no big-endian ports of SBCL (yet?)")))))))) + (make-byte-vector-ref-n 8) + (make-byte-vector-ref-n 16) + (make-byte-vector-ref-n 32)) (declaim (ftype (function (descriptor sb!vm:word) descriptor) read-wordindexed)) (defun read-wordindexed (address index) @@ -726,7 +737,7 @@ ;;;; symbol magic -;;; FIXME: This should be a keyword argument of ALLOCATE-SYMBOL. +;;; FIXME: This should be a &KEY argument of ALLOCATE-SYMBOL. (defvar *cold-symbol-allocation-gspace* nil) ;;; Allocate (and initialize) a symbol. @@ -1435,8 +1446,12 @@ (setf (gethash name *cold-foreign-symbol-table*) value)))))) (values))) +;;; FIXME: the relation between #'lookup-foreign-symbol and +;;; #'lookup-maybe-prefix-foreign-symbol seems more than slightly +;;; illdefined + (defun lookup-foreign-symbol (name) - #!+x86 + #!+(or alpha x86) (let ((prefixes #!+linux #(;; FIXME: How many of these are actually ;; needed? The first four are taken from rather @@ -1464,7 +1479,7 @@ *cold-foreign-symbol-table*) (format *error-output* "~&The prefix table is: ~S~%" prefixes) (error "The foreign symbol ~S is undefined." name)))) - #!-x86 (error "non-x86 unsupported in SBCL (but see old CMU CL code)")) + #!-(or x86 alpha) (error "non-x86/alpha unsupported in SBCL (but see old CMU CL code)")) (defvar *cold-assembler-routines*) @@ -1551,71 +1566,51 @@ (gspace-byte-address (gspace-byte-address (descriptor-gspace code-object)))) (ecase sb!c:*backend-fasl-file-implementation* - ;; Classic CMU CL supported these, and I haven't gone out of my way - ;; to break them, but I have no way of testing them.. -- WHN 19990817 - #| - (#.sb!c:pmax-fasl-file-implementation - (ecase kind - (:jump - (assert (zerop (ash value -28))) - (setf (ldb (byte 26 0) (sap-ref-32 sap 0)) - (ash value -2))) - (:lui - (setf (sap-ref-16 sap 0) - (+ (ash value -16) - (if (logbitp 15 value) 1 0)))) - (:addi - (setf (sap-ref-16 sap 0) - (ldb (byte 16 0) value))))) - (#.sb!c:sparc-fasl-file-implementation - (let ((inst (maybe-byte-swap (sap-ref-32 sap 0)))) + ;; See CMUCL source for other formerly-supported architectures + ;; (and note that you have to rewrite them to use vector-ref unstead + ;; of sap-ref) + (:alpha (ecase kind - (:call - (error "Can't deal with call fixups yet.")) - (:sethi - (setf inst - (dpb (ldb (byte 22 10) value) - (byte 22 0) - inst))) - (:add - (setf inst - (dpb (ldb (byte 10 0) value) - (byte 10 0) - inst)))) - (setf (sap-ref-32 sap 0) - (maybe-byte-swap inst)))) - ((#.sb!c:rt-fasl-file-implementation - #.sb!c:rt-afpa-fasl-file-implementation) - (ecase kind - (:cal - (setf (sap-ref-16 sap 2) - (maybe-byte-swap-short - (ldb (byte 16 0) value)))) - (:cau - (let ((high (ldb (byte 16 16) value))) - (setf (sap-ref-16 sap 2) - (maybe-byte-swap-short - (if (logbitp 15 value) (1+ high) high))))) - (:ba - (unless (zerop (ash value -24)) - (warn "#X~8,'0X out of range for branch-absolute." value)) - (let ((inst (maybe-byte-swap-short (sap-ref-16 sap 0)))) + (:jmp-hint + (assert (zerop (ldb (byte 2 0) value))) + #+nil ;; was commented out in cmucl source too. Don't know what + ;; it does -dan 2001.05.03 (setf (sap-ref-16 sap 0) - (maybe-byte-swap-short - (dpb (ldb (byte 8 16) value) - (byte 8 0) - inst)))) - (setf (sap-ref-16 sap 2) - (maybe-byte-swap-short (ldb (byte 16 0) value)))))) - |# + (logior (sap-ref-16 sap 0) (ldb (byte 14 0) (ash value -2))))) + (:bits-63-48 + (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)) + (value (if (logbitp 31 value) (+ value (ash 1 32)) value)) + (value (if (logbitp 47 value) (+ value (ash 1 48)) value))) + (setf (byte-vector-ref-8 gspace-bytes gspace-byte-offset) + (ldb (byte 8 48) value) + (byte-vector-ref-8 gspace-bytes (1+ gspace-byte-offset)) + (ldb (byte 8 56) value)))) + (:bits-47-32 + (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)) + (value (if (logbitp 31 value) (+ value (ash 1 32)) value))) + (setf (byte-vector-ref-8 gspace-bytes gspace-byte-offset) + (ldb (byte 8 32) value) + (byte-vector-ref-8 gspace-bytes (1+ gspace-byte-offset)) + (ldb (byte 8 40) value)))) + (:ldah + (let ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))) + (setf (byte-vector-ref-8 gspace-bytes gspace-byte-offset) + (ldb (byte 8 16) value) + (byte-vector-ref-8 gspace-bytes (1+ gspace-byte-offset)) + (ldb (byte 8 24) value)))) + (:lda + (setf (byte-vector-ref-8 gspace-bytes gspace-byte-offset) + (ldb (byte 8 0) value) + (byte-vector-ref-8 gspace-bytes (1+ gspace-byte-offset)) + (ldb (byte 8 8) value))))) (:x86 (let* ((un-fixed-up (byte-vector-ref-32 gspace-bytes gspace-byte-offset)) (code-object-start-addr (logandc2 (descriptor-bits code-object) sb!vm:lowtag-mask))) - (assert (= code-object-start-addr - (+ gspace-byte-address - (descriptor-byte-offset code-object)))) + (assert (= code-object-start-addr + (+ gspace-byte-address + (descriptor-byte-offset code-object)))) (ecase kind (:absolute (let ((fixed-up (+ value un-fixed-up))) @@ -1649,75 +1644,7 @@ (note-load-time-code-fixup code-object after-header value - kind)))))) - ;; CMU CL supported these, and I haven't gone out of my way to break - ;; them, but I have no way of testing them.. -- WHN 19990817 - #| - (#.sb!c:hppa-fasl-file-implementation - (let ((inst (maybe-byte-swap (sap-ref-32 sap 0)))) - (setf (sap-ref-32 sap 0) - (maybe-byte-swap - (ecase kind - (:load - (logior (ash (ldb (byte 11 0) value) 1) - (logand inst #xffffc000))) - (:load-short - (let ((low-bits (ldb (byte 11 0) value))) - (assert (<= 0 low-bits (1- (ash 1 4)))) - (logior (ash low-bits 17) - (logand inst #xffe0ffff)))) - (:hi - (logior (ash (ldb (byte 5 13) value) 16) - (ash (ldb (byte 2 18) value) 14) - (ash (ldb (byte 2 11) value) 12) - (ash (ldb (byte 11 20) value) 1) - (ldb (byte 1 31) value) - (logand inst #xffe00000))) - (:branch - (let ((bits (ldb (byte 9 2) value))) - (assert (zerop (ldb (byte 2 0) value))) - (logior (ash bits 3) - (logand inst #xffe0e002))))))))) - (#.sb!c:alpha-fasl-file-implementation - (ecase kind - (:jmp-hint - (assert (zerop (ldb (byte 2 0) value))) - #+nil - (setf (sap-ref-16 sap 0) - (logior (sap-ref-16 sap 0) (ldb (byte 14 0) (ash value -2))))) - (:bits-63-48 - (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)) - (value (if (logbitp 31 value) (+ value (ash 1 32)) value)) - (value (if (logbitp 47 value) (+ value (ash 1 48)) value))) - (setf (sap-ref-8 sap 0) (ldb (byte 8 48) value)) - (setf (sap-ref-8 sap 1) (ldb (byte 8 56) value)))) - (:bits-47-32 - (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)) - (value (if (logbitp 31 value) (+ value (ash 1 32)) value))) - (setf (sap-ref-8 sap 0) (ldb (byte 8 32) value)) - (setf (sap-ref-8 sap 1) (ldb (byte 8 40) value)))) - (:ldah - (let ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))) - (setf (sap-ref-8 sap 0) (ldb (byte 8 16) value)) - (setf (sap-ref-8 sap 1) (ldb (byte 8 24) value)))) - (:lda - (setf (sap-ref-8 sap 0) (ldb (byte 8 0) value)) - (setf (sap-ref-8 sap 1) (ldb (byte 8 8) value))))) - (#.sb!c:sgi-fasl-file-implementation - (ecase kind - (:jump - (assert (zerop (ash value -28))) - (setf (ldb (byte 26 0) (sap-ref-32 sap 0)) - (ash value -2))) - (:lui - (setf (sap-ref-16 sap 2) - (+ (ash value -16) - (if (logbitp 15 value) 1 0)))) - (:addi - (setf (sap-ref-16 sap 2) - (ldb (byte 16 0) value))))) - |# - )) + kind)))))) )) (values)) (defun resolve-assembler-fixups () @@ -1758,7 +1685,7 @@ ;;; (2) stores its definition in the *COLD-FOP-FUNCTIONS* vector, ;;; instead of storing in the *FOP-FUNCTIONS* vector. (defmacro define-cold-fop ((name &optional (pushp t)) &rest forms) - (check-type pushp (member nil t :nope)) + (aver (member pushp '(nil t :nope))) (let ((code (get name 'fop-code)) (fname (symbolicate "COLD-" name))) (unless code @@ -1771,7 +1698,7 @@ (setf (svref *cold-fop-functions* ,code) #',fname)))) (defmacro clone-cold-fop ((name &optional (pushp t)) (small-name) &rest forms) - (check-type pushp (member nil t :nope)) + (aver (member pushp '(nil t :nope))) `(progn (macrolet ((clone-arg () '(read-arg 4))) (define-cold-fop (,name ,pushp) ,@forms)) @@ -1784,7 +1711,7 @@ (error "The fop ~S is not supported in cold load." ',name))) ;;; COLD-LOAD loads stuff into the core image being built by calling -;;; FASLOAD with the fop function table rebound to a table of cold +;;; LOAD-AS-FASL with the fop function table rebound to a table of cold ;;; loading functions. (defun cold-load (filename) #!+sb-doc @@ -1795,7 +1722,7 @@ (string filename) (pathname (namestring filename))))) (with-open-file (s filename :element-type '(unsigned-byte 8)) - (fasload s nil nil)))) + (load-as-fasl s nil nil)))) ;;;; miscellaneous cold fops @@ -1860,7 +1787,7 @@ (declare (type index old-length)) (declare (type fixnum old-depthoid)) (declare (type list old-inherits-list)) - (assert (eq name old-name)) + (aver (eq name old-name)) (let ((length (descriptor-fixnum length-des)) (inherits-list (listify-cold-inherits cold-inherits)) (depthoid (descriptor-fixnum depthoid-des))) @@ -2849,7 +2776,7 @@ initially undefined function references:~2%") ;; less expensively (ERROR, not CERROR), and which reports ;; "internal error" on failure. Use it here and elsewhere in the ;; system. - (assert (zerop rem)) + (aver (zerop rem)) (write-long floor)) (write-long pages) @@ -3042,7 +2969,7 @@ initially undefined function references:~2%") ;; much. (And the old CMU CL code is still useful for making ;; sure that the appropriate keywords and internal symbols end ;; up interned in the target Lisp, which is good, e.g. in order - ;; to make keyword arguments work right and in order to make + ;; to make &KEY arguments work right and in order to make ;; BACKTRACEs into target Lisp system code be legible.) (dolist (exported-name (sb-cold:read-from-file "common-lisp-exports.lisp-expr"))