master: Add a way to jump to lisp code tags from inline-vop
stassats via Sbcl-commits <[email protected]>
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via 30e1a2af345d26a05287f0e45720413d6d236deb (commit)
from 06df2ad72b00014341d066afe4984e4ae6d374e5 (commit)
- Log -----------------------------------------------------------------
commit 30e1a2af345d26a05287f0e45720413d6d236deb
Author: Stas Boukarev <[email protected]>
Date: Tue Aug 11 20:08:36 2026 +0300
Add a way to jump to lisp code tags from inline-vop
---
src/compiler/debug.lisp | 2 ++
src/compiler/generic/vm-fndb.lisp | 1 +
src/compiler/ir1-translators.lisp | 18 +++++++++++++
src/compiler/ir1util.lisp | 6 +++++
src/compiler/ir2tran.lisp | 9 +++++++
src/compiler/ltn.lisp | 2 ++
src/compiler/meta-vmdef.lisp | 55 +++++++++++++++++++++++++--------------
src/compiler/node.lisp | 5 ++++
src/compiler/xref.lisp | 2 +-
9 files changed, 79 insertions(+), 21 deletions(-)
diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp
index bce087617..3d36eb136 100644
--- a/src/compiler/debug.lisp
+++ b/src/compiler/debug.lisp
@@ -1052,6 +1052,8 @@
(loop for (index . target) in (jump-table-targets node)
do (format t "~a>" index)
(print-ctran (block-start target))))
+ (vop-jumper
+ (write-string "vop-jumper "))
(bind
(write-string "bind ")
(print-leaf (bind-lambda node))
diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp
index 9adbc4fc3..8c2085bfa 100644
--- a/src/compiler/generic/vm-fndb.lisp
+++ b/src/compiler/generic/vm-fndb.lisp
@@ -863,6 +863,7 @@
(values (simple-array * (*)) (or null index)))
(defknown restart-point (t) t ())
+(defknown jump-target (t) t ())
;;; formerly in 'float-tran'
diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index c6c5ba9cf..412ef890f 100644
--- a/src/compiler/ir1-translators.lisp
+++ b/src/compiler/ir1-translators.lisp
@@ -87,6 +87,24 @@ otherwise evaluate ELSE and return its values. ELSE defaults to NIL."
(link-blocks start-block block))
collect (cons index block))))))
+(def-ir1-translator vop-jumper ((&rest targets) start next result)
+ (declare (inline make-vop-jumper))
+ (let ((node (make-vop-jumper)))
+ (link-node-to-previous-ctran node start)
+ (let ((start-block (ctran-block start)))
+ (setf (block-last start-block) node)
+ (setf (vop-jumper-default node)
+ (ctran-starts-block next))
+ (link-blocks start-block (vop-jumper-default node))
+ (loop for tag in targets
+ for (nil ctran) = (or (lexenv-find tag tags :test #'eql)
+ (compiler-error "attempt to GO to nonexistent tag: ~S"
+ tag))
+ for block = (ctran-block ctran)
+ do
+ (unless (memq block (block-succ start-block))
+ (link-blocks start-block block))))))
+
;;; then or else can be already converted blocks
(def-ir1-translator if-to-blocks ((test then &optional else) start next result)
(flet ((to-block (x)
diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index a2d7d4d55..daab5d181 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -1875,6 +1875,11 @@
(unless (cdr (block-succ block))
(flush-dest (jump-table-index last))
(unlink-node last)))
+ (vop-jumper
+ (when (eq (vop-jumper-default last) old)
+ (setf (vop-jumper-default last) new))
+ (unless (memq new (block-succ block))
+ (link-blocks block new)))
(t
(unless (memq new (block-succ block))
(link-blocks block new)))))
@@ -2435,6 +2440,7 @@
(ref (delete-ref node))
(cif (flush-dest (if-test node)))
(jump-table (flush-dest (jump-table-index node)))
+ (vop-jumper)
;; The next two cases serve to maintain the invariant that a LET
;; always has a well-formed COMBINATION, REF and BIND. We delete
;; the lambda whenever we delete any of these, but we must be
diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index 2b7922cb3..5b8d28fa3 100644
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -2351,6 +2351,13 @@
(defoptimizer (restart-point ir2-convert) ((location) node block)
(setf (restart-location-label (lvar-value location))
(block-label (ir2-block-block block))))
+
+(defoptimizer (jump-target ir2-convert) ((tag) node)
+ (let ((ctran (second (or (lexenv-find (lvar-value tag) tags :test #'eql
+ :lexenv (node-lexenv node))
+ (compiler-error "attempt to GO to nonexistent tag: ~S"
+ tag)))))
+ (replace-combination-with-constant (ctran-block ctran) node)))
;;; Convert the code in a component into VOPs.
(defun ir2-convert (component)
@@ -2509,6 +2516,8 @@
(jump-table
(when (lvar-info (jump-table-index node))
(ir2-convert-jump-table node 2block)))
+ (vop-jumper
+ (vop branch node 2block (block-label (vop-jumper-default node))))
(bind
(let ((fun (bind-lambda node)))
(when (eq (lambda-home fun) fun)
diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp
index 83c5c32fa..e9622a985 100644
--- a/src/compiler/ltn.lisp
+++ b/src/compiler/ltn.lisp
@@ -1066,6 +1066,8 @@
(ltn-analyze-known-call node))))
(cif (ltn-analyze-if node))
(jump-table (ltn-analyze-jump-table node))
+ (vop-jumper
+ (setf (node-tail-p node) nil))
(creturn) ;; delay to FLUSH-FULL-CALL-TAIL-TRANSFERS
((or bind entry))
(exit (ltn-analyze-exit node))
diff --git a/src/compiler/meta-vmdef.lisp b/src/compiler/meta-vmdef.lisp
index 3dfc66464..73b650574 100644
--- a/src/compiler/meta-vmdef.lisp
+++ b/src/compiler/meta-vmdef.lisp
@@ -1835,7 +1835,8 @@
(infos)
(temps)
(results)
- (result-types))
+ (result-types)
+ (label-tags))
(flet ((sc-to-primtype (sc)
(case sc
(sb-vm::any-reg
@@ -1883,6 +1884,10 @@
do (cond ((eq name :info)
(infos this-sc)
(input arg))
+ ((eq name :label)
+ (label-tags this-sc)
+ (infos this-sc)
+ (input `(jump-target ',this-sc)))
(arg
(args (list* name :scs (list sc) rest))
(let ((type (or type (sc-to-primtype sc))))
@@ -1901,25 +1906,35 @@
prev)
do (results (list* name :scs (list sc) rest))
(result-types (or type (sc-to-primtype sc))))
- `(truly-the
- (values ,@(mapcar #'primtype-to-type (result-types)) &optional)
- (inline-%primitive
- ,(eval (%define-vop nil nil
- (delete nil
- (list* (and (args)
- (list* :args (args)))
- (and (arg-types)
- (list* :arg-types (arg-types)))
- (and (results)
- (list* :results (results)))
- (and (result-types)
- (list* :result-types (result-types)))
- (and (infos)
- (list* :info (infos)))
- (list* :generator 0 body)
- (temps)))
- nil))
- ,@(input))))))
+ (let ((form
+ `(truly-the
+ (values ,@(mapcar #'primtype-to-type (result-types)) &optional)
+ (inline-%primitive
+ ,(eval (%define-vop nil nil
+ (delete nil
+ (list* (and (args)
+ (list* :args (args)))
+ (and (arg-types)
+ (list* :arg-types (arg-types)))
+ (and (results)
+ (list* :results (results)))
+ (and (result-types)
+ (list* :result-types (result-types)))
+ (and (infos)
+ (list* :info (infos)))
+ (list* :generator 0
+ (if (label-tags)
+ `((let ,(loop for tag in (label-tags)
+ collect `(,tag (block-label ,tag)))
+ ,@body))
+ body))
+ (temps)))
+ nil))
+ ,@(input)))))
+ (if (label-tags)
+ `(multiple-value-prog1 ,form
+ (vop-jumper ,@(label-tags)))
+ form)))))
(macrolet
((def ()
diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp
index 031878523..3f13a16e0 100644
--- a/src/compiler/node.lisp
+++ b/src/compiler/node.lisp
@@ -1542,6 +1542,11 @@
index
targets)
+(defstruct (vop-jumper (:include multiple-successors-node)
+ (:constructor make-vop-jumper ())
+ (:copier nil))
+ (default nil))
+
(defstruct (cset (:include valued-node
(derived-type (make-single-value-type *universal-type*)))
(:conc-name set-)
diff --git a/src/compiler/xref.lisp b/src/compiler/xref.lisp
index 5fa150208..55dd4bd10 100644
--- a/src/compiler/xref.lisp
+++ b/src/compiler/xref.lisp
@@ -81,7 +81,7 @@
(declare (type node node))
(etypecase node
((or creturn cif entry mv-combination cast exit
- enclose cdynamic-extent jump-table))
+ enclose cdynamic-extent jump-table vop-jumper))
(combination
(let ((name (combination-fun-debug-name node)))
(when (equal name '(cas symbol-value))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL