[Guile-commits] 01/02: Fix order-of-side-effects bug in (eq? x y z) expansion

[Andy Wingo]

wingo pushed a commit to branch main
in repository guile.

commit d184d093466a536281dfc2bcb9eb727f6facdeb4
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Thu Dec 1 12:56:51 2022 +0100

    Fix order-of-side-effects bug in (eq? x y z) expansion
    
    * module/language/tree-il/primitives.scm (bind-lexicals): New helper.
    (expand-eq, expand-chained-comparisons): Ensure all arguments are
    eagerly evaluated.  Previously an intermediate #f result would shortcut
    the evaluation.
    * test-suite/tests/compiler.test ("size effects in multi-arg eq / <"):
    Add test.
---
 module/language/tree-il/primitives.scm | 46 +++++++++++++++++++++++++---------
 test-suite/tests/compiler.test         | 11 ++++++++
 2 files changed, 45 insertions(+), 12 deletions(-)

diff --git a/module/language/tree-il/primitives.scm 
b/module/language/tree-il/primitives.scm
index 7f3746b4f..135a1f56f 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -1,6 +1,6 @@
 ;;; open-coding primitive procedures
 
-;; Copyright (C) 2009-2015, 2017-2021 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2015, 2017-2022 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -568,17 +568,32 @@
 (define-primitive-expander f64vector-set! (vec i x)
   (bytevector-ieee-double-native-set! vec (* i 8) x))
 
+(define (bind-lexicals src exps k)
+  (match exps
+    (() (k '()))
+    ((exp . exps)
+     (with-lexicals src (exp)
+       (bind-lexicals src exps (lambda (exps) (k (cons exp exps))))))))
+
 (define (expand-eq prim)
   (case-lambda
     ((src) (make-const src #t))
     ((src a) (make-const src #t))
     ((src a b) #f)
-    ((src a b . rest)
-     (with-lexicals src (b)
-       (make-conditional src (make-primcall src prim (list a b))
-                         (make-primcall src prim (cons b rest))
-                         (make-const src #f))))
-    (else #f)))
+    ((src . args)
+     (bind-lexicals
+      src args
+      (lambda (args)
+        (match args
+          ((a . args)
+           (let lp ((args args))
+             (match args
+               ((b)
+                (make-primcall src prim (list a b)))
+               ((b . args)
+                (make-conditional src (make-primcall src prim (list a b))
+                                  (lp args)
+                                  (make-const src #f))))))))))))
 
 (define-primitive-expander! 'eq?    (expand-eq 'eq?))
 (define-primitive-expander! 'eqv?   (expand-eq 'eqv?))
@@ -594,11 +609,18 @@
                (make-primcall src prim (list a (make-const src 0)))
                (make-const src #t)))
     ((src a b) #f)
-    ((src a b . rest)
-     (with-lexicals src (b)
-       (make-conditional src (make-primcall src prim (list a b))
-                         (make-primcall src prim (cons b rest))
-                         (make-const src #f))))
+    ((src . args)
+     (bind-lexicals
+      src args
+      (lambda (args)
+        (let lp ((args args))
+          (match args
+            ((a b)
+             (make-primcall src prim (list a b)))
+            ((a b . args)
+             (make-conditional src (make-primcall src prim (list a b))
+                               (lp (cons b args))
+                               (make-const src #f))))))))
     (else #f)))
 
 (for-each (lambda (prim)
diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test
index 67d8d9ed9..a018e0c41 100644
--- a/test-suite/tests/compiler.test
+++ b/test-suite/tests/compiler.test
@@ -401,6 +401,17 @@
   (pass-if-equal "foo bar" 'qux (test-proc 'foo 'bar))
   (pass-if-equal "foo two" 'foo (test-proc 'foo 'two)))
 
+(with-test-prefix "size effects in multi-arg eq / <"
+  (pass-if-equal "eq?" 42
+    (compile '(catch 'foo
+                (lambda () (= 0 1 (throw 'foo)))
+                (lambda (k) 42))))
+
+  (pass-if-equal "<" 42
+    (compile '(catch 'foo
+                (lambda () (< 0 -1 (throw 'foo)))
+                (lambda (k) 42)))))
+
 (with-test-prefix "read-and-compile tree-il"
   (let ((code
          "\