X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffop.lisp;h=514d63109242185410b4c66af24bc505e72c762a;hb=78a057624fecd10d0fb2ead4ef02ffc361b1ee22;hp=b5f382b70c28920d19bfe0af25a3da9ceb194805;hpb=f143939b1dbaf38ebd4f92c851fbc4ecddf37af1;p=sbcl.git diff --git a/src/code/fop.lisp b/src/code/fop.lisp index b5f382b..514d631 100644 --- a/src/code/fop.lisp +++ b/src/code/fop.lisp @@ -4,24 +4,19 @@ ;;; Define NAME as a fasl operation, with op-code FOP-CODE. PUSHP ;;; describes what the body does to the fop stack: -;;; :NOPE -;;; The body neither pushes or pops the fop stack. ;;; T ;;; The body might pop the fop stack. The result of the body is ;;; pushed on the fop stack. ;;; NIL ;;; The body might pop the fop stack. The result of the body is ;;; discarded. -;;; -;;; FIXME: Make PUSHP into a &KEY argument accepting a booleana value. -;;; Handle the :PUSHP :NOPE case with a separate :STACKP NIL argument, -;;; meaning "the body doesn't interact with the FOP stack." -(defmacro define-fop ((name fop-code &optional (pushp t)) &rest forms) +;;; STACKP describes whether or not the body interacts with the fop stack. +(defmacro define-fop ((name fop-code &key (pushp t) (stackp t)) &rest forms) `(progn (defun ,name () - ,(if (eq pushp :nope) - `(progn ,@forms) - `(with-fop-stack ,pushp ,@forms))) + ,(if stackp + `(with-fop-stack ,pushp ,@forms) + `(progn ,@forms))) (%define-fop ',name ,fop-code))) (defun %define-fop (name code) @@ -37,7 +32,7 @@ (error "multiple codes for fop name ~S: ~D and ~D" name code ocode))) (setf (svref *fop-names* code) name (get name 'fop-code) code - (svref *fop-functions* code) (symbol-function name)) + (svref *fop-funs* code) (symbol-function name)) (values)) ;;; Define a pair of fops which are identical except that one reads @@ -62,14 +57,15 @@ ;;; Some of this logic is already in DUMP-FOP*, but that still requires the ;;; caller to know that it's a 1-byte-arg/4-byte-arg cloned fop pair, and to ;;; know both the 1-byte-arg and the 4-byte-arg fop names. -- WHN 19990902 -(defmacro define-cloned-fops ((name code &optional (pushp t)) +(defmacro define-cloned-fops ((name code &key (pushp t) (stackp t)) (small-name small-code) &rest forms) - (aver (member pushp '(nil t :nope))) + (aver (member pushp '(nil t))) + (aver (member stackp '(nil t))) `(progn (macrolet ((clone-arg () '(read-arg 4))) - (define-fop (,name ,code ,pushp) ,@forms)) + (define-fop (,name ,code :pushp ,pushp :stackp ,stackp) ,@forms)) (macrolet ((clone-arg () '(read-arg 1))) - (define-fop (,small-name ,small-code ,pushp) ,@forms)))) + (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), @@ -105,15 +101,15 @@ ;;; 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) +(define-fop (fop-nop4 137 :stackp nil) (let ((arg (read-arg 4))) (declare (ignorable arg)) #!+sb-show (when *show-fop-nop4-p* - (format *debug-io* "~&/FOP-NOP4 ARG=~D=#X~X~%" arg arg)))) + (format *debug-io* "~&/FOP-NOP4 ARG=~W=#X~X~%" arg arg)))) -(define-fop (fop-nop 0 :nope)) -(define-fop (fop-pop 1 nil) (push-fop-table (pop-stack))) +(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))) @@ -125,7 +121,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))) @@ -152,22 +148,23 @@ (name (pop-stack))) (find-and-init-or-check-layout name length inherits depthoid))) -(define-fop (fop-end-group 64 :nope) +(define-fop (fop-end-group 64 :stackp nil) + (/show0 "THROWing FASL-GROUP-END") (throw 'fasl-group-end t)) ;;; In the normal loader, we just ignore these. GENESIS overwrites ;;; FOP-MAYBE-COLD-LOAD with something that knows whether to revert to ;;; cold-loading or not. -(define-fop (fop-normal-load 81 :nope)) -(define-fop (fop-maybe-cold-load 82 :nope)) +(define-fop (fop-normal-load 81 :stackp nil)) +(define-fop (fop-maybe-cold-load 82 :stackp nil)) -(define-fop (fop-verify-table-size 62 :nope) +(define-fop (fop-verify-table-size 62 :stackp nil) (let ((expected-index (read-arg 4))) (unless (= *current-fop-table-index* expected-index) - (error "internal error: fasl table of improper size")))) -(define-fop (fop-verify-empty-stack 63 :nope) + (bug "fasl table of improper size")))) +(define-fop (fop-verify-empty-stack 63 :stackp nil) (unless (= *fop-stack-pointer* *fop-stack-pointer-on-entry*) - (error "internal error: fasl stack not empty when it should be"))) + (bug "fasl stack not empty when it should be"))) ;;;; fops for loading symbols @@ -409,7 +406,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 @@ -423,13 +420,13 @@ (define-fop (fop-single-float-vector 84) (let* ((length (read-arg 4)) (result (make-array length :element-type 'single-float))) - (read-n-bytes *fasl-input-stream* 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-input-stream* 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 @@ -439,19 +436,22 @@ (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-input-stream* 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-input-stream* 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 @@ -459,13 +459,14 @@ (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:word-bytes #!+x86 3 #!+sparc 4 2)) + (* 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-input-stream* (let* ((len (fast-read-u-integer 4)) @@ -477,15 +478,14 @@ (8 (make-array len :element-type '(unsigned-byte 8))) (16 (make-array len :element-type '(unsigned-byte 16))) (32 (make-array len :element-type '(unsigned-byte 32))) - (t (error "internal error: losing i-vector element size: ~S" - size))))) + (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:byte-bits)) + sb!vm:n-byte-bits)) res))) ;;; This is the same as FOP-INT-VECTOR, except this is for signed @@ -499,8 +499,7 @@ (16 (make-array len :element-type '(signed-byte 16))) (30 (make-array len :element-type '(signed-byte 30))) (32 (make-array len :element-type '(signed-byte 32))) - (t (error "internal error: losing si-vector element size: ~S" - size))))) + (t (bug "losing si-vector element size: ~S" size))))) (declare (type index len)) (done-with-fast-read-byte) (read-n-bytes *fasl-input-stream* @@ -508,7 +507,7 @@ 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) @@ -523,7 +522,7 @@ ;; fasl loading. result)) -(define-fop (fop-eval-for-effect 54 nil) +(define-fop (fop-eval-for-effect 54 :pushp nil) (let ((result (eval (pop-stack)))) ;; FIXME: See the comment about *LOAD-PRINT* in FOP-EVAL. (declare (ignore result)) @@ -541,7 +540,7 @@ ((zerop n) (apply (pop-stack) args)) (declare (type index n)))))) -(define-fop (fop-funcall-for-effect 56 nil) +(define-fop (fop-funcall-for-effect 56 :pushp nil) (let ((arg (read-arg 1))) (if (zerop arg) (funcall (pop-stack)) @@ -552,19 +551,19 @@ ;;;; fops for fixing up circularities -(define-fop (fop-rplaca 200 nil) +(define-fop (fop-rplaca 200 :pushp nil) (let ((obj (svref *current-fop-table* (read-arg 4))) (idx (read-arg 4)) (val (pop-stack))) (setf (car (nthcdr idx obj)) val))) -(define-fop (fop-rplacd 201 nil) +(define-fop (fop-rplacd 201 :pushp nil) (let ((obj (svref *current-fop-table* (read-arg 4))) (idx (read-arg 4)) (val (pop-stack))) (setf (cdr (nthcdr idx obj)) val))) -(define-fop (fop-svset 202 nil) +(define-fop (fop-svset 202 :pushp nil) (let* ((obi (read-arg 4)) (obj (svref *current-fop-table* obi)) (idx (read-arg 4)) @@ -573,12 +572,14 @@ (setf (%instance-ref obj idx) val) (setf (svref obj idx) val)))) -(define-fop (fop-structset 204 nil) +(define-fop (fop-structset 204 :pushp nil) (setf (%instance-ref (svref *current-fop-table* (read-arg 4)) (read-arg 4)) (pop-stack))) -(define-fop (fop-nthcdr 203 t) +;;; 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))) ;;;; fops for loading functions @@ -590,10 +591,10 @@ ;;; putting the implementation and version in required fields in the ;;; fasl file header.) -(define-fop (fop-code 58 :nope) +(define-fop (fop-code 58 :stackp nil) (load-code (read-arg 4) (read-arg 4))) -(define-fop (fop-small-code 59 :nope) +(define-fop (fop-small-code 59 :stackp nil) (load-code (read-arg 1) (read-arg 2))) (define-fop (fop-fdefinition 60) @@ -604,7 +605,7 @@ (sb!vm:sanctify-for-execution component) component)) -(define-fop (fop-fset 74 nil) +(define-fop (fop-fset 74 :pushp nil) ;; 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 @@ -626,15 +627,15 @@ bug.~:@>") (setf (fdefinition name) fn))) ;;; Modify a slot in a CONSTANTS object. -(define-cloned-fops (fop-alter-code 140 nil) (fop-byte-alter-code 141) +(define-cloned-fops (fop-alter-code 140 :pushp nil) (fop-byte-alter-code 141) (let ((value (pop-stack)) (code (pop-stack))) (setf (code-header-ref code (clone-arg)) value) (values))) -(define-fop (fop-function-entry 142) +(define-fop (fop-fun-entry 142) #+sb-xc-host ; since xc host doesn't know how to compile %PRIMITIVE - (error "FOP-FUNCTION-ENTRY can't be defined without %PRIMITIVE.") + (error "FOP-FUN-ENTRY can't be defined without %PRIMITIVE.") #-sb-xc-host (let ((type (pop-stack)) (arglist (pop-stack)) @@ -643,9 +644,8 @@ bug.~:@>") (offset (read-arg 4))) (declare (type index offset)) (unless (zerop (logand offset sb!vm:lowtag-mask)) - (error "internal error: unaligned function object, offset = #X~X" - offset)) - (let ((fun (%primitive sb!c:compute-function code-object offset))) + (bug "unaligned function object, offset = #X~X" offset)) + (let ((fun (%primitive sb!c:compute-fun code-object offset))) (setf (%simple-fun-self fun) fun) (setf (%simple-fun-next fun) (%code-entry-points code-object)) (setf (%code-entry-points code-object) fun)