From a9d69aba79fde8125d0c25d4560e5e0dd9158d42 Mon Sep 17 00:00:00 2001
From: Stas Boukarev <stassats@gmail.com>
Date: Tue, 30 Apr 2024 11:24:32 +0300
Subject: [PATCH] Don't lose lvar-types for some VOPs.

(when (typep y '(or fixnum null))
  (rplaca x y))

was issuing gengc-barriers because of that.
---
 src/compiler/generic/vm-ir2tran.lisp |  6 +++---
 src/compiler/meta-vmdef.lisp         | 18 ++++++++++++------
 2 files changed, 15 insertions(+), 9 deletions(-)

diff --git a/src/compiler/generic/vm-ir2tran.lisp b/src/compiler/generic/vm-ir2tran.lisp
index 64c67d67f..6cda727f0 100644
--- a/src/compiler/generic/vm-ir2tran.lisp
+++ b/src/compiler/generic/vm-ir2tran.lisp
@@ -47,7 +47,7 @@
 
 (defoptimizer ir2-convert-setter ((object value) node block name offset lowtag)
   (let ((value-tn (lvar-tn node block value)))
-    (vop set-slot node block (lvar-tn node block object) value-tn
+    (vop set-slot node block (lvar-tn node block object) (:lvar value value-tn)
          name offset lowtag)
     (move-lvar-result node block (list value-tn) (node-lvar node))))
 
@@ -67,8 +67,8 @@
          (res (first locs)))
     (vop compare-and-swap-slot node block
          (lvar-tn node block object)
-         (lvar-tn node block old)
-         (lvar-tn node block new)
+         (:lvar old (lvar-tn node block old))
+         (:lvar new (lvar-tn node block new))
          name offset lowtag
          res)
     (move-lvar-result node block locs lvar)))
diff --git a/src/compiler/meta-vmdef.lisp b/src/compiler/meta-vmdef.lisp
index cf874806c..73e550f21 100644
--- a/src/compiler/meta-vmdef.lisp
+++ b/src/compiler/meta-vmdef.lisp
@@ -2010,12 +2010,18 @@
     (let ((n-head nil)
           (n-prev nil))
       (dolist (op fixed)
-        (let ((n-ref (gensym)))
-          (binds `(,n-ref (reference-tn ,op ,write-p)))
-          (if n-prev
-              (forms `(setf (tn-ref-across ,n-prev) ,n-ref))
-              (setq n-head n-ref))
-          (setq n-prev n-ref)))
+        (multiple-value-bind (op lvar)
+            (if (typep op '(cons (eql :lvar)))
+                (values (third op) (second op))
+                op)
+          (let ((n-ref (gensym)))
+            (binds `(,n-ref (reference-tn ,op ,write-p)))
+            (when lvar
+              (forms `(setf (tn-ref-type ,n-ref) (lvar-type ,lvar))))
+            (if n-prev
+                (forms `(setf (tn-ref-across ,n-prev) ,n-ref))
+                (setq n-head n-ref))
+            (setq n-prev n-ref))))
 
       (when more
         (let ((n-more (gensym)))
-- 
2.11.4.GIT