X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffop.lisp;h=d9acdd5f6349798894791c04a18e32d18c901751;hb=a160917364f85b38dc0826a5e3dcef87e3c4c62c;hp=712e0824cea7a47d4778027ed2630a3d7d20dffd;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/src/code/fop.lisp b/src/code/fop.lisp index 712e082..d9acdd5 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)) @@ -204,7 +211,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,7 +265,7 @@ #!-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) @@ -386,7 +393,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) @@ -507,43 +514,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 @@ -564,7 +581,7 @@ (obj (svref *current-fop-table* obi)) (idx (read-word-arg)) (val (pop-stack))) - (if (typep obj 'instance) + (if (%instancep obj) (setf (%instance-ref obj idx) val) (setf (svref obj idx) val)))) @@ -622,6 +639,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 +661,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 ((xrefs (pop-stack)) + (type (pop-stack)) (arglist (pop-stack)) (name (pop-stack)) (code-object (pop-stack)) @@ -648,6 +677,7 @@ bug.~:@>") (setf (%simple-fun-name fun) name) (setf (%simple-fun-arglist fun) arglist) (setf (%simple-fun-type fun) type) + (setf (%simple-fun-xrefs fun) xrefs) ;; FIXME: See the comment about *LOAD-PRINT* in FOP-EVAL. #+nil (when *load-print* (load-fresh-line) @@ -718,3 +748,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))