mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Fix order-of-side-effects bug in (eq? x y z) expansion

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2022-12-01 12:56:51 +01:00
parent c7fa78fc75
commit d184d09346
2 changed files with 45 additions and 12 deletions
Download patch file Download diff file Expand all files Collapse all files

46
module/language/tree-il/primitives.scm
View file

@ -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)