[prev in list] [next in list] [prev in thread] [next in thread] 

List:       sbcl-commits
Subject:    [Sbcl-commits] master: ir1-transform-type-predicate: don't transform to some intersections.
From:       stassats via Sbcl-commits <sbcl-commits () lists ! sourceforge ! net>
Date:       2023-06-30 11:24:16
Message-ID: 1688124257.4265.26284 () sfp-scm-3 ! v30 ! lw ! sourceforge ! com
[Download RAW message or body]

The branch "master" has been updated in SBCL:
       via  a105c51e016924e7de1b7608b528f84daf897e02 (commit)
      from  3e9848156ec8665008eb603d1988f911f4df6691 (commit)

- Log -----------------------------------------------------------------
commit a105c51e016924e7de1b7608b528f84daf897e02
Author: Stas Boukarev <stassats@gmail.com>
Date:   Fri Jun 30 13:47:09 2023 +0300

    ir1-transform-type-predicate: don't transform to some intersections.
    
    Some subtypes are more expensive to check and some end up being
    transformed in an infinite loop.
    
    Fixes lp#2025405
---
 src/compiler/arm64/type-vops.lisp |  7 ++++---
 src/compiler/typetran.lisp        | 10 +++++++++-
 2 files changed, 13 insertions(+), 4 deletions(-)

diff --git a/src/compiler/arm64/type-vops.lisp b/src/compiler/arm64/type-vops.lisp
index 9db962b33..b1db418e9 100644
--- a/src/compiler/arm64/type-vops.lisp
+++ b/src/compiler/arm64/type-vops.lisp
@@ -38,11 +38,12 @@
   (cond ((= immediate single-float-widetag)
          (when (types-equal-or-intersect (tn-ref-type value-tn-ref)
                                          (specifier-type 'single-float))
-           (inst cmp (32-bit-reg value) single-float-widetag)))
+           (inst cmp (32-bit-reg value) single-float-widetag)
+           (inst b :eq (if not-p drop-through target))))
         (t
          (inst mov temp immediate)
-         (inst cmp temp (extend value :uxtb))))
-  (inst b :eq (if not-p drop-through target))
+         (inst cmp temp (extend value :uxtb))
+         (inst b :eq (if not-p drop-through target))))
   (%test-headers value temp target not-p nil headers
                  :drop-through drop-through
                  :value-tn-ref value-tn-ref
diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index c39104002..eb81a34df 100644
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -120,8 +120,16 @@
                      (current (combination-fun-source-name node)))
                  (when (and new-predicate
                             (neq new-predicate current)
+                            ;; Some subtypes are more expensive to check
                             (not (and (eq current 'listp)
-                                      (eq new-predicate 'consp))))
+                                      (eq new-predicate 'consp)))
+                            (not (and (eq current 'functionp)
+                                      (eq new-predicate 'compiled-function-p)))
+                            (not (eq current 'characterp))
+                            (not (eq new-predicate #+64-bit 'signed-byte-64-p
+                                                   #-64-bit 'signed-byte-32-p))
+                            (not (eq new-predicate #+64-bit 'unsigned-byte-64-p
+                                                   #-64-bit 'unsigned-byte-32-p)))
                    `(,new-predicate object))))
               ;; (typep (the float x) 'double-float) =>
               ;; (typep x 'single-float)

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL


_______________________________________________
Sbcl-commits mailing list
Sbcl-commits@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/sbcl-commits
[prev in list] [next in list] [prev in thread] [next in thread]