X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffop.lisp;h=6a443622bd19a7d18f46045ecea3a19c69004455;hb=f3f677703e37f5a335b3be7fa64f7748ad969517;hp=2612386b9553d349d8fdbc24ac4295a3427b4ada;hpb=e9840c3696d663a186df1a7e20d15b6caf4aec86;p=sbcl.git diff --git a/src/code/fop.lisp b/src/code/fop.lisp index 2612386..6a44362 100644 --- a/src/code/fop.lisp +++ b/src/code/fop.lisp @@ -49,8 +49,8 @@ ;;; (dump-integer-as-n-bytes total-length 2 file)) ;;; (t ;;; (dump-fop 'sb!impl::fop-code file) -;;; (dump-unsigned-32 num-consts file) -;;; (dump-unsigned-32 total-length file)))) +;;; (dump-word num-consts file) +;;; (dump-word total-length file)))) ;;; in several places. It would be cleaner if this could be replaced with ;;; something like ;;; (dump-fop file fop-code num-consts total-length) @@ -62,26 +62,38 @@ (aver (member pushp '(nil t))) (aver (member stackp '(nil t))) `(progn - (macrolet ((clone-arg () '(read-arg 4))) + (macrolet ((clone-arg () '(read-word-arg))) (define-fop (,name ,code :pushp ,pushp :stackp ,stackp) ,@forms)) - (macrolet ((clone-arg () '(read-arg 1))) + (macrolet ((clone-arg () '(read-byte-arg))) (define-fop (,small-name ,small-code :pushp ,pushp :stackp stackp) ,@forms)))) ;;; a helper function for reading string values from FASL files: sort ;;; of like READ-SEQUENCE specialized for files of (UNSIGNED-BYTE 8), ;;; with an automatic conversion from (UNSIGNED-BYTE 8) into CHARACTER ;;; for each element read -(declaim (ftype (function (stream simple-string &optional index) (values)) read-string-as-bytes)) +(declaim (ftype (function (stream simple-string &optional index) (values)) + read-string-as-bytes #!+sb-unicode read-string-as-words)) (defun read-string-as-bytes (stream string &optional (length (length string))) (dotimes (i length) (setf (aref string i) - (code-char (read-byte stream)))) + (sb!xc:code-char (read-byte stream)))) ;; FIXME: The classic CMU CL code to do this was ;; (READ-N-BYTES FILE STRING START END). ;; It was changed for SBCL because we needed a portable version for ;; bootstrapping. Benchmark the non-portable version and see whether it's ;; significantly better than the portable version here. If it is, then use - ;; add as an alternate definition, protected with #-SB-XC-HOST. + ;; it as an alternate definition, protected with #-SB-XC-HOST. + (values)) +#!+sb-unicode +(defun read-string-as-words (stream string &optional (length (length string))) + #+sb-xc-host (bug "READ-STRING-AS-WORDS called") + (dotimes (i length) + (setf (aref string i) + (let ((code 0)) + ;; FIXME: is this the same as READ-WORD-ARG? + (dotimes (k sb!vm:n-word-bytes (sb!xc:code-char code)) + (setf code (logior code (ash (read-byte stream) + (* k sb!vm:n-byte-bits)))))))) (values)) ;;;; miscellaneous fops @@ -110,8 +122,8 @@ (define-fop (fop-nop 0 :stackp nil)) (define-fop (fop-pop 1 :pushp nil) (push-fop-table (pop-stack))) -(define-fop (fop-push 2) (svref *current-fop-table* (read-arg 4))) -(define-fop (fop-byte-push 3) (svref *current-fop-table* (read-arg 1))) +(define-fop (fop-push 2) (svref *current-fop-table* (read-word-arg))) +(define-fop (fop-byte-push 3) (svref *current-fop-table* (read-byte-arg))) (define-fop (fop-empty-list 4) ()) (define-fop (fop-truth 5) t) @@ -123,28 +135,32 @@ #-sb-xc-host (%primitive sb!c:make-other-immediate-type 0 sb!vm:unbound-marker-widetag)) -;;; CMU CL had FOP-CHARACTER as fop 68, but it's not needed in current -;;; SBCL as we have no extended characters, only 1-byte characters. -;;; (Ditto for CMU CL, actually: FOP-CHARACTER was speculative generality.) -(define-fop (fop-short-character 69) - (code-char (read-arg 1))) +(define-cloned-fops (fop-character 68) (fop-short-character 69) + (code-char (clone-arg))) (define-cloned-fops (fop-struct 48) (fop-small-struct 49) (let* ((size (clone-arg)) (res (%make-instance size))) (declare (type index size)) - (do ((n (1- size) (1- n))) - ((minusp n)) - (declare (type index-or-minus-1 n)) - (setf (%instance-ref res n) (pop-stack))) + (let* ((layout (pop-stack)) + (nuntagged (layout-n-untagged-slots layout)) + (ntagged (- size nuntagged))) + (setf (%instance-ref res 0) layout) + (dotimes (n (1- ntagged)) + (declare (type index n)) + (setf (%instance-ref res (1+ n)) (pop-stack))) + (dotimes (n nuntagged) + (declare (type index n)) + (setf (%raw-instance-ref/word res (- nuntagged n 1)) (pop-stack)))) res)) (define-fop (fop-layout 45) - (let ((length (pop-stack)) + (let ((nuntagged (pop-stack)) + (length (pop-stack)) (depthoid (pop-stack)) (inherits (pop-stack)) (name (pop-stack))) - (find-and-init-or-check-layout name length inherits depthoid))) + (find-and-init-or-check-layout name length inherits depthoid nuntagged))) (define-fop (fop-end-group 64 :stackp nil) (/show0 "THROWing FASL-GROUP-END") @@ -157,7 +173,7 @@ (define-fop (fop-maybe-cold-load 82 :stackp nil)) (define-fop (fop-verify-table-size 62 :stackp nil) - (let ((expected-index (read-arg 4))) + (let ((expected-index (read-word-arg))) (unless (= *current-fop-table-index* expected-index) (bug "fasl table of improper size")))) (define-fop (fop-verify-empty-stack 63 :stackp nil) @@ -166,17 +182,6 @@ ;;;; fops for loading symbols -(defvar *load-symbol-buffer* (make-string 100)) -(declaim (simple-string *load-symbol-buffer*)) -(defvar *load-symbol-buffer-size* 100) -(declaim (type index *load-symbol-buffer-size*)) -;;; FIXME: -;;; (1) *LOAD-SYMBOL-BUFFER-SIZE* is redundant, should just be -;;; (LENGTH *LOAD-SYMBOL-BUFFER*). -;;; (2) *LOAD-SYMBOL-BUFFER* should not have a global value, but should -;;; be bound on entry to FASL loading, and it should be renamed to -;;; *FASL-SYMBOL-BUFFER*. - (macrolet (;; FIXME: Should all this code really be duplicated inside ;; each fop? Perhaps it would be better for this shared ;; code to live in FLET FROB1 and FLET FROB4 (for the @@ -189,18 +194,25 @@ (prepare-for-fast-read-byte *fasl-input-stream* (let ((,n-package ,package) (,n-size (fast-read-u-integer ,name-size))) - (when (> ,n-size *load-symbol-buffer-size*) - (setq *load-symbol-buffer* - (make-string (setq *load-symbol-buffer-size* - (* ,n-size 2))))) + (when (> ,n-size (length *fasl-symbol-buffer*)) + (setq *fasl-symbol-buffer* + (make-string (* ,n-size 2)))) (done-with-fast-read-byte) - (let ((,n-buffer *load-symbol-buffer*)) + (let ((,n-buffer *fasl-symbol-buffer*)) + #+sb-xc-host (read-string-as-bytes *fasl-input-stream* ,n-buffer ,n-size) - (push-fop-table (intern* ,n-buffer - ,n-size - ,n-package))))))))) + #-sb-xc-host + (#!+sb-unicode read-string-as-words + #!-sb-unicode read-string-as-bytes + *fasl-input-stream* + ,n-buffer + ,n-size) + (push-fop-table (without-package-locks + (intern* ,n-buffer + ,n-size + ,n-package)))))))))) ;; Note: CMU CL had FOP-SYMBOL-SAVE and FOP-SMALL-SYMBOL-SAVE, but ;; since they made the behavior of the fasloader depend on the @@ -220,9 +232,9 @@ ;;(frob fop-symbol-save 6 4 *package*) ;;(frob fop-small-symbol-save 7 1 *package*) - (frob fop-lisp-symbol-save 75 4 *cl-package*) + (frob fop-lisp-symbol-save 75 #.sb!vm:n-word-bytes *cl-package*) (frob fop-lisp-small-symbol-save 76 1 *cl-package*) - (frob fop-keyword-symbol-save 77 4 *keyword-package*) + (frob fop-keyword-symbol-save 77 #.sb!vm:n-word-bytes *keyword-package*) (frob fop-keyword-small-symbol-save 78 1 *keyword-package*) ;; FIXME: Because we don't have FOP-SYMBOL-SAVE any more, an enormous number @@ -230,11 +242,11 @@ ;; fasl files. A new ;; FOP-SYMBOL-IN-LAST-PACKAGE-SAVE/FOP-SMALL-SYMBOL-IN-LAST-PACKAGE-SAVE ;; cloned fop pair could undo some of this bloat. - (frob fop-symbol-in-package-save 8 4 - (svref *current-fop-table* (fast-read-u-integer 4))) + (frob fop-symbol-in-package-save 8 #.sb!vm:n-word-bytes + (svref *current-fop-table* (fast-read-u-integer #.sb!vm:n-word-bytes))) (frob fop-small-symbol-in-package-save 9 1 - (svref *current-fop-table* (fast-read-u-integer 4))) - (frob fop-symbol-in-byte-package-save 10 4 + (svref *current-fop-table* (fast-read-u-integer #.sb!vm:n-word-bytes))) + (frob fop-symbol-in-byte-package-save 10 #.sb!vm:n-word-bytes (svref *current-fop-table* (fast-read-u-integer 1))) (frob fop-small-symbol-in-byte-package-save 11 1 (svref *current-fop-table* (fast-read-u-integer 1)))) @@ -243,7 +255,10 @@ (fop-uninterned-small-symbol-save 13) (let* ((arg (clone-arg)) (res (make-string arg))) + #!-sb-unicode (read-string-as-bytes *fasl-input-stream* res) + #!+sb-unicode + (read-string-as-words *fasl-input-stream* res) (push-fop-table (make-symbol res)))) (define-fop (fop-package 14) @@ -271,7 +286,7 @@ (define-fop (fop-word-integer 35) (prepare-for-fast-read-byte *fasl-input-stream* (prog1 - (fast-read-s-integer 4) + (fast-read-s-integer #.sb!vm:n-word-bytes) (done-with-fast-read-byte)))) (define-fop (fop-byte-integer 36) @@ -292,14 +307,7 @@ '(make-single-float (fast-read-s-integer 4))) (fast-read-double-float () '(let ((lo (fast-read-u-integer 4))) - (make-double-float (fast-read-s-integer 4) lo))) - #!+long-float - (fast-read-long-float () - '(let ((lo (fast-read-u-integer 4)) - #!+sparc (mid (fast-read-u-integer 4)) - (hi (fast-read-u-integer 4)) ; XXX - (exp (fast-read-s-integer #!+x86 2 #!+sparc 4))) - (make-long-float exp hi #!+sparc mid lo)))) + (make-double-float (fast-read-s-integer 4) lo)))) (macrolet ((define-complex-fop (name fop-code type) (let ((reader (symbolicate "FAST-READ-" type))) `(define-fop (,name ,fop-code) @@ -328,13 +336,13 @@ (define-fop (fop-list 15) (do ((res () (cons (pop-stack) res)) - (n (read-arg 1) (1- n))) + (n (read-byte-arg) (1- n))) ((zerop n) res) (declare (type index n)))) (define-fop (fop-list* 16) (do ((res (pop-stack) (cons (pop-stack) res)) - (n (read-arg 1) (1- n))) + (n (read-byte-arg) (1- n))) ((zerop n) res) (declare (type index n)))) @@ -362,12 +370,25 @@ ;;;; fops for loading arrays -(define-cloned-fops (fop-string 37) (fop-small-string 38) +(define-cloned-fops (fop-base-string 37) (fop-small-base-string 38) (let* ((arg (clone-arg)) - (res (make-string arg))) + (res (make-string arg :element-type 'base-char))) (read-string-as-bytes *fasl-input-stream* res) res)) +#!+sb-unicode +(progn + #+sb-xc-host + (define-cloned-fops (fop-character-string 161) (fop-small-character-string 162) + (bug "CHARACTER-STRING FOP encountered")) + + #-sb-xc-host + (define-cloned-fops (fop-character-string 161) (fop-small-character-string 162) + (let* ((arg (clone-arg)) + (res (make-string arg))) + (read-string-as-words *fasl-input-stream* res) + res))) + (define-cloned-fops (fop-vector 39) (fop-small-vector 40) (let* ((size (clone-arg)) (res (make-array size))) @@ -378,12 +399,12 @@ res)) (define-fop (fop-array 83) - (let* ((rank (read-arg 4)) + (let* ((rank (read-word-arg)) (vec (pop-stack)) (length (length vec)) (res (make-array-header sb!vm:simple-array-widetag rank))) (declare (simple-array vec) - (type (unsigned-byte 24) rank)) + (type (unsigned-byte #.(- sb!vm:n-word-bits sb!vm:n-widetag-bits)) rank)) (set-array-header res vec length nil 0 (do ((i rank (1- i)) (dimensions () (cons (pop-stack) dimensions))) @@ -393,48 +414,27 @@ res)) (define-fop (fop-single-float-vector 84) - (let* ((length (read-arg 4)) + (let* ((length (read-word-arg)) (result (make-array length :element-type 'single-float))) - (read-n-bytes *fasl-input-stream* result 0 (* length sb!vm:n-word-bytes)) + (read-n-bytes *fasl-input-stream* result 0 (* length 4)) result)) (define-fop (fop-double-float-vector 85) - (let* ((length (read-arg 4)) + (let* ((length (read-word-arg)) (result (make-array length :element-type 'double-float))) - (read-n-bytes *fasl-input-stream* result 0 (* length sb!vm:n-word-bytes 2)) - result)) - -#!+long-float -(define-fop (fop-long-float-vector 88) - (let* ((length (read-arg 4)) - (result (make-array length :element-type 'long-float))) - (read-n-bytes *fasl-input-stream* - result - 0 - (* length sb!vm:n-word-bytes #!+x86 3 #!+sparc 4)) + (read-n-bytes *fasl-input-stream* result 0 (* length 8)) result)) (define-fop (fop-complex-single-float-vector 86) - (let* ((length (read-arg 4)) + (let* ((length (read-word-arg)) (result (make-array length :element-type '(complex single-float)))) - (read-n-bytes *fasl-input-stream* result 0 (* length sb!vm:n-word-bytes 2)) + (read-n-bytes *fasl-input-stream* result 0 (* length 8)) result)) (define-fop (fop-complex-double-float-vector 87) - (let* ((length (read-arg 4)) + (let* ((length (read-word-arg)) (result (make-array length :element-type '(complex double-float)))) - (read-n-bytes *fasl-input-stream* - result - 0 - (* length sb!vm:n-word-bytes 2 2)) - result)) - -#!+long-float -(define-fop (fop-complex-long-float-vector 89) - (let* ((length (read-arg 4)) - (result (make-array length :element-type '(complex long-float)))) - (read-n-bytes *fasl-input-stream* result 0 - (* length sb!vm:n-word-bytes #!+x86 3 #!+sparc 4 2)) + (read-n-bytes *fasl-input-stream* result 0 (* length 16)) result)) ;;; CMU CL comment: @@ -444,7 +444,7 @@ ;;; byte-ordering, allowing us to directly read the bits. (define-fop (fop-int-vector 43) (prepare-for-fast-read-byte *fasl-input-stream* - (let* ((len (fast-read-u-integer 4)) + (let* ((len (fast-read-u-integer #.sb!vm:n-word-bytes)) (size (fast-read-byte)) (res (case size (0 (make-array len :element-type 'nil)) @@ -460,37 +460,50 @@ (31 (prog1 (make-array len :element-type '(unsigned-byte 31)) (setf size 32))) (32 (make-array len :element-type '(unsigned-byte 32))) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + (63 (prog1 (make-array len :element-type '(unsigned-byte 63)) + (setf size 64))) + (64 (make-array len :element-type '(unsigned-byte 64))) (t (bug "losing i-vector element size: ~S" size))))) (declare (type index len)) (done-with-fast-read-byte) (read-n-bytes *fasl-input-stream* res 0 - (ceiling (the index (* size len)) - sb!vm:n-byte-bits)) + (ceiling (the index (* size len)) sb!vm:n-byte-bits)) res))) ;;; This is the same as FOP-INT-VECTOR, except this is for signed ;;; SIMPLE-ARRAYs. (define-fop (fop-signed-int-vector 50) (prepare-for-fast-read-byte *fasl-input-stream* - (let* ((len (fast-read-u-integer 4)) + (let* ((len (fast-read-u-integer #.sb!vm:n-word-bytes)) (size (fast-read-byte)) (res (case size (8 (make-array len :element-type '(signed-byte 8))) (16 (make-array len :element-type '(signed-byte 16))) - (29 (make-array len :element-type '(unsigned-byte 29))) - (30 (make-array len :element-type '(signed-byte 30))) + #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or)) + (29 (prog1 (make-array len :element-type '(unsigned-byte 29)) + (setf size 32))) + #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or)) + (30 (prog1 (make-array len :element-type '(signed-byte 30)) + (setf size 32))) (32 (make-array len :element-type '(signed-byte 32))) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + (60 (prog1 (make-array len :element-type '(unsigned-byte 60)) + (setf size 64))) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + (61 (prog1 (make-array len :element-type '(signed-byte 61)) + (setf size 64))) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + (64 (make-array len :element-type '(signed-byte 64))) (t (bug "losing si-vector element size: ~S" size))))) (declare (type index len)) (done-with-fast-read-byte) (read-n-bytes *fasl-input-stream* res 0 - (ceiling (the index (* (if (or (= size 30) (= size 29)) - 32 ; Adjust for (signed-byte 30) - size) len)) sb!vm:n-byte-bits)) + (ceiling (the index (* size len)) sb!vm:n-byte-bits)) res))) (define-fop (fop-eval 53) @@ -515,7 +528,7 @@ (terpri)))) (define-fop (fop-funcall 55) - (let ((arg (read-arg 1))) + (let ((arg (read-byte-arg))) (if (zerop arg) (funcall (pop-stack)) (do ((args () (cons (pop-stack) args)) @@ -524,7 +537,7 @@ (declare (type index n)))))) (define-fop (fop-funcall-for-effect 56 :pushp nil) - (let ((arg (read-arg 1))) + (let ((arg (read-byte-arg))) (if (zerop arg) (funcall (pop-stack)) (do ((args () (cons (pop-stack) args)) @@ -535,35 +548,35 @@ ;;;; fops for fixing up circularities (define-fop (fop-rplaca 200 :pushp nil) - (let ((obj (svref *current-fop-table* (read-arg 4))) - (idx (read-arg 4)) + (let ((obj (svref *current-fop-table* (read-word-arg))) + (idx (read-word-arg)) (val (pop-stack))) (setf (car (nthcdr idx obj)) val))) (define-fop (fop-rplacd 201 :pushp nil) - (let ((obj (svref *current-fop-table* (read-arg 4))) - (idx (read-arg 4)) + (let ((obj (svref *current-fop-table* (read-word-arg))) + (idx (read-word-arg)) (val (pop-stack))) (setf (cdr (nthcdr idx obj)) val))) (define-fop (fop-svset 202 :pushp nil) - (let* ((obi (read-arg 4)) + (let* ((obi (read-word-arg)) (obj (svref *current-fop-table* obi)) - (idx (read-arg 4)) + (idx (read-word-arg)) (val (pop-stack))) (if (typep obj 'instance) (setf (%instance-ref obj idx) val) (setf (svref obj idx) val)))) (define-fop (fop-structset 204 :pushp nil) - (setf (%instance-ref (svref *current-fop-table* (read-arg 4)) - (read-arg 4)) + (setf (%instance-ref (svref *current-fop-table* (read-word-arg)) + (read-word-arg)) (pop-stack))) ;;; In the original CMUCL code, this actually explicitly declared PUSHP ;;; to be T, even though that's what it defaults to in DEFINE-FOP. (define-fop (fop-nthcdr 203) - (nthcdr (read-arg 4) (pop-stack))) + (nthcdr (read-word-arg) (pop-stack))) ;;;; fops for loading functions @@ -575,10 +588,10 @@ ;;; fasl file header.) (define-fop (fop-code 58 :stackp nil) - (load-code (read-arg 4) (read-arg 4))) + (load-code (read-word-arg) (read-word-arg))) (define-fop (fop-small-code 59 :stackp nil) - (load-code (read-arg 1) (read-arg 2))) + (load-code (read-byte-arg) (read-halfword-arg))) (define-fop (fop-fdefinition 60) (fdefinition-object (pop-stack) t)) @@ -624,7 +637,7 @@ bug.~:@>") (arglist (pop-stack)) (name (pop-stack)) (code-object (pop-stack)) - (offset (read-arg 4))) + (offset (read-word-arg))) (declare (type index offset)) (unless (zerop (logand offset sb!vm:lowtag-mask)) (bug "unaligned function object, offset = #X~X" offset)) @@ -655,24 +668,24 @@ bug.~:@>") ;;;; assemblerish fops +(define-fop (fop-assembler-code 144) + (error "cannot load assembler code except at cold load")) + +(define-fop (fop-assembler-routine 145) + (error "cannot load assembler code except at cold load")) + (define-fop (fop-foreign-fixup 147) (let* ((kind (pop-stack)) (code-object (pop-stack)) - (len (read-arg 1)) - (sym (make-string len))) + (len (read-byte-arg)) + (sym (make-string len :element-type 'base-char))) (read-n-bytes *fasl-input-stream* sym 0 len) (sb!vm:fixup-code-object code-object - (read-arg 4) + (read-word-arg) (foreign-symbol-address-as-integer sym) kind) code-object)) -(define-fop (fop-assembler-code 144) - (error "cannot load assembler code except at cold load")) - -(define-fop (fop-assembler-routine 145) - (error "cannot load assembler code except at cold load")) - (define-fop (fop-assembler-fixup 148) (let ((routine (pop-stack)) (kind (pop-stack)) @@ -680,7 +693,7 @@ bug.~:@>") (multiple-value-bind (value found) (gethash routine *assembler-routines*) (unless found (error "undefined assembler routine: ~S" routine)) - (sb!vm:fixup-code-object code-object (read-arg 4) value kind)) + (sb!vm:fixup-code-object code-object (read-word-arg) value kind)) code-object)) (define-fop (fop-code-object-fixup 149) @@ -689,6 +702,19 @@ bug.~:@>") ;; Note: We don't have to worry about GC moving the code-object after ;; the GET-LISP-OBJ-ADDRESS and before that value is deposited, because ;; we can only use code-object fixups when code-objects don't move. - (sb!vm:fixup-code-object code-object (read-arg 4) + (sb!vm:fixup-code-object code-object (read-word-arg) (get-lisp-obj-address code-object) kind) code-object)) + +#!+linkage-table +(define-fop (fop-foreign-dataref-fixup 150) + (let* ((kind (pop-stack)) + (code-object (pop-stack)) + (len (read-byte-arg)) + (sym (make-string len :element-type 'base-char))) + (read-n-bytes *fasl-input-stream* sym 0 len) + (sb!vm:fixup-code-object code-object + (read-word-arg) + (foreign-symbol-address-as-integer sym t) + kind) + code-object))