X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffop.lisp;h=d52941af2d0ae99b8125f54862561d1a9dd2c547;hb=913e06f191acb65c1d99d42234704bec38500ff4;hp=b47aa4ee985a9aa4b9cfc7244d0fcc526668a6f1;hpb=02ce4b1b927f1312c300047bd5a0db6663a1d2c6;p=sbcl.git diff --git a/src/code/fop.lisp b/src/code/fop.lisp index b47aa4e..d52941a 100644 --- a/src/code/fop.lisp +++ b/src/code/fop.lisp @@ -1,6 +1,6 @@ ;;;; FOP definitions -(in-package "SB!IMPL") +(in-package "SB!FASL") ;;; Define NAME as a fasl operation, with op-code FOP-CODE. PUSHP ;;; describes what the body does to the fop stack: @@ -24,7 +24,6 @@ `(with-fop-stack ,pushp ,@forms))) (%define-fop ',name ,fop-code))) -;;; FIXME: This can be byte coded. (defun %define-fop (name code) (let ((oname (svref *fop-names* code))) (when (and oname (not (eq oname name))) @@ -65,16 +64,17 @@ ;;; know both the 1-byte-arg and the 4-byte-arg fop names. -- WHN 19990902 (defmacro define-cloned-fops ((name code &optional (pushp t)) (small-name small-code) &rest forms) - (check-type pushp (member nil t :nope)) + (aver (member pushp '(nil t :nope))) `(progn (macrolet ((clone-arg () '(read-arg 4))) (define-fop (,name ,code ,pushp) ,@forms)) (macrolet ((clone-arg () '(read-arg 1))) (define-fop (,small-name ,small-code ,pushp) ,@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 +;;; 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)) (defun read-string-as-bytes (stream string &optional (length (length string))) (dotimes (i length) @@ -95,15 +95,16 @@ ;;; Setting this variable causes execution of a FOP-NOP4 to produce ;;; output to *DEBUG-IO*. This can be handy when trying to follow the -;;; progress of FASLOAD. +;;; progress of FASL loading. #!+sb-show (defvar *show-fop-nop4-p* nil) -;;; CMU CL had a single no-op fop, FOP-NOP, with fop code 0. Since 0 occurs -;;; disproportionately often in fasl files for other reasons, FOP-NOP is less -;;; than ideal for writing human-readable patterns into fasl files for -;;; debugging purposes. There's no shortage of unused fop codes, so we add this -;;; second NOP, which reads 4 arbitrary bytes and discards them. +;;; CMU CL had a single no-op fop, FOP-NOP, with fop code 0. Since 0 +;;; occurs disproportionately often in fasl files for other reasons, +;;; FOP-NOP is less than ideal for writing human-readable patterns +;;; into fasl files for debugging purposes. There's no shortage of +;;; unused fop codes, so we add this second NOP, which reads 4 +;;; arbitrary bytes and discards them. (define-fop (fop-nop4 137 :nope) (let ((arg (read-arg 4))) (declare (ignorable arg)) @@ -124,7 +125,7 @@ #+sb-xc-host ; since xc host doesn't know how to compile %PRIMITIVE (error "FOP-MISC-TRAP can't be defined without %PRIMITIVE.") #-sb-xc-host - (%primitive sb!c:make-other-immediate-type 0 sb!vm:unbound-marker-type)) + (%primitive sb!c:make-other-immediate-type 0 sb!vm:unbound-marker-widetag)) (define-fop (fop-character 68) (code-char (read-arg 3))) @@ -178,8 +179,8 @@ ;;; (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 FASLOAD, and it should be renamed to -;;; *FASLOAD-SYMBOL-BUFFER*. +;;; 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 @@ -190,7 +191,7 @@ (n-size (gensym)) (n-buffer (gensym))) `(define-fop (,name ,code) - (prepare-for-fast-read-byte *fasl-file* + (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*) @@ -199,7 +200,7 @@ (* ,n-size 2))))) (done-with-fast-read-byte) (let ((,n-buffer *load-symbol-buffer*)) - (read-string-as-bytes *fasl-file* + (read-string-as-bytes *fasl-input-stream* ,n-buffer ,n-size) (push-fop-table (intern* ,n-buffer @@ -247,7 +248,7 @@ (fop-uninterned-small-symbol-save 13) (let* ((arg (clone-arg)) (res (make-string arg))) - (read-string-as-bytes *fasl-file* res) + (read-string-as-bytes *fasl-input-stream* res) (push-fop-table (make-symbol res)))) (define-fop (fop-package 14) @@ -255,12 +256,12 @@ ;;;; fops for loading numbers -;;; Load a signed integer LENGTH bytes long from *FASL-FILE*. +;;; Load a signed integer LENGTH bytes long from *FASL-INPUT-STREAM*. (defun load-s-integer (length) (declare (fixnum length)) ;; #+cmu (declare (optimize (inhibit-warnings 2))) (do* ((index length (1- index)) - (byte 0 (read-byte *fasl-file*)) + (byte 0 (read-byte *fasl-input-stream*)) (result 0 (+ result (ash byte bits))) (bits 0 (+ bits 8))) ((= index 0) @@ -273,13 +274,13 @@ (load-s-integer (clone-arg))) (define-fop (fop-word-integer 35) - (prepare-for-fast-read-byte *fasl-file* + (prepare-for-fast-read-byte *fasl-input-stream* (prog1 (fast-read-s-integer 4) (done-with-fast-read-byte)))) (define-fop (fop-byte-integer 36) - (prepare-for-fast-read-byte *fasl-file* + (prepare-for-fast-read-byte *fasl-input-stream* (prog1 (fast-read-s-integer 1) (done-with-fast-read-byte)))) @@ -293,14 +294,14 @@ (%make-complex (pop-stack) im))) (define-fop (fop-complex-single-float 72) - (prepare-for-fast-read-byte *fasl-file* + (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-file* + (prepare-for-fast-read-byte *fasl-input-stream* (prog1 (let* ((re-lo (fast-read-u-integer 4)) (re-hi (fast-read-u-integer 4)) @@ -313,7 +314,7 @@ #!+long-float (define-fop (fop-complex-long-float 67) - (prepare-for-fast-read-byte *fasl-file* + (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)) @@ -329,12 +330,12 @@ (done-with-fast-read-byte)))) (define-fop (fop-single-float 46) - (prepare-for-fast-read-byte *fasl-file* + (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-file* + (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)) @@ -342,7 +343,7 @@ #!+long-float (define-fop (fop-long-float 52) - (prepare-for-fast-read-byte *fasl-file* + (prepare-for-fast-read-byte *fasl-input-stream* (prog1 (let ((lo (fast-read-u-integer 4)) #!+sparc (mid (fast-read-u-integer 4)) @@ -392,7 +393,7 @@ (define-cloned-fops (fop-string 37) (fop-small-string 38) (let* ((arg (clone-arg)) (res (make-string arg))) - (read-string-as-bytes *fasl-file* res) + (read-string-as-bytes *fasl-input-stream* res) res)) (define-cloned-fops (fop-vector 39) (fop-small-vector 40) @@ -408,7 +409,7 @@ (let* ((rank (read-arg 4)) (vec (pop-stack)) (length (length vec)) - (res (make-array-header sb!vm:simple-array-type rank))) + (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 @@ -422,51 +423,55 @@ (define-fop (fop-single-float-vector 84) (let* ((length (read-arg 4)) (result (make-array length :element-type 'single-float))) - (read-n-bytes *fasl-file* result 0 (* length sb!vm:word-bytes)) + (read-n-bytes *fasl-input-stream* result 0 (* length sb!vm:n-word-bytes)) result)) (define-fop (fop-double-float-vector 85) (let* ((length (read-arg 4)) (result (make-array length :element-type 'double-float))) - (read-n-bytes *fasl-file* result 0 (* length sb!vm:word-bytes 2)) + (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-file* + (read-n-bytes *fasl-input-stream* result 0 - (* length sb!vm:word-bytes #!+x86 3 #!+sparc 4)) + (* 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)))) - (read-n-bytes *fasl-file* result 0 (* length sb!vm:word-bytes 2)) + (read-n-bytes *fasl-input-stream* result 0 (* length sb!vm:n-word-bytes 2)) result)) (define-fop (fop-complex-double-float-vector 87) (let* ((length (read-arg 4)) (result (make-array length :element-type '(complex double-float)))) - (read-n-bytes *fasl-file* result 0 (* length sb!vm:word-bytes 2 2)) + (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-file* result 0 - (* length sb!vm:word-bytes #!+x86 3 #!+sparc 4 2)) + (read-n-bytes *fasl-input-stream* result 0 + (* length sb!vm:n-word-bytes #!+x86 3 #!+sparc 4 2)) result)) -;;; *** NOT *** the FOP-INT-VECTOR as currently documented in rtguts. Size -;;; must be a directly supported I-vector element size, with no extra bits. -;;; This must be packed according to the local byte-ordering, allowing us to -;;; directly read the bits. +;;; 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 +;;; extra bits. This must be packed according to the local +;;; byte-ordering, allowing us to directly read the bits. (define-fop (fop-int-vector 43) - (prepare-for-fast-read-byte *fasl-file* + (prepare-for-fast-read-byte *fasl-input-stream* (let* ((len (fast-read-u-integer 4)) (size (fast-read-byte)) (res (case size @@ -480,19 +485,17 @@ size))))) (declare (type index len)) (done-with-fast-read-byte) - (read-n-bytes *fasl-file* + (read-n-bytes *fasl-input-stream* res 0 (ceiling (the index (* size len)) - sb!vm:byte-bits)) + sb!vm:n-byte-bits)) res))) -;;; FOP-SIGNED-INT-VECTOR -;;; -;;; Same as FOP-INT-VECTOR, except this is for signed simple-arrays. -;;; It appears that entry 50 and 51 are clear. +;;; 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-file* + (prepare-for-fast-read-byte *fasl-input-stream* (let* ((len (fast-read-u-integer 4)) (size (fast-read-byte)) (res (case size @@ -504,12 +507,12 @@ size))))) (declare (type index len)) (done-with-fast-read-byte) - (read-n-bytes *fasl-file* + (read-n-bytes *fasl-input-stream* res 0 (ceiling (the index (* (if (= size 30) 32 ; Adjust for (signed-byte 30) - size) len)) sb!vm:byte-bits)) + size) len)) sb!vm:n-byte-bits)) res))) (define-fop (fop-eval 53) @@ -519,8 +522,9 @@ ;; (load-fresh-line) ;; (prin1 result) ;; (terpri)) - ;; Unfortunately, this dependence on the *LOAD-PRINT* global variable is - ;; non-ANSI, so for now we've just punted printing in fasload. + ;; Unfortunately, this dependence on the *LOAD-PRINT* global + ;; variable is non-ANSI, so for now we've just punted printing in + ;; fasl loading. result)) (define-fop (fop-eval-for-effect 54 nil) @@ -604,14 +608,28 @@ (sb!vm:sanctify-for-execution component) component)) -;;; This a no-op except in cold load. (In ordinary warm load, -;;; everything involved with function definition can be handled nicely -;;; by ordinary toplevel code.) (define-fop (fop-fset 74 nil) - (pop-stack) - (pop-stack)) + ;; Ordinary, not-for-cold-load code shouldn't need to mess with this + ;; at all, since it's only used as part of the conspiracy between + ;; the cross-compiler and GENESIS to statically link FDEFINITIONs + ;; for cold init. + (warn "~@") + ;; Unlike CMU CL, we don't treat this as a no-op in ordinary code. + ;; If the user (or, more likely, developer) is trying to reload + ;; compiled-for-cold-load code into a warm SBCL, we'll do a warm + ;; assignment. (This is partly for abstract tidiness, since the warm + ;; assignment is the closest analogy to what happens at cold load, + ;; and partly because otherwise our compiled-for-cold-load code will + ;; fail, since in SBCL things like compiled-for-cold-load %DEFUN + ;; depend more strongly than in CMU CL on FOP-FSET actually doing + ;; something.) + (let ((fn (pop-stack)) + (name (pop-stack))) + (setf (fdefinition name) fn))) -;;; Modify a slot in a Constants object. +;;; Modify a slot in a CONSTANTS object. (define-cloned-fops (fop-alter-code 140 nil) (fop-byte-alter-code 141) (let ((value (pop-stack)) (code (pop-stack))) @@ -632,37 +650,21 @@ (error "internal error: unaligned function object, offset = #X~X" offset)) (let ((fun (%primitive sb!c:compute-function code-object offset))) - (setf (%function-self fun) fun) - (setf (%function-next fun) (%code-entry-points code-object)) + (setf (%simple-fun-self fun) fun) + (setf (%simple-fun-next fun) (%code-entry-points code-object)) (setf (%code-entry-points code-object) fun) - (setf (%function-name fun) name) - (setf (%function-arglist fun) arglist) - (setf (%function-type fun) type) + (setf (%simple-fun-name fun) name) + (setf (%simple-fun-arglist fun) arglist) + (setf (%simple-fun-type fun) type) ;; FIXME: See the comment about *LOAD-PRINT* in FOP-EVAL. #+nil (when *load-print* (load-fresh-line) (format t "~S defined~%" fun)) fun))) - -(define-fop (fop-make-byte-compiled-function 143) - (let* ((size (read-arg 1)) - (layout (pop-stack)) - (res (%make-funcallable-instance size layout))) - (declare (type index size)) - (do ((n (1- size) (1- n))) - ((minusp n)) - (declare (type (integer -1 #.most-positive-fixnum) n)) - (setf (%funcallable-instance-info res n) (pop-stack))) - (initialize-byte-compiled-function res) - ;; FIXME: See the comment about *LOAD-PRINT* in FOP-EVAL. - #+nil (when *load-print* - (load-fresh-line) - (format t "~S defined~%" res)) - res)) -;;;; Some Dylan fops used to live here. By 1 November 1998 the code was -;;;; sufficiently stale that the functions it called were no longer defined, -;;;; so I (William Harold Newman) deleted it. +;;;; Some Dylan FOPs used to live here. By 1 November 1998 the code +;;;; was sufficiently stale that the functions it called were no +;;;; longer defined, so I (William Harold Newman) deleted it. ;;;; ;;;; In case someone in the future is trying to make sense of FOP layout, ;;;; it might be worth recording that the Dylan FOPs were @@ -679,7 +681,7 @@ (code-object (pop-stack)) (len (read-arg 1)) (sym (make-string len))) - (read-n-bytes *fasl-file* sym 0 len) + (read-n-bytes *fasl-input-stream* sym 0 len) (sb!vm:fixup-code-object code-object (read-arg 4) (foreign-symbol-address-as-integer sym)