From: Andrea Corallo <akrl@sdf.org>
Date: Wed, 17 May 2023 16:00:24 +0000 (+0200)
Subject: comp: Propagate pre slot access type check
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=6c781b5d252057e04c612d0a2e3e10b91a1cfa96;p=emacs.git

comp: Propagate pre slot access type check

* lisp/loadup.el (max-lisp-eval-depth): Increase
`max-lisp-eval-depth' to 3400.

* lisp/emacs-lisp/comp.el (comp-add-cond-cstrs): Pattern match pre
slot access type check and add constraint.

* lisp/emacs-lisp/comp-cstr.el (comp-cstr-cl-tag-p)
(comp-cstr-cl-tag): New functions.

* lisp/emacs-lisp/comp.el (make-comp-mvar): Add neg parameter.
---

diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el
index 35e9ac45919..e9132552506 100644
--- a/lisp/emacs-lisp/comp-cstr.el
+++ b/lisp/emacs-lisp/comp-cstr.el
@@ -895,6 +895,23 @@ Non memoized version of `comp-cstr-intersection-no-mem'."
          (null (neg cstr))
          (equal (typeset cstr) '(cons)))))
 
+;; Move to comp.el?
+(defsubst comp-cstr-cl-tag-p (cstr)
+  "Return non-nil if CSTR is a CL tag."
+  (with-comp-cstr-accessors
+    (and (null (range cstr))
+         (null (neg cstr))
+         (null (typeset cstr))
+         (length= (valset cstr) 1)
+         (string-match (rx "cl-struct-" (group-n 1 (1+ not-newline)) "-tags")
+                       (symbol-name (car (valset cstr)))))))
+
+(defsubst comp-cstr-cl-tag (cstr)
+  "If CSTR is a CL tag return its tag name."
+  (with-comp-cstr-accessors
+    (and (comp-cstr-cl-tag-p cstr)
+         (intern (match-string 1 (symbol-name (car (valset cstr))))))))
+
 (defun comp-cstr-= (dst op1 op2)
   "Constraint OP1 being = OP2 setting the result into DST."
   (with-comp-cstr-accessors
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index fe72f0e73a4..8e59c06d40e 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -1543,7 +1543,7 @@ STACK-OFF is the index of the first slot frame involved."
                              for sp from stack-off
                              collect (comp-slot-n sp))))
 
-(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type)
+(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type neg)
   "`comp-mvar' initializer."
   (let ((mvar (make--comp-mvar :slot slot)))
     (when const-vld
@@ -1551,6 +1551,8 @@ STACK-OFF is the index of the first slot frame involved."
       (setf (comp-cstr-imm mvar) constant))
     (when type
       (setf (comp-mvar-typeset mvar) (list type)))
+    (when neg
+      (setf (comp-mvar-neg mvar) t))
     mvar))
 
 (defun comp-new-frame (size vsize &optional ssa)
@@ -2546,6 +2548,19 @@ TARGET-BB-SYM is the symbol name of the target block."
     for insns-seq on (comp-block-insns b)
     do
     (pcase insns-seq
+      (`((set ,(and (pred comp-mvar-p) mvar-tested-copy)
+              ,(and (pred comp-mvar-p) mvar-tested))
+         (set ,(and (pred comp-mvar-p) mvar-1)
+              (call type-of ,(and (pred comp-mvar-p) mvar-tested-copy)))
+         (set ,(and (pred comp-mvar-p) mvar-2)
+              (call symbol-value ,(and (pred comp-cstr-cl-tag-p) mvar-tag)))
+         (set ,(and (pred comp-mvar-p) mvar-3)
+              (call memq ,(and (pred comp-mvar-p) mvar-1) ,(and (pred comp-mvar-p) mvar-2)))
+         (cond-jump ,(and (pred comp-mvar-p) mvar-3) ,(pred comp-mvar-p) ,bb1 ,bb2))
+       (push  `(assume ,mvar-tested ,(make-comp-mvar :type (comp-cstr-cl-tag mvar-tag)))
+              (comp-block-insns (comp-add-cond-cstrs-target-block b bb2)))
+       (push  `(assume ,mvar-tested ,(make-comp-mvar :type (comp-cstr-cl-tag mvar-tag) :neg t))
+              (comp-block-insns (comp-add-cond-cstrs-target-block b bb1))))
       (`((set ,(and (pred comp-mvar-p) cmp-res)
               (,(pred comp-call-op-p)
                ,(and (or (pred comp-equality-fun-p)
diff --git a/lisp/loadup.el b/lisp/loadup.el
index 1cc70348267..7044a629848 100644
--- a/lisp/loadup.el
+++ b/lisp/loadup.el
@@ -103,7 +103,7 @@
       ;; During bootstrapping the byte-compiler is run interpreted
       ;; when compiling itself, which uses a lot more stack
       ;; than usual.
-      (setq max-lisp-eval-depth 2200)))
+      (setq max-lisp-eval-depth 3400)))
 
 (if (eq t purify-flag)
     ;; Hash consing saved around 11% of pure space in my tests.