X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffop.lisp;h=37e79cee8aedd0d9d0755f3ca03880b0d4db555a;hb=80f222325e1f677e5cf8de01c6990906fa47f65d;hp=ea2ceef191cd999e70cb7be8cc3d4a96a27447f8;hpb=ec2616d216958a608581802c47496c0194478dc8;p=sbcl.git diff --git a/src/code/fop.lisp b/src/code/fop.lisp index ea2ceef..37e79ce 100644 --- a/src/code/fop.lisp +++ b/src/code/fop.lisp @@ -37,7 +37,7 @@ ;;; Define a pair of fops which are identical except that one reads ;;; a four-byte argument while the other reads a one-byte argument. The -;;; argument can be accessed by using the Clone-Arg macro. +;;; argument can be accessed by using the CLONE-ARG macro. ;;; ;;; KLUDGE: It would be nice if the definition here encapsulated which ;;; value ranges went with which fop variant, and chose the correct @@ -123,8 +123,6 @@ #-sb-xc-host (%primitive sb!c:make-other-immediate-type 0 sb!vm:unbound-marker-widetag)) -(define-fop (fop-character 68) - (code-char (read-arg 3))) ;;; 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.) @@ -163,22 +161,11 @@ (unless (= *current-fop-table-index* expected-index) (bug "fasl table of improper size")))) (define-fop (fop-verify-empty-stack 63 :stackp nil) - (unless (= *fop-stack-pointer* *fop-stack-pointer-on-entry*) + (unless (zerop (length *fop-stack*)) (bug "fasl stack not empty when it should be"))) ;;;; 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 @@ -191,18 +178,18 @@ (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*)) (read-string-as-bytes *fasl-input-stream* ,n-buffer ,n-size) - (push-fop-table (intern* ,n-buffer - ,n-size - ,n-package))))))))) + (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 @@ -290,64 +277,34 @@ (let ((im (pop-stack))) (%make-complex (pop-stack) im))) -(define-fop (fop-complex-single-float 72) - (prepare-for-fast-read-byte *fasl-input-stream* - (prog1 - (complex (make-single-float (fast-read-s-integer 4)) - (make-single-float (fast-read-s-integer 4))) - (done-with-fast-read-byte)))) - -(define-fop (fop-complex-double-float 73) - (prepare-for-fast-read-byte *fasl-input-stream* - (prog1 - (let* ((re-lo (fast-read-u-integer 4)) - (re-hi (fast-read-u-integer 4)) - (re (make-double-float re-hi re-lo)) - (im-lo (fast-read-u-integer 4)) - (im-hi (fast-read-u-integer 4)) - (im (make-double-float im-hi im-lo))) - (complex re im)) - (done-with-fast-read-byte)))) - -#!+long-float -(define-fop (fop-complex-long-float 67) - (prepare-for-fast-read-byte *fasl-input-stream* - (prog1 - (let* ((re-lo (fast-read-u-integer 4)) - #!+sparc (re-mid (fast-read-u-integer 4)) - (re-hi (fast-read-u-integer 4)) - (re-exp (fast-read-s-integer #!+x86 2 #!+sparc 4)) - (re (make-long-float re-exp re-hi #!+sparc re-mid re-lo)) - (im-lo (fast-read-u-integer 4)) - #!+sparc (im-mid (fast-read-u-integer 4)) - (im-hi (fast-read-u-integer 4)) - (im-exp (fast-read-s-integer #!+x86 2 #!+sparc 4)) - (im (make-long-float im-exp im-hi #!+sparc im-mid im-lo))) - (complex re im)) - (done-with-fast-read-byte)))) - -(define-fop (fop-single-float 46) - (prepare-for-fast-read-byte *fasl-input-stream* - (prog1 (make-single-float (fast-read-s-integer 4)) - (done-with-fast-read-byte)))) - -(define-fop (fop-double-float 47) - (prepare-for-fast-read-byte *fasl-input-stream* - (prog1 - (let ((lo (fast-read-u-integer 4))) - (make-double-float (fast-read-s-integer 4) lo)) - (done-with-fast-read-byte)))) +(macrolet ((fast-read-single-float () + '(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)))) + (macrolet ((define-complex-fop (name fop-code type) + (let ((reader (symbolicate "FAST-READ-" type))) + `(define-fop (,name ,fop-code) + (prepare-for-fast-read-byte *fasl-input-stream* + (prog1 + (complex (,reader) (,reader)) + (done-with-fast-read-byte)))))) + (define-float-fop (name fop-code type) + (let ((reader (symbolicate "FAST-READ-" type))) + `(define-fop (,name ,fop-code) + (prepare-for-fast-read-byte *fasl-input-stream* + (prog1 + (,reader) + (done-with-fast-read-byte))))))) + (define-complex-fop fop-complex-single-float 72 single-float) + (define-complex-fop fop-complex-double-float 73 double-float) + #!+long-float + (define-complex-fop fop-complex-long-float 67 long-float) + (define-float-fop fop-single-float 46 single-float) + (define-float-fop fop-double-float 47 double-float) + #!+long-float + (define-float-fop fop-long-float 52 long-float))) -#!+long-float -(define-fop (fop-long-float 52) - (prepare-for-fast-read-byte *fasl-input-stream* - (prog1 - (let ((lo (fast-read-u-integer 4)) - #!+sparc (mid (fast-read-u-integer 4)) - (hi (fast-read-u-integer 4)) - (exp (fast-read-s-integer #!+x86 2 #!+sparc 4))) - (make-long-float exp hi #!+sparc mid lo)) - (done-with-fast-read-byte)))) ;;;; loading lists @@ -365,7 +322,7 @@ (macrolet ((frob (name op fun n) `(define-fop (,name ,op) - (call-with-popped-things ,fun ,n)))) + (call-with-popped-args ,fun ,n)))) (frob fop-list-1 17 list 1) (frob fop-list-2 18 list 2) @@ -409,7 +366,7 @@ (res (make-array-header sb!vm:simple-array-widetag rank))) (declare (simple-array vec) (type (unsigned-byte 24) rank)) - (set-array-header res vec length length 0 + (set-array-header res vec length nil 0 (do ((i rank (1- i)) (dimensions () (cons (pop-stack) dimensions))) ((zerop i) dimensions) @@ -429,16 +386,6 @@ (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)) - result)) - (define-fop (fop-complex-single-float-vector 86) (let* ((length (read-arg 4)) (result (make-array length :element-type '(complex single-float)))) @@ -454,14 +401,6 @@ (* 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)) - result)) - ;;; CMU CL comment: ;;; *** NOT *** the FOP-INT-VECTOR as currently documented in rtguts. ;;; Size must be a directly supported I-vector element size, with no @@ -472,11 +411,18 @@ (let* ((len (fast-read-u-integer 4)) (size (fast-read-byte)) (res (case size + (0 (make-array len :element-type 'nil)) (1 (make-array len :element-type 'bit)) (2 (make-array len :element-type '(unsigned-byte 2))) (4 (make-array len :element-type '(unsigned-byte 4))) + (7 (prog1 (make-array len :element-type '(unsigned-byte 7)) + (setf size 8))) (8 (make-array len :element-type '(unsigned-byte 8))) + (15 (prog1 (make-array len :element-type '(unsigned-byte 15)) + (setf size 16))) (16 (make-array len :element-type '(unsigned-byte 16))) + (31 (prog1 (make-array len :element-type '(unsigned-byte 31)) + (setf size 32))) (32 (make-array len :element-type '(unsigned-byte 32))) (t (bug "losing i-vector element size: ~S" size))))) (declare (type index len)) @@ -497,6 +443,7 @@ (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))) (32 (make-array len :element-type '(signed-byte 32))) (t (bug "losing si-vector element size: ~S" size))))) @@ -505,7 +452,7 @@ (read-n-bytes *fasl-input-stream* res 0 - (ceiling (the index (* (if (= size 30) + (ceiling (the index (* (if (or (= size 30) (= size 29)) 32 ; Adjust for (signed-byte 30) size) len)) sb!vm:n-byte-bits)) res)))