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

Add with-lexicals helper; fix bug in (equal? #t (foo) #t)

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2020-05-13 14:22:37 +02:00
parent 31bb0eea8c
commit 498428fbef
5 changed files with 50 additions and 73 deletions
Download patch file Download diff file Expand all files Collapse all files

1
.dir-locals.el
View file

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

17
module/language/tree-il.scm
View file

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

10
module/language/tree-il/compile-bytecode.scm
View file

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

21
module/language/tree-il/compile-cps.scm
View file

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

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

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