(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
(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)
;; 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))
,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
#!-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)
(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)
(dimensions () (cons (pop-stack) dimensions)))
((zerop i) dimensions)
(declare (type index i)))
- nil)
+ nil
+ t)
res))
(define-fop (fop-single-float-vector 84)
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)))))))
\f
;;;; fops for fixing up circularities
(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))))
(name (pop-stack)))
(setf (fdefinition name) fn)))
+(define-fop (fop-note-debug-source 174 :pushp nil)
+ (warn "~@<FOP-NOTE-DEBUG-SOURCE seen in ordinary load (not cold load) -- ~
+very strange! If you didn't do something to cause this, please report it as ~
+a bug.~@:>")
+ ;; 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))
#+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))
(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)
(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))
projects / sbcl.git / blobdiff