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 closure-conversion bug for SCC with all free vars pruned

Browse source 
* module/language/cps/closure-conversion.scm (convert-one): Fix bug when
getting value of SCC whose free variables have been elided.  Thanks to
abcdw for the report!
* test-suite/tests/compiler.test ("cse auxiliary definitions"): Remove
spurious newline.
("closure conversion"): New test.
This commit is contained in:
Andy Wingo 2021-04-27 14:51:38 +02:00
parent 534dd35a3c
commit 12fa7d115d
2 changed files with 44 additions and 7 deletions
Download patch file Download diff file Expand all files Collapse all files

8
module/language/cps/closure-conversion.scm
View file

@ -504,11 +504,17 @@ Otherwise @var{var} is bound, so @var{k} is called with @var{var}."
;; A not-well-known function with zero free vars. Copy as a ;; A not-well-known function with zero free vars. Copy as a
;; constant, relying on the linker to reify just one copy. ;; constant, relying on the linker to reify just one copy.
=> (lambda (kfun) => (lambda (kfun)
;; It may well be that "var" is the "self" of another
;; member of an SCC containing just one not-well-known
;; function. But here we're asking for the value of the
;; closure, which is the $const-fun of the non-well-known
;; member.
(let ((kfun (closure-label kfun shared bound->label)))
(with-cps cps (with-cps cps
(letv var*) (letv var*)
(let$ body (k var*)) (let$ body (k var*))
(letk k* ($kargs (#f) (var*) ,body)) (letk k* ($kargs (#f) (var*) ,body))
(build-term ($continue k* #f ($const-fun kfun)))))) (build-term ($continue k* #f ($const-fun kfun)))))))
((intset-ref free var) ((intset-ref free var)
(if (and self-known? (eqv? 1 nfree)) (if (and self-known? (eqv? 1 nfree))
;; A reference to the one free var of a well-known function. ;; A reference to the one free var of a well-known function.

35
test-suite/tests/compiler.test
View file

@ -1,5 +1,5 @@
;;;; compiler.test --- tests for the compiler -*- scheme -*- ;;;; compiler.test --- tests for the compiler -*- scheme -*-
;;;; Copyright (C) 2008-2014, 2018 Free Software Foundation, Inc. ;;;; Copyright (C) 2008-2014, 2018, 2021 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -315,7 +315,6 @@
(loop (+ i 1) (thunk))) (loop (+ i 1) (thunk)))
(else (else
(unless (= result 42) (error "bad result" result)) (unless (= result 42) (error "bad result" result))
(newline)
result)))) result))))
(define (test n) (define (test n)
(let ((matrix (make-vector n))) (let ((matrix (make-vector n)))
@ -337,3 +336,35 @@
(pass-if-equal "test terminates without error" 42 (pass-if-equal "test terminates without error" 42
(test-proc))) (test-proc)))
(with-test-prefix "closure conversion"
(define test-code
'(lambda (arg)
(define (A a)
(let loop ((ls a))
(cond ((null? ls)
(B a))
((pair? ls)
(if (list? (car ls))
(loop (cdr ls))
#t))
(else #t))))
(define (B b)
(let loop ((ls b))
(cond ((null? ls)
(map A b))
((pair? ls)
(if (list? (car ls))
(loop (cdr ls))
(error "bad" b)))
(else
(error "bad" b)))))
(B arg)))
(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" '(#t #t)
(test-proc '((V X) (Y Z)))))