wingo pushed a commit to branch master in repository guile. commit 498428fbef63d9159d84f18f719e02927341aa9a Author: Andy Wingo <wi...@pobox.com> AuthorDate: Wed May 13 14:22:37 2020 +0200
Add with-lexicals helper; fix bug in (equal? #t (foo) #t) * module/language/tree-il.scm (with-lexicals): New public helper. * .dir-locals.el (with-lexicals): Add indentation rule. * module/language/tree-il/compile-bytecode.scm (canonicalize): Use with-lexicals. * module/language/tree-il/compile-cps.scm (canonicalize): Use with-lexicals from tree-il. * module/language/tree-il/primitives.scm (chained-comparison-expander): Remove duplicate expander definitions for <, <=, and so on. * module/language/tree-il/primitives.scm (maybe-simplify-to-eq): Avoid inadvertent code duplication by using with-lexicals. (expand-chained-comparisons): Likewise. (call-with-prompt): Simplify to use with-lexicals. --- .dir-locals.el | 1 + module/language/tree-il.scm | 17 ++++++- module/language/tree-il/compile-bytecode.scm | 10 ++-- module/language/tree-il/compile-cps.scm | 21 ++------ module/language/tree-il/primitives.scm | 74 ++++++++++------------------ 5 files changed, 50 insertions(+), 73 deletions(-) diff --git a/.dir-locals.el b/.dir-locals.el index c987955..3c6519f 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -19,6 +19,7 @@ (eval . (put 'with-fresh-name-state-from-dfg 'scheme-indent-function 1)) (eval . (put 'with-cps 'scheme-indent-function 1)) (eval . (put 'with-cps-constants 'scheme-indent-function 1)) + (eval . (put 'with-lexicals 'scheme-indent-function 2)) (eval . (put 'build-cps-term 'scheme-indent-function 0)) (eval . (put 'build-cps-exp 'scheme-indent-function 0)) (eval . (put 'build-cps-cont 'scheme-indent-function 0)) diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index 77d6f23..974fce2 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -1,4 +1,4 @@ -;;;; Copyright (C) 2009-2014, 2017-2019 Free Software Foundation, Inc. +;;;; Copyright (C) 2009-2014, 2017-2020 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 @@ -60,6 +60,7 @@ make-tree-il-folder post-order pre-order + with-lexicals tree-il=? tree-il-hash)) @@ -568,6 +569,20 @@ This is an implementation of `foldts' as described by Andy Wingo in (define (pre-order f x) (pre-post-order f (lambda (x) x) x)) +(define-syntax-rule (with-lexical src id . body) + (let ((k (lambda (id) . body))) + (match id + (($ <lexical-ref>) (k id)) + (_ + (let ((tmp (gensym "v "))) + (make-let src (list 'id) (list tmp) (list id) + (k (make-lexical-ref src 'id tmp)))))))) +(define-syntax with-lexicals + (syntax-rules () + ((with-lexicals src () . body) (let () . body)) + ((with-lexicals src (id . ids) . body) + (with-lexical src id (with-lexicals src ids . body))))) + ;; FIXME: We should have a better primitive than this. (define (struct-nfields x) (/ (string-length (symbol->string (struct-layout x))) 2)) diff --git a/module/language/tree-il/compile-bytecode.scm b/module/language/tree-il/compile-bytecode.scm index 96f5eb8..b8d432f 100644 --- a/module/language/tree-il/compile-bytecode.scm +++ b/module/language/tree-il/compile-bytecode.scm @@ -432,12 +432,10 @@ ;; struct-set! needs to return its value. (($ <primcall> src 'struct-set! (x idx v)) - (let ((sym (gensym "v "))) - (make-let src (list 'v) (list sym) (list v) - (let ((v (make-lexical-ref src 'v sym))) - (make-seq src - (make-primcall src 'struct-set! (list x idx v)) - v))))) + (with-lexicals src (v) + (make-seq src + (make-primcall src 'struct-set! (list x idx v)) + v))) ;; Transform "ash" to lsh / rsh. (($ <primcall> src 'ash (x ($ <const> src (? exact-integer? y)))) diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 703e9fd..bd2bd77 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -2303,19 +2303,6 @@ integer." (define *comp-module* (make-fluid)) (define (canonicalize exp) - (define-syntax-rule (with-lexical src id . body) - (let ((k (lambda (id) . body))) - (match id - (($ <lexical-ref>) (k id)) - (_ - (let ((v (gensym "v "))) - (make-let src (list 'v) (list v) (list id) - (k (make-lexical-ref src 'v v)))))))) - (define-syntax with-lexicals - (syntax-rules () - ((with-lexicals src () . body) (let () . body)) - ((with-lexicals src (id . ids) . body) - (with-lexical src id (with-lexicals src ids . body))))) (define (reduce-conditional exp) (match exp (($ <conditional> src @@ -2348,10 +2335,9 @@ integer." (evaluate-args-eagerly-if-needed src inits (lambda (inits) (k (cons init inits))))) (_ - (with-lexical - src init - (evaluate-args-eagerly-if-needed - src inits (lambda (inits) (k (cons init inits)))))))))) + (with-lexicals src (init) + (evaluate-args-eagerly-if-needed + src inits (lambda (inits) (k (cons init inits)))))))))) (post-order (lambda (exp) (match exp @@ -2521,5 +2507,4 @@ integer." ;;; Local Variables: ;;; eval: (put 'convert-arg 'scheme-indent-function 2) ;;; eval: (put 'convert-args 'scheme-indent-function 2) -;;; eval: (put 'with-lexicals 'scheme-indent-function 2) ;;; End: diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index b1fa344..f97da97 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -560,28 +560,6 @@ (define-primitive-expander f64vector-set! (vec i x) (bytevector-ieee-double-native-set! vec (* i 8) x)) -(define (chained-comparison-expander prim-name) - (case-lambda - ((src) (make-const src #t)) - ((src a) #f) - ((src a b) #f) - ((src a b . rest) - (let* ((b-sym (gensym "b")) - (b* (make-lexical-ref src 'b b-sym))) - (make-let src - '(b) - (list b-sym) - (list b) - (make-conditional src - (make-primcall src prim-name (list a b*)) - (make-primcall src prim-name (cons b* rest)) - (make-const src #f))))))) - -(for-each (lambda (prim-name) - (define-primitive-expander! prim-name - (chained-comparison-expander prim-name))) - '(< > <= >= =)) - (define (character-comparison-expander char< <) (lambda (src . args) (expand-primcall @@ -619,9 +597,10 @@ (make-primcall src 'eq? (list a b)))))) (or (maybe-simplify a b) (maybe-simplify b a))) ((src a b . rest) - (make-conditional src (make-primcall src prim (list a b)) - (make-primcall src prim (cons b rest)) - (make-const src #f))) + (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))) (define-primitive-expander! 'eqv? (maybe-simplify-to-eq 'eqv?)) @@ -638,9 +617,10 @@ (make-const src #t))) ((src a b) #f) ((src a b . rest) - (make-conditional src (make-primcall src prim (list a b)) - (make-primcall src prim (cons b rest)) - (make-const src #f))) + (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))) (for-each (lambda (prim) @@ -662,26 +642,24 @@ (make-primcall src 'name (list . args))) (define-syntax-rule (const val) (make-const src val)) - (make-let - src (list 'handler) (list h) (list handler) - (let ((handler (make-lexical-ref src 'handler h))) - (make-conditional - src - (primcall procedure? handler) - (make-prompt - src #f tag thunk - (make-lambda - src '() - (make-lambda-case - src '() #f 'args #f '() (list args) - (primcall apply handler (make-lexical-ref #f 'args args)) - #f))) - (primcall throw - (const 'wrong-type-arg) - (const "call-with-prompt") - (const "Wrong type (expecting procedure): ~S") - (primcall list handler) - (primcall list handler))))))))) + (with-lexicals src (handler) + (make-conditional + src + (primcall procedure? handler) + (make-prompt + src #f tag thunk + (make-lambda + src '() + (make-lambda-case + src '() #f 'args #f '() (list args) + (primcall apply handler (make-lexical-ref #f 'args args)) + #f))) + (primcall throw + (const 'wrong-type-arg) + (const "call-with-prompt") + (const "Wrong type (expecting procedure): ~S") + (primcall list handler) + (primcall list handler)))))))) (else #f))) (define-primitive-expander! 'abort-to-prompt*