X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffop.lisp;h=9891b4690dfd1f599c2d5077a244aaedfe503743;hb=65b5ab7e713d04e0d76bc0ee196374f6e57b922f;hp=c021a01a80a4395512263511777b4f73896c5f4b;hpb=0aecc2b20142e08068c3434273500131cb13fe2d;p=sbcl.git diff --git a/src/code/fop.lisp b/src/code/fop.lisp index c021a01..9891b46 100644 --- a/src/code/fop.lisp +++ b/src/code/fop.lisp @@ -2,6 +2,12 @@ (in-package "SB!FASL") +;;; Sometimes we want to skip over any FOPs with side-effects (like +;;; function calls) while executing other FOPs. *SKIP-UNTIL* will +;;; either contain the position where the skipping will stop, or +;;; NIL if we're executing normally. +(defvar *skip-until* nil) + ;;; Define NAME as a fasl operation, with op-code FOP-CODE. PUSHP ;;; describes what the body does to the fop stack: ;;; T @@ -65,14 +71,15 @@ (macrolet ((clone-arg () '(read-word-arg))) (define-fop (,name ,code :pushp ,pushp :stackp ,stackp) ,@forms)) (macrolet ((clone-arg () '(read-byte-arg))) - (define-fop (,small-name ,small-code :pushp ,pushp :stackp stackp) ,@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), ;;; 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 #!+sb-unicode read-string-as-words)) + read-string-as-bytes + #!+sb-unicode read-string-as-unsigned-byte-32)) (defun read-string-as-bytes (stream string &optional (length (length string))) (dotimes (i length) (setf (aref string i) @@ -85,13 +92,13 @@ ;; 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") +(defun read-string-as-unsigned-byte-32 + (stream string &optional (length (length string))) + #+sb-xc-host (bug "READ-STRING-AS-UNSIGNED-BYTE-32 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)) + (dotimes (k 4 (sb!xc:code-char code)) (setf code (logior code (ash (read-byte stream) (* k sb!vm:n-byte-bits)))))))) (values)) @@ -166,11 +173,9 @@ (/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 :stackp nil)) -(define-fop (fop-maybe-cold-load 82 :stackp nil)) +;;; We used to have FOP-NORMAL-LOAD as 81 and FOP-MAYBE-COLD-LOAD as +;;; 82 until GENESIS learned how to work with host symbols and +;;; packages directly instead of piggybacking on the host code. (define-fop (fop-verify-table-size 62 :stackp nil) (let ((expected-index (read-word-arg))) @@ -204,7 +209,7 @@ ,n-buffer ,n-size) #-sb-xc-host - (#!+sb-unicode read-string-as-words + (#!+sb-unicode read-string-as-unsigned-byte-32 #!-sb-unicode read-string-as-bytes *fasl-input-stream* ,n-buffer @@ -258,11 +263,23 @@ #!-sb-unicode (read-string-as-bytes *fasl-input-stream* res) #!+sb-unicode - (read-string-as-words *fasl-input-stream* res) + (read-string-as-unsigned-byte-32 *fasl-input-stream* res) (push-fop-table (make-symbol res)))) (define-fop (fop-package 14) (find-undeleted-package-or-lose (pop-stack))) + +(define-cloned-fops (fop-named-package-save 156 :stackp nil) + (fop-small-named-package-save 157) + (let* ((arg (clone-arg)) + (package-name (make-string arg))) + #+sb-xc-host + (read-string-as-bytes *fasl-input-stream* package-name) + #-sb-xc-host + (#!-sb-unicode read-string-as-bytes + #!+sb-unicode read-string-as-unsigned-byte-32 + *fasl-input-stream* package-name) + (push-fop-table (find-undeleted-package-or-lose package-name)))) ;;;; fops for loading numbers @@ -386,7 +403,7 @@ (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) + (read-string-as-unsigned-byte-32 *fasl-input-stream* res) res))) (define-cloned-fops (fop-vector 39) (fop-small-vector 40) @@ -410,7 +427,8 @@ (dimensions () (cons (pop-stack) dimensions))) ((zerop i) dimensions) (declare (type index i))) - nil) + nil + t) res)) (define-fop (fop-single-float-vector 84) @@ -507,43 +525,53 @@ res))) (define-fop (fop-eval 53) - (let ((result (eval (pop-stack)))) - ;; FIXME: CMU CL had this code here: - ;; (when *load-print* - ;; (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 - ;; fasl loading. - result)) + (if *skip-until* + (pop-stack) + (let ((result (eval (pop-stack)))) + ;; FIXME: CMU CL had this code here: + ;; (when *load-print* + ;; (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 + ;; fasl loading. + result))) (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)) - #+nil (when *load-print* - (load-fresh-line) - (prin1 result) - (terpri)))) + (if *skip-until* + (pop-stack) + (let ((result (eval (pop-stack)))) + ;; FIXME: See the comment about *LOAD-PRINT* in FOP-EVAL. + (declare (ignore result)) + #+nil (when *load-print* + (load-fresh-line) + (prin1 result) + (terpri))))) (define-fop (fop-funcall 55) (let ((arg (read-byte-arg))) - (if (zerop arg) - (funcall (pop-stack)) - (do ((args () (cons (pop-stack) args)) - (n arg (1- n))) - ((zerop n) (apply (pop-stack) args)) - (declare (type index n)))))) + (if *skip-until* + (dotimes (i (1+ arg)) + (pop-stack)) + (if (zerop arg) + (funcall (pop-stack)) + (do ((args () (cons (pop-stack) args)) + (n arg (1- n))) + ((zerop n) (apply (pop-stack) args)) + (declare (type index n))))))) (define-fop (fop-funcall-for-effect 56 :pushp nil) (let ((arg (read-byte-arg))) - (if (zerop arg) - (funcall (pop-stack)) - (do ((args () (cons (pop-stack) args)) - (n arg (1- n))) - ((zerop n) (apply (pop-stack) args)) - (declare (type index n)))))) + (if *skip-until* + (dotimes (i (1+ arg)) + (pop-stack)) + (if (zerop arg) + (funcall (pop-stack)) + (do ((args () (cons (pop-stack) args)) + (n arg (1- n))) + ((zerop n) (apply (pop-stack) args)) + (declare (type index n))))))) ;;;; fops for fixing up circularities @@ -622,6 +650,17 @@ bug.~:@>") (name (pop-stack))) (setf (fdefinition name) fn))) +(define-fop (fop-note-debug-source 174 :pushp nil) + (warn "~@") + ;; as with COLD-FSET above, we are going to be lenient with coming + ;; across this fop in a warm SBCL. + (let ((debug-source (pop-stack))) + (setf (sb!c::debug-source-compiled debug-source) (get-universal-time) + (sb!c::debug-source-created debug-source) + (file-write-date (sb!c::debug-source-namestring debug-source))))) + ;;; Modify a slot in a CONSTANTS object. (define-cloned-fops (fop-alter-code 140 :pushp nil) (fop-byte-alter-code 141) (let ((value (pop-stack)) @@ -633,7 +672,8 @@ bug.~:@>") #+sb-xc-host ; since xc host doesn't know how to compile %PRIMITIVE (error "FOP-FUN-ENTRY can't be defined without %PRIMITIVE.") #-sb-xc-host - (let ((type (pop-stack)) + (let ((info (pop-stack)) + (type (pop-stack)) (arglist (pop-stack)) (name (pop-stack)) (code-object (pop-stack)) @@ -648,6 +688,7 @@ bug.~:@>") (setf (%simple-fun-name fun) name) (setf (%simple-fun-arglist fun) arglist) (setf (%simple-fun-type fun) type) + (setf (%simple-fun-info fun) info) ;; FIXME: See the comment about *LOAD-PRINT* in FOP-EVAL. #+nil (when *load-print* (load-fresh-line) @@ -718,3 +759,46 @@ bug.~:@>") (foreign-symbol-address sym t) kind) code-object)) + +;;; FOPs needed for implementing an IF operator in a FASL + +;;; Skip until a FOP-MAYBE-STOP-SKIPPING with the same POSITION is +;;; executed. While skipping, we execute most FOPs normally, except +;;; for ones that a) funcall/eval b) start skipping. This needs to +;;; be done to ensure that the fop table gets populated correctly +;;; regardless of the execution path. +(define-fop (fop-skip 151 :pushp nil) + (let ((position (pop-stack))) + (unless *skip-until* + (setf *skip-until* position))) + (values)) + +;;; As before, but only start skipping if the top of the FOP stack is NIL. +(define-fop (fop-skip-if-false 152 :pushp nil) + (let ((condition (pop-stack)) + (position (pop-stack))) + (unless (or condition + *skip-until*) + (setf *skip-until* position))) + (values)) + +;;; If skipping, pop the top of the stack and discard it. Needed for +;;; ensuring that the stack stays balanced when skipping. +(define-fop (fop-drop-if-skipping 153 :pushp nil) + (when *skip-until* + (pop-stack)) + (values)) + +;;; If skipping, push a dummy value on the stack. Needed for +;;; ensuring that the stack stays balanced when skipping. +(define-fop (fop-push-nil-if-skipping 154 :pushp nil) + (when *skip-until* + (push-stack nil)) + (values)) + +;;; Stop skipping if the top of the stack matches *SKIP-UNTIL* +(define-fop (fop-maybe-stop-skipping 155 :pushp nil) + (let ((label (pop-stack))) + (when (eql *skip-until* label) + (setf *skip-until* nil))) + (values))