[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/03: Fix bug in CSE auxiliary definitions
From: |
Andy Wingo |
Subject: |
[Guile-commits] 01/03: Fix bug in CSE auxiliary definitions |
Date: |
Wed, 28 Aug 2019 04:49:07 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit a2f5f9eda4949c62c5a01e0da71605343be3df60
Author: Andy Wingo <address@hidden>
Date: Wed Aug 28 10:24:54 2019 +0200
Fix bug in CSE auxiliary definitions
* module/language/cps/cse.scm (compute-equivalent-subexpressions): When
CSE sees a definition like `(cons a b)', it will also record an
"auxiliary definition" for `(car x)', where x is the variable defined
by the cons, whereby calling `(car x)' can reduce to `a' if there is
no intervening effect that clobbers the definitions. However, when
the successor of the cons is a control-flow join, then any variables
defined there have multiple definitions. It's incorrect to add the
aux definition in that case.
* test-suite/tests/compiler.test ("cse auxiliary definitions"): New
test.
---
module/language/cps/cse.scm | 35 +++++++++++++++++++----------------
test-suite/tests/compiler.test | 37 +++++++++++++++++++++++++++++++++++++
2 files changed, 56 insertions(+), 16 deletions(-)
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index 9f3b3da..8ecd6f3 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013, 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2019 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
@@ -225,9 +225,8 @@ false. It could be that both true and false proofs are
available."
(cons* op param (subst-vars var-substs args)))
((or ($ $prompt) ($ $throw)) #f)))
- (define (add-auxiliary-definitions! label var-substs term-key)
- (let ((defs (and=> (intmap-ref defs label)
- (lambda (defs) (subst-vars var-substs defs)))))
+ (define (add-auxiliary-definitions! label defs var-substs term-key)
+ (let ((defs (and defs (subst-vars var-substs defs))))
(define (add-def! aux-key var)
(let ((equiv (hash-ref equiv-set aux-key '())))
(hash-set! equiv-set aux-key
@@ -242,6 +241,10 @@ false. It could be that both true and false proofs are
available."
(match term-key
(('op arg ...)
(match defs
+ (#f
+ ;; If the successor is a control-flow join, don't
+ ;; pretend to know the values of its defs.
+ #f)
((def) (add-def! (list 'op* arg* ...) aux) ...)))
(_ (add-definitions . clauses))))
((add-definitions
@@ -296,13 +299,13 @@ false. It could be that both true and false proofs are
available."
(let* ((equiv (hash-ref equiv-set term-key '()))
(fx (intmap-ref effects label))
(avail (intmap-ref avail label)))
- (define (finish equiv-labels var-substs)
+ (define (finish equiv-labels var-substs defs)
;; If this expression defines auxiliary definitions,
;; as `cons' does for the results of `car' and `cdr',
;; define those. Do so after finding equivalent
;; expressions, so that we can take advantage of
;; subst'd output vars.
- (add-auxiliary-definitions! label var-substs term-key)
+ (add-auxiliary-definitions! label defs var-substs term-key)
(values equiv-labels var-substs))
(let lp ((candidates equiv))
(match candidates
@@ -314,13 +317,12 @@ false. It could be that both true and false proofs are
available."
;; be eliminated by CSE (though DCE might do it
;; if the value proves to be unused, in the
;; allocation case).
- (when (and (not (causes-effect? fx &allocation))
- (not (effect-clobbers? fx (&read-object
&fluid))))
- (let ((defs (term-defs term)))
- (when defs
- (hash-set! equiv-set term-key
- (acons label defs equiv)))))
- (finish equiv-labels var-substs))
+ (let ((defs (term-defs term)))
+ (when (and defs
+ (not (causes-effect? fx &allocation))
+ (not (effect-clobbers? fx (&read-object
&fluid))))
+ (hash-set! equiv-set term-key (acons label defs
equiv)))
+ (finish equiv-labels var-substs defs)))
(((and head (candidate . vars)) . candidates)
(cond
((not (intset-ref avail candidate))
@@ -331,13 +333,14 @@ false. It could be that both true and false proofs are
available."
;; Yay, a match. Mark expression as equivalent. If
;; we provide the definitions for the successor, mark
;; the vars for substitution.
- (finish (intmap-add equiv-labels label head)
- (let ((defs (term-defs term)))
+ (let ((defs (term-defs term)))
+ (finish (intmap-add equiv-labels label head)
(if defs
(fold (lambda (def var var-substs)
(intmap-add var-substs def var))
var-substs defs vars)
- var-substs))))))))))))
+ var-substs)
+ defs)))))))))))
(_ (values equiv-labels var-substs))))
;; Traverse the labels in fun in reverse post-order, which will
diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test
index 64bb976..dc75d0a 100644
--- a/test-suite/tests/compiler.test
+++ b/test-suite/tests/compiler.test
@@ -300,3 +300,40 @@
(cons 't (if x 't 'f))
(cons 'f (if x 't 'f)))))
'(3 #t #f #nil ()))))
+
+(with-test-prefix "cse auxiliary definitions"
+ (define test-code
+ '(begin
+ (define count 1)
+ (set! count count) ;; Avoid inlining
+
+ (define (main)
+ (define (trampoline thunk)
+ (let loop ((i 0) (result #f))
+ (cond
+ ((< i 1)
+ (loop (+ i 1) (thunk)))
+ (else
+ (unless (= result 42) (error "bad result" result))
+ (newline)
+ result))))
+ (define (test n)
+ (let ((matrix (make-vector n)))
+ (let loop ((i (- n 1)))
+ (when (>= i 0)
+ (vector-set! matrix i (make-vector n 42))
+ (loop (- i 1))))
+ (vector-ref (vector-ref matrix 0) 0)))
+
+ (trampoline (lambda () (test count))))
+ main))
+
+ (define test-proc #f)
+ (pass-if "compiling test works"
+ (begin
+ (set! test-proc (compile test-code))
+ (procedure? test-proc)))
+
+ (pass-if-equal "test terminates without error" 42
+ (test-proc)))
+