From 159bda56c35137cfb4123cac9802acce2af22507 Mon Sep 17 00:00:00 2001
From: Kris Katterjohn <katterjohn@gmail.com>
Date: Sat, 12 Nov 2022 22:42:15 -0500
Subject: [PATCH] Fix the inefficient evaluation of translated predicates

Translated predicates that don't evaluate to a boolean value have
been needlessly doing extra and repeated work.

For example, a > comparison would translate to a MGRP call followed
by IS-BOOLE-CHECK or MAYBE-BOOLE-CHECK.  If the comparison didn't
yield a boolean, then a MGRP expression would be returned by MGRP,
which would get passed to a FOO-BOOLE-CHECK, which would then call
MEVALP_TR to evaluate the expression, which eventually just calls
MGRP yet again.

An upcoming commit will be making changes to translated predicates,
and after that this bug would cause a much more significant slow down
in various cases.

No problems with the test suite, share test suite or rtest_translator.
---
 src/acall.lisp  | 42 ++++++++++++++++++++++++++++++------------
 src/trpred.lisp | 31 ++++++++++++++++++-------------
 2 files changed, 48 insertions(+), 25 deletions(-)

diff --git a/src/acall.lisp b/src/acall.lisp
index 25df390c2..a54071efb 100644
--- a/src/acall.lisp
+++ b/src/acall.lisp
@@ -267,27 +267,45 @@
 ;;; result, which is wrong, not to mention being incompatible with
 ;;; the interpreter.
 
-(defun boole-check (form error?)
-  ; We check for booleans quickly, otherwise go for the database.
+(defun boole-verify (form error? $unknown?)
+  (cond ((typep form 'boolean)
+         form)
+        (error?
+         (pre-err form))
+        ($unknown?
+         '$unknown)
+        (t
+         form)))
+
+(defun boole-eval (form error? $unknown?)
   (if (typep form 'boolean)
       form
       (let ((ans (mevalp_tr form error?)))
-        (if (typep ans 'boolean)
+        (if (or (typep ans 'boolean)
+                (not $unknown?))
             ans
             '$unknown))))
 
-(defun is-boole-check (form)
-  (boole-check form $prederror))
+(defun $is-boole-verify (form)
+  (boole-verify form $prederror t))
 
-(defun maybe-boole-check (form)
-  (boole-check form nil))
+(defun $is-boole-eval (form)
+  (boole-eval form $prederror t))
+
+(setf (get '$is 'tr-boole-verify) '$is-boole-verify)
+(setf (get '$is 'tr-boole-eval) '$is-boole-eval)
+
+(defun $maybe-boole-verify (form)
+  (boole-verify form nil t))
+
+(defun $maybe-boole-eval (form)
+  (boole-eval form nil t))
+
+(setf (get '$maybe 'tr-boole-verify) '$maybe-boole-verify)
+(setf (get '$maybe 'tr-boole-eval) '$maybe-boole-eval)
 
 (defun mevalp_tr (pat error?)
-  (let ((ans (mevalp1_tr pat error?)))
-    (cond ((typep ans 'boolean) ans)
-	  (error?
-	   (pre-err pat))
-	  (t ans))))
+  (boole-verify (mevalp1_tr pat error?) error? nil))
 
 (defun mevalp1_tr (pat error?)
   (cond ((atom pat) pat)
diff --git a/src/trpred.lisp b/src/trpred.lisp
index 4cb12c029..de2214bf3 100644
--- a/src/trpred.lisp
+++ b/src/trpred.lisp
@@ -12,13 +12,18 @@
 
 (macsyma-module trpred)
 
-(defvar wrap-an-is 'is-boole-check "How to verify booleans")
-
-(defun wrap-an-is (exp)
-  (cons '$any (list wrap-an-is exp)))
-
-(defun tr-is/maybe (boole-check form)
-  (let* ((wrap-an-is boole-check)
+; $is or $maybe
+(defvar wrap-a-pred '$is)
+
+(defun wrap-pred (form &optional (evalp t))
+  (let ((boole-fun (get wrap-a-pred
+                        (if evalp
+                            'tr-boole-eval
+                            'tr-boole-verify))))
+    (cons '$any `(,boole-fun ,form))))
+
+(defun tr-is/maybe (wrap-type form)
+  (let* ((wrap-a-pred wrap-type)
          (tr (translate-predicate form)))
     (destructuring-bind (mode . tr-form) tr
       (if (eq mode '$boolean)
@@ -26,10 +31,10 @@
           (cons '$any tr-form)))))
 
 (def%tr $is (form)
-  (tr-is/maybe 'is-boole-check (cadr form)))
+  (tr-is/maybe '$is (cadr form)))
 
 (def%tr $maybe (form)
-  (tr-is/maybe 'maybe-boole-check (cadr form)))
+  (tr-is/maybe '$maybe (cadr form)))
 
 ;;; these don't have an imperitive predicate semantics outside of
 ;;; being used in MNOT, MAND, MOR, MCOND, $IS.
@@ -87,7 +92,7 @@
     (destructuring-bind (mode . exp) tr
       (if (eq mode '$boolean)
           tr
-          (wrap-an-is exp)))))
+          (wrap-pred exp)))))
 
 (defun trp-mnot (form) 
   (setq form (cdr (translate-predicate (cadr form))))
@@ -133,7 +138,7 @@
 	  ((eq '$number mode)
 	   `($boolean . (> ,(cdr arg1) ,(cdr arg2))))
 	  ('else
-	   (wrap-an-is `(mgrp ,(dconvx arg1) ,(dconvx arg2)))))))
+	   (wrap-pred `(mgrp ,(dconvx arg1) ,(dconvx arg2)) nil)))))
  
 (defun trp-mlessp (form) 
   (let (mode arg1 arg2)
@@ -146,7 +151,7 @@
 	  ((eq '$number mode)
 	   `($boolean . (< ,(cdr arg1) ,(cdr arg2))))
 	  ('else
-	   (wrap-an-is `(mlsp ,(dconvx arg1) ,(dconvx arg2)))))))
+	   (wrap-pred `(mlsp ,(dconvx arg1) ,(dconvx arg2)) nil)))))
 
 (defun trp-mequal (form) 
   (destructuring-let (((mode1 . arg1) (translate (cadr form)))
@@ -165,7 +170,7 @@
 	  ((eq '$number mode)
 	   `($any . (meqp ,(cdr arg1) ,(cdr arg2))))
 	  ('else
-	   (wrap-an-is `(meqp ,(dconvx arg1) ,(dconvx arg2)))))))
+	   (wrap-pred `(meqp ,(dconvx arg1) ,(dconvx arg2)) nil)))))
 
 ;; Logical not for predicates.  Do the expected thing, except return
 (defun trp-not (val)
-- 
2.11.4.GIT