(defvar *args* ()
#!+sb-doc
"This variable is bound to the format arguments when an error is signalled
- by BARF or BURP.")
+by BARF or BURP.")
(defvar *ignored-errors* (make-hash-table :test 'equal))
(defun barf (string &rest *args*)
(unless (gethash string *ignored-errors*)
(restart-case
- (apply #'error string *args*)
+ (apply #'error string *args*)
(continue ()
- :report "Ignore this error.")
+ :report "Ignore this error.")
(ignore-all ()
- :report "Ignore this and all future occurrences of this error."
- (setf (gethash string *ignored-errors*) t))))
+ :report "Ignore this and all future occurrences of this error."
+ (setf (gethash string *ignored-errors*) t))))
(values))
(defvar *burp-action* :warn
#!+sb-doc
"Action taken by the BURP function when a possible compiler bug is detected.
- One of :WARN, :ERROR or :NONE.")
+One of :WARN, :ERROR or :NONE.")
(declaim (type (member :warn :error :none) *burp-action*))
;;; Called when something funny but possibly correct is noticed.
;;; reached by recursing on top level functions.
;;; FIXME: Is it really only LAMBDAs, not e.g. FUNCTIONALs? Then
;;; shouldn't it be *SEEN-LAMBDAS*?
-(defvar *seen-blocks* (make-hash-table :test 'eq))
-(defvar *seen-funs* (make-hash-table :test 'eq))
+(defvar *seen-blocks*)
+(defvar *seen-funs*)
;;; Barf if NODE is in a block which wasn't reached during the graph
;;; walk.
;;; hashtables, looking for lossage.
(declaim (ftype (function (list) (values)) check-ir1-consistency))
(defun check-ir1-consistency (components)
- (clrhash *seen-blocks*)
- (clrhash *seen-funs*)
- (dolist (c components)
- (let* ((head (component-head c))
- (tail (component-tail c)))
- (unless (and (null (block-pred head))
- (null (block-succ tail)))
- (barf "~S is malformed." c))
-
- (do ((prev nil block)
- (block head (block-next block)))
- ((null block)
- (unless (eq prev tail)
- (barf "wrong TAIL for DFO, ~S in ~S" prev c)))
- (setf (gethash block *seen-blocks*) t)
- (unless (eq (block-prev block) prev)
- (barf "bad PREV for ~S, should be ~S" block prev))
- (unless (or (eq block tail)
- (eq (block-component block) c))
- (barf "~S is not in ~S." block c)))
-#|
- (when (or (loop-blocks c) (loop-inferiors c))
- (do-blocks (block c :both)
- (setf (block-flag block) nil))
- (check-loop-consistency c nil)
- (do-blocks (block c :both)
- (unless (block-flag block)
- (barf "~S was not in any loop." block))))
-|#
- ))
-
- (check-fun-consistency components)
-
- (dolist (c components)
- (do ((block (block-next (component-head c)) (block-next block)))
- ((null (block-next block)))
- (check-block-consistency block)))
-
- (maphash (lambda (k v)
- (declare (ignore k))
- (unless (or (constant-p v)
- (and (global-var-p v)
- (member (global-var-kind v)
- '(:global :special))))
- (barf "strange *FREE-VARS* entry: ~S" v))
- (dolist (n (leaf-refs v))
- (check-node-reached n))
- (when (basic-var-p v)
- (dolist (n (basic-var-sets v))
- (check-node-reached n))))
- *free-vars*)
-
- (maphash (lambda (k v)
- (declare (ignore k))
- (unless (constant-p v)
- (barf "strange *CONSTANTS* entry: ~S" v))
- (dolist (n (leaf-refs v))
- (check-node-reached n)))
- *constants*)
-
- (maphash (lambda (k v)
- (declare (ignore k))
- (unless (or (functional-p v)
- (and (global-var-p v)
- (eq (global-var-kind v) :global-function)))
- (barf "strange *FREE-FUNS* entry: ~S" v))
- (dolist (n (leaf-refs v))
- (check-node-reached n)))
- *free-funs*)
- (clrhash *seen-funs*)
- (clrhash *seen-blocks*)
- (values))
+ (let ((*seen-blocks* (make-hash-table :test 'eq))
+ (*seen-funs* (make-hash-table :test 'eq)))
+ (unwind-protect
+ (progn
+ (dolist (c components)
+ (let* ((head (component-head c))
+ (tail (component-tail c)))
+ (unless (and (null (block-pred head))
+ (null (block-succ tail)))
+ (barf "~S is malformed." c))
+
+ (do ((prev nil block)
+ (block head (block-next block)))
+ ((null block)
+ (unless (eq prev tail)
+ (barf "wrong TAIL for DFO, ~S in ~S" prev c)))
+ (setf (gethash block *seen-blocks*) t)
+ (unless (eq (block-prev block) prev)
+ (barf "bad PREV for ~S, should be ~S" block prev))
+ (unless (or (eq block tail)
+ (eq (block-component block) c))
+ (barf "~S is not in ~S." block c)))
+ #|
+ (when (or (loop-blocks c) (loop-inferiors c))
+ (do-blocks (block c :both)
+ (setf (block-flag block) nil))
+ (check-loop-consistency c nil)
+ (do-blocks (block c :both)
+ (unless (block-flag block)
+ (barf "~S was not in any loop." block))))
+ |#
+ ))
+ (check-fun-consistency components)
+
+ (dolist (c components)
+ (do ((block (block-next (component-head c)) (block-next block)))
+ ((null (block-next block)))
+ (check-block-consistency block)))
+
+ (maphash (lambda (k v)
+ (declare (ignore k))
+ (unless (or (constant-p v)
+ (and (global-var-p v)
+ (member (global-var-kind v)
+ '(:global :special :unknown))))
+ (barf "strange *FREE-VARS* entry: ~S" v))
+ (dolist (n (leaf-refs v))
+ (check-node-reached n))
+ (when (basic-var-p v)
+ (dolist (n (basic-var-sets v))
+ (check-node-reached n))))
+ *free-vars*)
+
+ (maphash (lambda (k v)
+ (declare (ignore k))
+ (unless (constant-p v)
+ (barf "strange *CONSTANTS* entry: ~S" v))
+ (dolist (n (leaf-refs v))
+ (check-node-reached n)))
+ *constants*)
+
+ (maphash (lambda (k v)
+ (declare (ignore k))
+ (unless (or (functional-p v)
+ (and (global-var-p v)
+ (eq (global-var-kind v) :global-function)))
+ (barf "strange *FREE-FUNS* entry: ~S" v))
+ (dolist (n (leaf-refs v))
+ (check-node-reached n)))
+ *free-funs*))
+ (clrhash *seen-blocks*)
+ (clrhash *seen-funs*))
+ (values)))
\f
;;;; function consistency checking
(let ((fun (functional-entry-fun functional)))
(check-fun-reached fun functional)
(when (functional-kind fun)
- (barf "The function for XEP ~S has kind." functional))
+ (barf "The function for XEP ~S has kind." functional))
(unless (eq (functional-entry-fun fun) functional)
- (barf "bad back-pointer in function for XEP ~S" functional))))
+ (barf "bad back-pointer in function for XEP ~S" functional))))
((:let :mv-let :assignment) ; i.e. SOMEWHAT-LETLIKE-P
(check-fun-reached (lambda-home functional) functional)
(when (functional-entry-fun functional)
(barf "The LET ~S is not in LETs for HOME." functional))
(unless (eq (functional-kind functional) :assignment)
(when (rest (leaf-refs functional))
- (barf "The LET ~S has multiple references." functional)))
+ (barf "The LET ~S has multiple references." functional)))
(when (lambda-lets functional)
(barf "LETs in a LET: ~S" functional)))
(:optional
(barf ":OPTIONAL ~S has an ENTRY-FUN." functional))
(let ((ef (lambda-optional-dispatch functional)))
(check-fun-reached ef functional)
- (unless (or (member functional (optional-dispatch-entry-points ef))
- (eq functional (optional-dispatch-more-entry ef))
- (eq functional (optional-dispatch-main-entry ef)))
- (barf ":OPTIONAL ~S is not an e-p for its OPTIONAL-DISPATCH ~S."
- functional ef))))
+ (unless (or (member functional (optional-dispatch-entry-points ef)
+ :key (lambda (ep)
+ (when (promise-ready-p ep)
+ (force ep))))
+ (eq functional (optional-dispatch-more-entry ef))
+ (eq functional (optional-dispatch-main-entry ef)))
+ (barf ":OPTIONAL ~S is not an e-p for its OPTIONAL-DISPATCH ~S."
+ functional ef))))
(:toplevel
(unless (eq (functional-entry-fun functional) functional)
(barf "The ENTRY-FUN in ~S isn't a self-pointer." functional)))
((nil :escape :cleanup)
(let ((ef (functional-entry-fun functional)))
(when ef
- (check-fun-reached ef functional)
- (unless (eq (functional-kind ef) :external)
- (barf "The ENTRY-FUN in ~S isn't an XEP: ~S." functional ef)))))
+ (check-fun-reached ef functional)
+ (unless (eq (functional-kind ef) :external)
+ (barf "The ENTRY-FUN in ~S isn't an XEP: ~S." functional ef)))))
(:deleted
(return-from check-fun-stuff)))
((nil :optional :external :toplevel :escape :cleanup)
(when (lambda-p functional)
(dolist (fun (lambda-lets functional))
- (unless (eq (lambda-home fun) functional)
- (barf "The home in ~S is not ~S." fun functional))
- (check-fun-reached fun functional))
+ (unless (eq (lambda-home fun) functional)
+ (barf "The home in ~S is not ~S." fun functional))
+ (check-fun-reached fun functional))
(unless (eq (lambda-home functional) functional)
- (barf "home not self-pointer in ~S" functional)))))
+ (barf "home not self-pointer in ~S" functional)))))
(etypecase functional
(clambda
(dolist (var (lambda-vars functional))
(dolist (ref (leaf-refs var))
- (check-node-reached ref))
+ (check-node-reached ref))
(dolist (set (basic-var-sets var))
- (check-node-reached set))
+ (check-node-reached set))
(unless (eq (lambda-var-home var) functional)
- (barf "HOME in ~S should be ~S." var functional))))
+ (barf "HOME in ~S should be ~S." var functional))))
(optional-dispatch
(dolist (ep (optional-dispatch-entry-points functional))
- (check-fun-reached ep functional))
+ (when (promise-ready-p ep)
+ (check-fun-reached (force ep) functional)))
(let ((more (optional-dispatch-more-entry functional)))
(when more (check-fun-reached more functional)))
(check-fun-reached (optional-dispatch-main-entry functional)
- functional))))
+ functional))))
(defun check-fun-consistency (components)
(dolist (c components)
(observe-functional new-fun))
(dolist (fun (component-lambdas c))
(when (eq (functional-kind fun) :external)
- (let ((ef (functional-entry-fun fun)))
- (when (optional-dispatch-p ef)
- (observe-functional ef))))
+ (let ((ef (functional-entry-fun fun)))
+ (when (optional-dispatch-p ef)
+ (observe-functional ef))))
(observe-functional fun)
(dolist (let (lambda-lets fun))
- (observe-functional let))))
+ (observe-functional let))))
(dolist (c components)
(dolist (new-fun (component-new-functionals c))
(check-fun-stuff new-fun))
(dolist (fun (component-lambdas c))
(when (eq (functional-kind fun) :deleted)
- (barf "deleted lambda ~S in Lambdas for ~S" fun c))
+ (barf "deleted lambda ~S in Lambdas for ~S" fun c))
(check-fun-stuff fun)
(dolist (let (lambda-lets fun))
- (check-fun-stuff let)))))
+ (check-fun-stuff let)))))
\f
;;;; loop consistency checking
(unless (eq (loop-superior loop) superior)
(barf "wrong superior in ~S, should be ~S" loop superior))
(when (and superior
- (/= (loop-depth loop) (1+ (loop-depth superior))))
+ (/= (loop-depth loop) (1+ (loop-depth superior))))
(barf "wrong depth in ~S" loop))
(dolist (tail (loop-tail loop))
(unless (gethash block *seen-blocks*)
(barf "unseen block ~S in loop info for ~S" block loop))
(labels ((walk (l)
- (if (eq (block-loop block) l)
- t
- (dolist (inferior (loop-inferiors l) nil)
- (when (walk inferior) (return t))))))
+ (if (eq (block-loop block) l)
+ t
+ (dolist (inferior (loop-inferiors l) nil)
+ (when (walk inferior) (return t))))))
(unless (walk loop)
(barf "~S is in loop info for ~S but not in the loop." block loop)))
(values))
(barf "bad predecessor link ~S in ~S" pred block)))
(let* ((fun (block-home-lambda block))
- (fun-deleted (eq (functional-kind fun) :deleted))
- (this-ctran (block-start block))
- (last (block-last block)))
+ (fun-deleted (eq (functional-kind fun) :deleted))
+ (this-ctran (block-start block))
+ (last (block-last block)))
(unless fun-deleted
(check-fun-reached fun block))
(when (not this-ctran)
(loop
(unless (eq (ctran-block this-ctran) block)
- (barf "BLOCK of ~S should be ~S." this-ctran block))
+ (barf "BLOCK of ~S should be ~S." this-ctran block))
(let ((node (ctran-next this-ctran)))
- (unless (node-p node)
- (barf "~S has strange NEXT." this-ctran))
- (unless (eq (node-prev node) this-ctran)
- (barf "PREV in ~S should be ~S." node this-ctran))
+ (unless (node-p node)
+ (barf "~S has strange NEXT." this-ctran))
+ (unless (eq (node-prev node) this-ctran)
+ (barf "PREV in ~S should be ~S." node this-ctran))
(when (valued-node-p node)
(binding* ((lvar (node-lvar node) :exit-if-null))
(barf "~S does not have dest." lvar))))
(check-node-reached node)
- (unless fun-deleted
- (check-node-consistency node))
-
- (let ((next (node-next node)))
- (when (and (not next) (not (eq node last)))
- (barf "~S has no NEXT." node))
- (when (eq node last) (return))
- (unless (eq (ctran-kind next) :inside-block)
- (barf "The interior ctran ~S in ~S has the wrong kind."
- next
- block))
- (unless (ctran-next next)
- (barf "~S has no NEXT." next))
- (unless (eq (ctran-use next) node)
- (barf "USE in ~S should be ~S." next node))
- (setq this-ctran next))))
+ (unless fun-deleted
+ (check-node-consistency node))
+
+ (let ((next (node-next node)))
+ (when (and (not next) (not (eq node last)))
+ (barf "~S has no NEXT." node))
+ (when (eq node last) (return))
+ (unless (eq (ctran-kind next) :inside-block)
+ (barf "The interior ctran ~S in ~S has the wrong kind."
+ next
+ block))
+ (unless (ctran-next next)
+ (barf "~S has no NEXT." next))
+ (unless (eq (ctran-use next) node)
+ (barf "USE in ~S should be ~S." next node))
+ (setq this-ctran next))))
(check-block-successors block))
(values))
(declaim (ftype (function (cblock) (values)) check-block-successors))
(defun check-block-successors (block)
(let ((last (block-last block))
- (succ (block-succ block)))
+ (succ (block-succ block)))
(let* ((comp (block-component block)))
(dolist (b succ)
- (unless (gethash b *seen-blocks*)
- (barf "unseen successor ~S in ~S" b block))
- (unless (member block (block-pred b))
- (barf "bad successor link ~S in ~S" b block))
- (unless (eq (block-component b) comp)
- (barf "The successor ~S in ~S is in a different component."
- b
- block))))
+ (unless (gethash b *seen-blocks*)
+ (barf "unseen successor ~S in ~S" b block))
+ (unless (member block (block-pred b))
+ (barf "bad successor link ~S in ~S" b block))
+ (unless (eq (block-component b) comp)
+ (barf "The successor ~S in ~S is in a different component."
+ b
+ block))))
(typecase last
(cif
(unless (proper-list-of-length-p succ 1 2)
- (barf "~S ends in an IF, but doesn't have one or two succesors."
- block))
+ (barf "~S ends in an IF, but doesn't have one or two successors."
+ block))
(unless (member (if-consequent last) succ)
- (barf "The CONSEQUENT for ~S isn't in SUCC for ~S." last block))
+ (barf "The CONSEQUENT for ~S isn't in SUCC for ~S." last block))
(unless (member (if-alternative last) succ)
- (barf "The ALTERNATIVE for ~S isn't in SUCC for ~S." last block)))
+ (barf "The ALTERNATIVE for ~S isn't in SUCC for ~S." last block)))
(creturn
(unless (if (eq (functional-kind (return-lambda last)) :deleted)
- (null succ)
- (and (= (length succ) 1)
- (eq (first succ)
- (component-tail (block-component block)))))
- (barf "strange successors for RETURN in ~S" block)))
+ (null succ)
+ (and (= (length succ) 1)
+ (eq (first succ)
+ (component-tail (block-component block)))))
+ (barf "strange successors for RETURN in ~S" block)))
(exit
(unless (proper-list-of-length-p succ 0 1)
- (barf "EXIT node with strange number of successors: ~S" last)))
+ (barf "EXIT node with strange number of successors: ~S" last)))
(t
(unless (or (= (length succ) 1) (node-tail-p last)
- (and (block-delete-p block) (null succ)))
- (barf "~S ends in normal node, but doesn't have one successor."
- block)))))
+ (and (block-delete-p block) (null succ)))
+ (barf "~S ends in normal node, but doesn't have one successor."
+ block)))))
(values))
\f
;;;; node consistency checking
(ref
(let ((leaf (ref-leaf node)))
(when (functional-p leaf)
- (if (eq (functional-kind leaf) :toplevel-xep)
- (unless (eq (component-kind (block-component (node-block node)))
- :toplevel)
- (barf ":TOPLEVEL-XEP ref in non-top-level component: ~S"
- node))
- (check-fun-reached leaf node)))))
+ (if (eq (functional-kind leaf) :toplevel-xep)
+ (unless (component-toplevelish-p (block-component (node-block node)))
+ (barf ":TOPLEVEL-XEP ref in non-top-level component: ~S"
+ node))
+ (check-fun-reached leaf node)))))
(basic-combination
(check-dest (basic-combination-fun node) node)
+ (when (and (mv-combination-p node)
+ (eq (basic-combination-kind node) :local))
+ (let ((fun-lvar (basic-combination-fun node)))
+ (unless (ref-p (lvar-uses fun-lvar))
+ (barf "function in a local mv-combination is not a LEAF: ~S" node))
+ (let ((fun (ref-leaf (lvar-use fun-lvar))))
+ (unless (lambda-p fun)
+ (barf "function ~S in a local mv-combination ~S is not local"
+ fun node))
+ (unless (eq (functional-kind fun) :mv-let)
+ (barf "function ~S in a local mv-combination ~S is not of kind :MV-LET"
+ fun node)))))
(dolist (arg (basic-combination-args node))
(cond
(arg (check-dest arg node))
(let* ((lvar (node-lvar node))
(dest (and lvar (lvar-dest lvar))))
(when (and (return-p dest)
- (eq (basic-combination-kind node) :local)
- (not (eq (lambda-tail-set (combination-lambda node))
- (lambda-tail-set (return-lambda dest)))))
- (barf "tail local call to function with different tail set:~% ~S"
- node))))
+ (eq (basic-combination-kind node) :local)
+ (not (eq (lambda-tail-set (combination-lambda node))
+ (lambda-tail-set (return-lambda dest)))))
+ (barf "tail local call to function with different tail set:~% ~S"
+ node))))
(cif
(check-dest (if-test node) node)
(unless (eq (block-last (node-block node)) node)
(barf "~S is not in ENTRIES for its home LAMBDA." node))
(dolist (exit (entry-exits node))
(unless (node-deleted exit)
- (check-node-reached node))))
+ (check-node-reached node))))
(exit
(let ((entry (exit-entry node))
- (value (exit-value node)))
+ (value (exit-value node)))
(cond (entry
- (check-node-reached entry)
- (unless (member node (entry-exits entry))
- (barf "~S is not in its ENTRY's EXITS." node))
- (when value
- (check-dest value node)))
- (t
- (when value
- (barf "~S has VALUE but no ENTRY." node)))))))
+ (check-node-reached entry)
+ (unless (member node (entry-exits entry))
+ (barf "~S is not in its ENTRY's EXITS." node))
+ (when value
+ (check-dest value node)))
+ (t
+ (when value
+ (barf "~S has VALUE but no ENTRY." node)))))))
(values))
\f
(defun check-tn-refs (refs vop write-p count more-p what)
(let ((vop-refs (vop-refs vop)))
(do ((ref refs (tn-ref-across ref))
- (num 0 (1+ num)))
- ((null ref)
- (when (< num count)
- (barf "There should be at least ~W ~A in ~S, but there are only ~W."
- count what vop num))
- (when (and (not more-p) (> num count))
- (barf "There should be ~W ~A in ~S, but are ~W."
- count what vop num)))
+ (num 0 (1+ num)))
+ ((null ref)
+ (when (< num count)
+ (barf "There should be at least ~W ~A in ~S, but there are only ~W."
+ count what vop num))
+ (when (and (not more-p) (> num count))
+ (barf "There should be ~W ~A in ~S, but are ~W."
+ count what vop num)))
(unless (eq (tn-ref-vop ref) vop)
- (barf "VOP is ~S isn't ~S." ref vop))
+ (barf "VOP is ~S isn't ~S." ref vop))
(unless (eq (tn-ref-write-p ref) write-p)
- (barf "The WRITE-P in ~S isn't ~S." vop write-p))
+ (barf "The WRITE-P in ~S isn't ~S." vop write-p))
(unless (find-in #'tn-ref-next-ref ref vop-refs)
- (barf "~S not found in REFS for ~S" ref vop))
+ (barf "~S not found in REFS for ~S" ref vop))
(unless (find-in #'tn-ref-next ref
- (if (tn-ref-write-p ref)
- (tn-writes (tn-ref-tn ref))
- (tn-reads (tn-ref-tn ref))))
- (barf "~S not found in reads/writes for its TN" ref))
+ (if (tn-ref-write-p ref)
+ (tn-writes (tn-ref-tn ref))
+ (tn-reads (tn-ref-tn ref))))
+ (barf "~S not found in reads/writes for its TN" ref))
(let ((target (tn-ref-target ref)))
- (when target
- (unless (eq (tn-ref-write-p target) (not (tn-ref-write-p ref)))
- (barf "The target for ~S isn't complementary WRITE-P." ref))
- (unless (find-in #'tn-ref-next-ref target vop-refs)
- (barf "The target for ~S isn't in REFS for ~S." ref vop)))))))
+ (when target
+ (unless (eq (tn-ref-write-p target) (not (tn-ref-write-p ref)))
+ (barf "The target for ~S isn't complementary WRITE-P." ref))
+ (unless (find-in #'tn-ref-next-ref target vop-refs)
+ (barf "The target for ~S isn't in REFS for ~S." ref vop)))))))
;;; Verify the sanity of the VOP-REFS slot in VOP. This involves checking
;;; that each referenced TN appears as an argument, result or temp, and also
(barf "stray ref that isn't a READ: ~S" ref))
(t
(let* ((tn (tn-ref-tn ref))
- (temp (find-in #'tn-ref-across tn (vop-temps vop)
- :key #'tn-ref-tn)))
- (unless temp
- (barf "stray ref with no corresponding temp write: ~S" ref))
- (unless (find-in #'tn-ref-next-ref temp (tn-ref-next-ref ref))
- (barf "Read is after write for temp ~S in refs of ~S."
- tn vop))))))
+ (temp (find-in #'tn-ref-across tn (vop-temps vop)
+ :key #'tn-ref-tn)))
+ (unless temp
+ (barf "stray ref with no corresponding temp write: ~S" ref))
+ (unless (find-in #'tn-ref-next-ref temp (tn-ref-next-ref ref))
+ (barf "Read is after write for temp ~S in refs of ~S."
+ tn vop))))))
(values))
;;; Check the basic sanity of the VOP linkage, then call some other
(defun check-ir2-block-consistency (2block)
(declare (type ir2-block 2block))
(do ((vop (ir2-block-start-vop 2block)
- (vop-next vop))
+ (vop-next vop))
(prev nil vop))
((null vop)
(unless (eq prev (ir2-block-last-vop 2block))
- (barf "The last VOP in ~S should be ~S." 2block prev)))
+ (barf "The last VOP in ~S should be ~S." 2block prev)))
(unless (eq (vop-prev vop) prev)
(barf "PREV in ~S should be ~S." vop prev))
(check-vop-refs vop)
(let* ((info (vop-info vop))
- (atypes (template-arg-types info))
- (rtypes (template-result-types info)))
+ (atypes (template-arg-types info))
+ (rtypes (template-result-types info)))
(check-tn-refs (vop-args vop) vop nil
- (count-if-not (lambda (x)
- (and (consp x)
- (eq (car x) :constant)))
- atypes)
- (template-more-args-type info) "args")
+ (count-if-not (lambda (x)
+ (and (consp x)
+ (eq (car x) :constant)))
+ atypes)
+ (template-more-args-type info) "args")
(check-tn-refs (vop-results vop) vop t
- (if (eq rtypes :conditional) 0 (length rtypes))
- (template-more-results-type info) "results")
+ (if (template-conditional-p info) 0 (length rtypes))
+ (template-more-results-type info) "results")
(check-tn-refs (vop-temps vop) vop t 0 t "temps")
(unless (= (length (vop-codegen-info vop))
- (template-info-arg-count info))
- (barf "wrong number of codegen info args in ~S" vop))))
+ (template-info-arg-count info))
+ (barf "wrong number of codegen info args in ~S" vop))))
(values))
;;; Check stuff about the IR2 representation of COMPONENT. This assumes the
;;; Dump some info about how many TNs there, and what the conflicts data
;;; structures are like.
-(defun pre-pack-tn-stats (component &optional (stream *error-output*))
+(defun pre-pack-tn-stats (component &optional (stream *standard-output*))
(declare (type component component))
(let ((wired 0)
- (global 0)
- (local 0)
- (confs 0)
- (unused 0)
- (const 0)
- (temps 0)
- (environment 0)
- (comp 0))
+ (global 0)
+ (local 0)
+ (confs 0)
+ (unused 0)
+ (const 0)
+ (temps 0)
+ (environment 0)
+ (comp 0))
(do-packed-tns (tn component)
(let ((reads (tn-reads tn))
- (writes (tn-writes tn)))
- (when (and reads writes
- (not (tn-ref-next reads)) (not (tn-ref-next writes))
- (eq (tn-ref-vop reads) (tn-ref-vop writes)))
- (incf temps)))
+ (writes (tn-writes tn)))
+ (when (and reads writes
+ (not (tn-ref-next reads)) (not (tn-ref-next writes))
+ (eq (tn-ref-vop reads) (tn-ref-vop writes)))
+ (incf temps)))
(when (tn-offset tn)
- (incf wired))
+ (incf wired))
(unless (or (tn-reads tn) (tn-writes tn))
- (incf unused))
+ (incf unused))
(cond ((eq (tn-kind tn) :component)
- (incf comp))
- ((tn-global-conflicts tn)
- (case (tn-kind tn)
- ((:environment :debug-environment) (incf environment))
- (t (incf global)))
- (do ((conf (tn-global-conflicts tn)
- (global-conflicts-next-tnwise conf)))
- ((null conf))
- (incf confs)))
- (t
- (incf local))))
+ (incf comp))
+ ((tn-global-conflicts tn)
+ (case (tn-kind tn)
+ ((:environment :debug-environment) (incf environment))
+ (t (incf global)))
+ (do ((conf (tn-global-conflicts tn)
+ (global-conflicts-next-tnwise conf)))
+ ((null conf))
+ (incf confs)))
+ (t
+ (incf local))))
(do ((tn (ir2-component-constant-tns (component-info component))
- (tn-next tn)))
- ((null tn))
+ (tn-next tn)))
+ ((null tn))
(incf const))
(format stream
;;; for the validity of the usage.
(defun check-more-tn-entry (tn block)
(let* ((vop (ir2-block-start-vop block))
- (info (vop-info vop)))
+ (info (vop-info vop)))
(macrolet ((frob (more-p ops)
- `(and (,more-p info)
- (find-in #'tn-ref-across tn (,ops vop)
- :key #'tn-ref-tn))))
+ `(and (,more-p info)
+ (find-in #'tn-ref-across tn (,ops vop)
+ :key #'tn-ref-tn))))
(unless (and (eq vop (ir2-block-last-vop block))
- (or (frob template-more-args-type vop-args)
- (frob template-more-results-type vop-results)))
- (barf "strange :MORE LTN entry for ~S in ~S" tn block))))
+ (or (frob template-more-args-type vop-args)
+ (frob template-more-results-type vop-results)))
+ (barf "strange :MORE LTN entry for ~S in ~S" tn block))))
(values))
(defun check-tn-conflicts (component)
(do-packed-tns (tn component)
(unless (or (not (eq (tn-kind tn) :normal))
- (tn-reads tn)
- (tn-writes tn))
+ (tn-reads tn)
+ (tn-writes tn))
(barf "no references to ~S" tn))
(unless (tn-sc tn) (barf "~S has no SC." tn))
(let ((conf (tn-global-conflicts tn))
- (kind (tn-kind tn)))
+ (kind (tn-kind tn)))
(cond
((eq kind :component)
- (unless (member tn (ir2-component-component-tns
- (component-info component)))
- (barf "~S not in COMPONENT-TNs for ~S" tn component)))
+ (unless (member tn (ir2-component-component-tns
+ (component-info component)))
+ (barf "~S not in COMPONENT-TNs for ~S" tn component)))
(conf
- (do ((conf conf (global-conflicts-next-tnwise conf))
- (prev nil conf))
- ((null conf))
- (unless (eq (global-conflicts-tn conf) tn)
- (barf "TN in ~S should be ~S." conf tn))
-
- (unless (eq (global-conflicts-kind conf) :live)
- (let* ((block (global-conflicts-block conf))
- (ltn (svref (ir2-block-local-tns block)
- (global-conflicts-number conf))))
- (cond ((eq ltn tn))
- ((eq ltn :more) (check-more-tn-entry tn block))
- (t
- (barf "~S wrong in LTN map for ~S" conf tn)))))
-
- (when prev
- (unless (> (ir2-block-number (global-conflicts-block conf))
- (ir2-block-number (global-conflicts-block prev)))
- (barf "~s and ~s out of order" prev conf)))))
+ (do ((conf conf (global-conflicts-next-tnwise conf))
+ (prev nil conf))
+ ((null conf))
+ (unless (eq (global-conflicts-tn conf) tn)
+ (barf "TN in ~S should be ~S." conf tn))
+
+ (unless (eq (global-conflicts-kind conf) :live)
+ (let* ((block (global-conflicts-block conf))
+ (ltn (svref (ir2-block-local-tns block)
+ (global-conflicts-number conf))))
+ (cond ((eq ltn tn))
+ ((eq ltn :more) (check-more-tn-entry tn block))
+ (t
+ (barf "~S wrong in LTN map for ~S" conf tn)))))
+
+ (when prev
+ (unless (> (ir2-block-number (global-conflicts-block conf))
+ (ir2-block-number (global-conflicts-block prev)))
+ (barf "~s and ~s out of order" prev conf)))))
((member (tn-kind tn) '(:constant :specified-save)))
(t
- (let ((local (tn-local tn)))
- (unless local
- (barf "~S has no global conflicts, but isn't local either." tn))
- (unless (eq (svref (ir2-block-local-tns local)
- (tn-local-number tn))
- tn)
- (barf "~S wrong in LTN map" tn))
- (do ((ref (tn-reads tn) (tn-ref-next ref)))
- ((null ref))
- (unless (eq (vop-block (tn-ref-vop ref)) local)
- (barf "~S has references in blocks other than its LOCAL block."
- tn)))
- (do ((ref (tn-writes tn) (tn-ref-next ref)))
- ((null ref))
- (unless (eq (vop-block (tn-ref-vop ref)) local)
- (barf "~S has references in blocks other than its LOCAL block."
- tn))))))))
+ (let ((local (tn-local tn)))
+ (unless local
+ (barf "~S has no global conflicts, but isn't local either." tn))
+ (unless (eq (svref (ir2-block-local-tns local)
+ (tn-local-number tn))
+ tn)
+ (barf "~S wrong in LTN map" tn))
+ (do ((ref (tn-reads tn) (tn-ref-next ref)))
+ ((null ref))
+ (unless (eq (vop-block (tn-ref-vop ref)) local)
+ (barf "~S has references in blocks other than its LOCAL block."
+ tn)))
+ (do ((ref (tn-writes tn) (tn-ref-next ref)))
+ ((null ref))
+ (unless (eq (vop-block (tn-ref-vop ref)) local)
+ (barf "~S has references in blocks other than its LOCAL block."
+ tn))))))))
(values))
(defun check-block-conflicts (component)
(do-ir2-blocks (block component)
(do ((conf (ir2-block-global-tns block)
- (global-conflicts-next-blockwise conf))
- (prev nil conf))
- ((null conf))
+ (global-conflicts-next-blockwise conf))
+ (prev nil conf))
+ ((null conf))
(when prev
- (unless (> (tn-number (global-conflicts-tn conf))
- (tn-number (global-conflicts-tn prev)))
- (barf "~S and ~S out of order in ~S" prev conf block)))
+ (unless (> (tn-number (global-conflicts-tn conf))
+ (tn-number (global-conflicts-tn prev)))
+ (barf "~S and ~S out of order in ~S" prev conf block)))
(unless (find-in #'global-conflicts-next-tnwise
- conf
- (tn-global-conflicts
- (global-conflicts-tn conf)))
- (barf "~S missing from global conflicts of its TN" conf)))
+ conf
+ (tn-global-conflicts
+ (global-conflicts-tn conf)))
+ (barf "~S missing from global conflicts of its TN" conf)))
(let ((map (ir2-block-local-tns block)))
(dotimes (i (ir2-block-local-tn-count block))
- (let ((tn (svref map i)))
- (unless (or (eq tn :more)
- (null tn)
- (tn-global-conflicts tn)
- (eq (tn-local tn) block))
- (barf "strange TN ~S in LTN map for ~S" tn block)))))))
+ (let ((tn (svref map i)))
+ (unless (or (eq tn :more)
+ (null tn)
+ (tn-global-conflicts tn)
+ (eq (tn-local tn) block))
+ (barf "strange TN ~S in LTN map for ~S" tn block)))))))
;;; All TNs live at the beginning of an environment must be passing
;;; locations associated with that environment. We make an exception
(defun check-environment-lifetimes (component)
(dolist (fun (component-lambdas component))
(let* ((env (lambda-physenv fun))
- (2env (physenv-info env))
- (vars (lambda-vars fun))
- (closure (ir2-physenv-closure 2env))
- (pc (ir2-physenv-return-pc-pass 2env))
- (fp (ir2-physenv-old-fp 2env))
- (2block (block-info (lambda-block (physenv-lambda env)))))
+ (2env (physenv-info env))
+ (vars (lambda-vars fun))
+ (closure (ir2-physenv-closure 2env))
+ (pc (ir2-physenv-return-pc-pass 2env))
+ (fp (ir2-physenv-old-fp 2env))
+ (2block (block-info (lambda-block (physenv-lambda env)))))
(do ((conf (ir2-block-global-tns 2block)
- (global-conflicts-next-blockwise conf)))
- ((null conf))
- (let ((tn (global-conflicts-tn conf)))
- (unless (or (eq (global-conflicts-kind conf) :write)
- (eq tn pc)
- (eq tn fp)
- (and (xep-p fun) (tn-offset tn))
- (member (tn-kind tn) '(:environment :debug-environment))
- (member tn vars :key #'leaf-info)
- (member tn closure :key #'cdr))
- (barf "strange TN live at head of ~S: ~S" env tn))))))
+ (global-conflicts-next-blockwise conf)))
+ ((null conf))
+ (let ((tn (global-conflicts-tn conf)))
+ (unless (or (eq (global-conflicts-kind conf) :write)
+ (eq tn pc)
+ (eq tn fp)
+ (and (xep-p fun) (tn-offset tn))
+ (member (tn-kind tn) '(:environment :debug-environment))
+ (member tn vars :key #'leaf-info)
+ (member tn closure :key #'cdr))
+ (barf "strange TN live at head of ~S: ~S" env tn))))))
(values))
;;; Check for some basic sanity in the TN conflict data structures,
(defun check-pack-consistency (component)
(flet ((check (scs ops)
- (do ((scs scs (cdr scs))
- (op ops (tn-ref-across op)))
- ((null scs))
- (let ((load-tn (tn-ref-load-tn op)))
- (unless (eq (svref (car scs)
- (sc-number
- (tn-sc
- (or load-tn (tn-ref-tn op)))))
- t)
- (barf "operand restriction not satisfied: ~S" op))))))
+ (do ((scs scs (cdr scs))
+ (op ops (tn-ref-across op)))
+ ((null scs))
+ (let ((load-tn (tn-ref-load-tn op)))
+ (unless (eq (svref (car scs)
+ (sc-number
+ (tn-sc
+ (or load-tn (tn-ref-tn op)))))
+ t)
+ (barf "operand restriction not satisfied: ~S" op))))))
(do-ir2-blocks (block component)
(do ((vop (ir2-block-last-vop block) (vop-prev vop)))
- ((null vop))
- (let ((info (vop-info vop)))
- (check (vop-info-result-load-scs info) (vop-results vop))
- (check (vop-info-arg-load-scs info) (vop-args vop))))))
+ ((null vop))
+ (let ((info (vop-info vop)))
+ (check (vop-info-result-load-scs info) (vop-results vop))
+ (check (vop-info-arg-load-scs info) (vop-args vop))))))
(values))
\f
;;;; data structure dumping routines
;;;
;;; FIXME:
;;; * Perhaps this machinery should be #!+SB-SHOW.
-;;; * Probably the hash tables should either be weak hash tables,
-;;; or only allocated within a single compilation unit. Otherwise
-;;; there will be a tendency for them to grow without bound and
-;;; keep garbage from being collected.
(macrolet ((def (counter vto vfrom fto ffrom)
- `(progn
- (declaim (type hash-table ,vto ,vfrom))
- (defvar ,vto (make-hash-table :test 'eq))
- (defvar ,vfrom (make-hash-table :test 'eql))
- (declaim (type fixnum ,counter))
- (defvar ,counter 0)
-
- (defun ,fto (x)
- (or (gethash x ,vto)
- (let ((num (incf ,counter)))
- (setf (gethash num ,vfrom) x)
- (setf (gethash x ,vto) num))))
-
- (defun ,ffrom (num)
- (values (gethash num ,vfrom))))))
+ `(progn
+ (declaim (type hash-table ,vto ,vfrom))
+ (defvar ,vto)
+ (defvar ,vfrom)
+ (declaim (type fixnum ,counter))
+ (defvar ,counter 0)
+
+ (defun ,fto (x)
+ (or (gethash x ,vto)
+ (let ((num (incf ,counter)))
+ (setf (gethash num ,vfrom) x)
+ (setf (gethash x ,vto) num))))
+
+ (defun ,ffrom (num)
+ (values (gethash num ,vfrom))))))
(def *continuation-number* *continuation-numbers* *number-continuations*
cont-num num-cont)
(def *tn-id* *tn-ids* *id-tns* tn-id id-tn)
- (def *label-id* *id-labels* *label-ids* label-id id-label))
+ (def *label-id* *label-ids* *id-labels* label-id id-label))
;;; Print a terse one-line description of LEAF.
(defun print-leaf (leaf &optional (stream *standard-output*))
(symbol (block-or-lose (gethash thing *free-funs*)))))
;;; Print cN.
-(defun print-continuation (cont)
- (declare (type continuation cont))
- (format t " c~D" (cont-num cont))
- (values))
-
(defun print-ctran (cont)
(declare (type ctran cont))
(format t "c~D " (cont-num cont))
(format t "v~D " (cont-num cont))
(values))
+(defun print-lvar-stack (stack &optional (stream *standard-output*))
+ (loop for (lvar . rest) on stack
+ do (format stream "~:[u~;d~]v~D~@[ ~]"
+ (lvar-dynamic-extent lvar) (cont-num lvar) rest)))
+
;;; Print out the nodes in BLOCK in a format oriented toward
;;; representing what the code does.
(defun print-nodes (block)
(format t " <deleted>"))
(pprint-newline :mandatory)
+ (awhen (block-info block)
+ (format t "start stack: ")
+ (print-lvar-stack (ir2-block-start-stack it))
+ (pprint-newline :mandatory))
(do ((ctran (block-start block) (node-next (ctran-next ctran))))
((not ctran))
(let ((node (ctran-next ctran)))
- (format t "~:[ ~;~:*~3D:~] "
+ (format t "~3D>~:[ ~;~:*~3D:~] "
+ (cont-num ctran)
(when (and (valued-node-p node) (node-lvar node))
(cont-num (node-lvar node))))
(etypecase node
(let ((kind (basic-combination-kind node)))
(format t "~(~A~A ~A~) "
(if (node-tail-p node) "tail " "")
- (if (fun-info-p kind) "known" kind)
+ kind
(type-of node))
(print-lvar (basic-combination-fun node))
(dolist (arg (basic-combination-args node))
(print-lvar (return-result node))
(print-leaf (return-lambda node)))
(entry
- (format t "entry ~S" (entry-exits node)))
+ (let ((cleanup (entry-cleanup node)))
+ (case (cleanup-kind cleanup)
+ ((:dynamic-extent)
+ (format t "entry DX~{ v~D~}"
+ (mapcar (lambda (lvar-or-cell)
+ (if (consp lvar-or-cell)
+ (cons (car lvar-or-cell)
+ (cont-num (cdr lvar-or-cell)))
+ (cont-num lvar-or-cell)))
+ (cleanup-info cleanup))))
+ (t
+ (format t "entry ~S" (entry-exits node))))))
(exit
(let ((value (exit-value node)))
(cond (value
(cast-asserted-type node)))))
(pprint-newline :mandatory)))
+ (awhen (block-info block)
+ (format t "end stack: ")
+ (print-lvar-stack (ir2-block-end-stack it))
+ (pprint-newline :mandatory))
(let ((succ (block-succ block)))
(format t "successors~{ c~D~}~%"
(mapcar (lambda (x) (cont-num (block-start x))) succ))))
(declare (type tn tn))
(let ((leaf (tn-leaf tn)))
(cond (leaf
- (print-leaf leaf stream)
- (format stream "!~D" (tn-id tn)))
- (t
- (format stream "t~D" (tn-id tn))))
+ (print-leaf leaf stream)
+ (format stream "!~D" (tn-id tn)))
+ (t
+ (format stream "t~D" (tn-id tn))))
(when (and (tn-sc tn) (tn-offset tn))
(format stream "[~A]" (location-print-name tn)))))
(declare (type (or tn-ref null) refs))
(pprint-logical-block (*standard-output* nil)
(do ((ref refs (tn-ref-across ref)))
- ((null ref))
+ ((null ref))
(let ((tn (tn-ref-tn ref))
- (ltn (tn-ref-load-tn ref)))
- (cond ((not ltn)
- (print-tn-guts tn))
- (t
- (print-tn-guts tn)
- (princ (if (tn-ref-write-p ref) #\< #\>))
- (print-tn-guts ltn)))
- (princ #\space)
- (pprint-newline :fill)))))
+ (ltn (tn-ref-load-tn ref)))
+ (cond ((not ltn)
+ (print-tn-guts tn))
+ (t
+ (print-tn-guts tn)
+ (princ (if (tn-ref-write-p ref) #\< #\>))
+ (print-tn-guts ltn)))
+ (princ #\space)
+ (pprint-newline :fill)))))
;;; Print the VOP, putting args, info and results on separate lines, if
;;; necessary.
(pprint-newline :linear)
(when (vop-codegen-info vop)
(princ (with-output-to-string (stream)
- (let ((*print-level* 1)
- (*print-length* 3))
- (format stream "{~{~S~^ ~}} " (vop-codegen-info vop)))))
+ (let ((*print-level* 1)
+ (*print-length* 3))
+ (format stream "{~{~S~^ ~}} " (vop-codegen-info vop)))))
(pprint-newline :linear))
(when (vop-results vop)
(princ "=> ")
(let ((2block (block-info block)))
(print-ir2-block 2block)
(do ((b (ir2-block-next 2block) (ir2-block-next b)))
- ((not (eq (ir2-block-block b) block)))
+ ((not (eq (ir2-block-block b) block)))
(print-ir2-block b)))
(values))
(do-blocks (block (block-component block) :both)
(setf (block-flag block) nil))
(labels ((walk (block)
- (unless (block-flag block)
- (setf (block-flag block) t)
- (when (block-start block)
- (print-nodes block))
- (dolist (block (block-succ block))
- (walk block)))))
+ (unless (block-flag block)
+ (setf (block-flag block) t)
+ (when (block-start block)
+ (print-nodes block))
+ (dolist (block (block-succ block))
+ (walk block)))))
(walk block))
(values))
(do-blocks (block (block-component (block-or-lose thing)))
(handler-case (print-nodes block)
(error (condition)
- (format t "~&~A...~%" condition))))
+ (format t "~&~A...~%" condition))))
(values))
(defvar *list-conflicts-table* (make-hash-table :test 'eq))
(defun add-always-live-tns (block tn)
(declare (type ir2-block block) (type tn tn))
(do ((conf (ir2-block-global-tns block)
- (global-conflicts-next-blockwise conf)))
+ (global-conflicts-next-blockwise conf)))
((null conf))
(when (eq (global-conflicts-kind conf) :live)
(let ((btn (global-conflicts-tn conf)))
- (unless (eq btn tn)
- (setf (gethash btn *list-conflicts-table*) t)))))
+ (unless (eq btn tn)
+ (setf (gethash btn *list-conflicts-table*) t)))))
(values))
;;; Add all local TNs in BLOCK to the conflicts.
(defun listify-conflicts-table ()
(collect ((res))
(maphash (lambda (k v)
- (declare (ignore v))
- (when k
- (res k)))
- *list-conflicts-table*)
- (clrhash *list-conflicts-table*)
+ (declare (ignore v))
+ (when k
+ (res k)))
+ *list-conflicts-table*)
(res)))
;;; Return a list of a the TNs that conflict with TN. Sort of, kind
(aver (member (tn-kind tn) '(:normal :environment :debug-environment)))
(let ((confs (tn-global-conflicts tn)))
(cond (confs
- (clrhash *list-conflicts-table*)
- (do ((conf confs (global-conflicts-next-tnwise conf)))
- ((null conf))
- (format t "~&#<block ~D kind ~S>~%"
- (block-number (ir2-block-block (global-conflicts-block
- conf)))
- (global-conflicts-kind conf))
- (let ((block (global-conflicts-block conf)))
- (add-always-live-tns block tn)
- (if (eq (global-conflicts-kind conf) :live)
- (add-all-local-tns block)
- (let ((bconf (global-conflicts-conflicts conf))
- (ltns (ir2-block-local-tns block)))
- (dotimes (i (ir2-block-local-tn-count block))
- (when (/= (sbit bconf i) 0)
- (setf (gethash (svref ltns i) *list-conflicts-table*)
- t)))))))
- (listify-conflicts-table))
- (t
- (let* ((block (tn-local tn))
- (ltns (ir2-block-local-tns block))
- (confs (tn-local-conflicts tn)))
- (collect ((res))
- (dotimes (i (ir2-block-local-tn-count block))
- (when (/= (sbit confs i) 0)
- (let ((tn (svref ltns i)))
- (when (and tn (not (eq tn :more))
- (not (tn-global-conflicts tn)))
- (res tn)))))
- (do ((gtn (ir2-block-global-tns block)
- (global-conflicts-next-blockwise gtn)))
- ((null gtn))
- (when (or (eq (global-conflicts-kind gtn) :live)
- (/= (sbit confs (global-conflicts-number gtn)) 0))
- (res (global-conflicts-tn gtn))))
- (res)))))))
+ (let ((*list-conflicts-table* (make-hash-table :test 'eq)))
+ (unwind-protect
+ (do ((conf confs (global-conflicts-next-tnwise conf)))
+ ((null conf)
+ (listify-conflicts-table))
+ (format t "~&#<block ~D kind ~S>~%"
+ (block-number (ir2-block-block (global-conflicts-block
+ conf)))
+ (global-conflicts-kind conf))
+ (let ((block (global-conflicts-block conf)))
+ (add-always-live-tns block tn)
+ (if (eq (global-conflicts-kind conf) :live)
+ (add-all-local-tns block)
+ (let ((bconf (global-conflicts-conflicts conf))
+ (ltns (ir2-block-local-tns block)))
+ (dotimes (i (ir2-block-local-tn-count block))
+ (when (/= (sbit bconf i) 0)
+ (setf (gethash (svref ltns i) *list-conflicts-table*)
+ t)))))))
+ (clrhash *list-conflicts-table*))))
+ (t
+ (let* ((block (tn-local tn))
+ (ltns (ir2-block-local-tns block))
+ (confs (tn-local-conflicts tn)))
+ (collect ((res))
+ (dotimes (i (ir2-block-local-tn-count block))
+ (when (/= (sbit confs i) 0)
+ (let ((tn (svref ltns i)))
+ (when (and tn (not (eq tn :more))
+ (not (tn-global-conflicts tn)))
+ (res tn)))))
+ (do ((gtn (ir2-block-global-tns block)
+ (global-conflicts-next-blockwise gtn)))
+ ((null gtn))
+ (when (or (eq (global-conflicts-kind gtn) :live)
+ (/= (sbit confs (global-conflicts-number gtn)) 0))
+ (res (global-conflicts-tn gtn))))
+ (res)))))))
(defun nth-vop (thing n)
#!+sb-doc
"Return the Nth VOP in the IR2-BLOCK pointed to by THING."
(let ((block (block-info (block-or-lose thing))))
(do ((i 0 (1+ i))
- (vop (ir2-block-start-vop block) (vop-next vop)))
- ((= i n) vop))))
+ (vop (ir2-block-start-vop block) (vop-next vop)))
+ ((= i n) vop))))
projects / sbcl.git / blobdiff