From 4ba8549b0eb6816c2a026f31f15932d228c6490e Mon Sep 17 00:00:00 2001
From: Andrea Corallo <akrl@sdf.org>
Date: Tue, 23 May 2023 11:18:07 +0200
Subject: [PATCH] Add 'comp-type-check-optim' pass

* lisp/emacs-lisp/comp.el (comp-passes): Add 'comp--type-check-optim'.
(comp--type-check-optim-block, comp--type-check-optim): New functions.

(cherry picked from commit a1775552cef5a8bc0ba13e802ecf343423a53364)
---
 lisp/emacs-lisp/comp.el | 66 +++++++++++++++++++++++++++++++++++++++++
 1 file changed, 66 insertions(+)

diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 06261e30402..f5b35ec07b5 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -164,6 +164,7 @@ Can be one of: `d-default', `d-impure' or `d-ephemeral'.  See `comp-ctxt'.")
                         comp--ipa-pure
                         comp--add-cstrs
                         comp--fwprop
+                        comp--type-check-optim
                         comp--tco
                         comp--fwprop
                         comp--remove-type-hints
@@ -2812,6 +2813,71 @@ Return t if something was changed."
                  (comp--log-func comp-func 3))))
            (comp-ctxt-funcs-h comp-ctxt)))
 
+
+;;; Type check optimizer pass specific code.
+
+;; This pass optimize-out unnecessary type checks, that is calls to
+;; `type-of' and corresponding conditional branches.
+;;
+;; This is often advantageous in cases where a function manipulates an
+;; object with several slot accesses like:
+;;
+;; (cl-defstruct foo a b c)
+;; (defun bar (x)
+;;   (setf (foo-a x) 3)
+;;   (+ (foo-b x) (foo-c x)))
+;;
+;; After x is accessed and type checked once, it's proved to be of type
+;; foo, and no other type checks are required.
+
+;; At present running this pass over the whole Emacs codebase triggers
+;; the optimization of 1972 type checks.
+
+(defun comp--type-check-optim-block (block)
+  "Optimize conditional branches in BLOCK when possible."
+  (cl-loop
+   named in-the-basic-block
+   for insns-seq on (comp-block-insns block)
+   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))
+         (cl-assert (comp-cstr-imm-vld-p mvar-tag))
+         (when (and (length= (comp-mvar-typeset mvar-tested) 1)
+                    (member
+                     (car (comp-mvar-typeset mvar-tested))
+                     (symbol-value (comp-cstr-imm mvar-tag))))
+           (comp-log (format "Optimizing conditional branch in function: %s"
+                             (comp-func-name comp-func))
+                     3)
+           (setf (car insns-seq) '(comment "optimized by comp--type-check-optim")
+                 (cdr insns-seq) `((jump ,bb2))
+                 ;; Set the SSA status as dirty so
+                 ;; `comp--ssa-function' will remove the unreachable
+                 ;; branches later.
+                 (comp-func-ssa-status comp-func) 'dirty))))))
+
+(defun comp--type-check-optim (_)
+  "Optimize conditional branches when possible."
+  (cl-loop
+   for f being each hash-value of (comp-ctxt-funcs-h comp-ctxt)
+   for comp-func = f
+   when (>= (comp-func-speed f) 2)
+   do (cl-loop
+       for b being each hash-value of (comp-func-blocks f)
+       do (comp--type-check-optim-block b)
+       finally
+       (progn
+         (when (eq (comp-func-ssa-status f) 'dirty)
+           (comp--ssa-function f))
+         (comp--log-func comp-func 3)))))
+
 
 ;;; Call optimizer pass specific code.
 ;; This pass is responsible for the following optimizations:
-- 
2.39.2