mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00
Code Activity

"fix" <let>-bound lambda expressions too

Browse source 
* module/language/tree-il/compile-glil.scm (compile-glil): Compute
  warnings before optimizing, as unreferenced variables will be
  optimized out.

* libguile/_scm.h: Fix C99 comment.

* module/language/tree-il/fix-letrec.scm (partition-vars): Also analyze
  let-bound vars.
  (fix-letrec!): Fix a bug whereby a set! to an unreffed var would be
  called for value, not effect. Also "fix" <let>-bound lambda
  expressions -- really speeds up pmatch.

* test-suite/tests/tree-il.test ("lexical sets", "the or hack"): Update
  to take into account the new optimizations.
This commit is contained in:
Andy Wingo 2009-08-12 20:44:30 +02:00
parent eca29b0202
commit aaae0d5ab3
4 changed files with 90 additions and 23 deletions
Download patch file Download diff file Expand all files Collapse all files

2
libguile/_scm.h
View file

@ -170,7 +170,7 @@
/* The word size marker in objcode. */
#define SCM_OBJCODE_WORD_SIZE SCM_CPP_STRINGIFY (SIZEOF_VOID_P)
// major and minor versions must be single characters
/* Major and minor versions must be single characters. */
#define SCM_OBJCODE_MAJOR_VERSION 0
#define SCM_OBJCODE_MINOR_VERSION B
#define SCM_OBJCODE_MAJOR_VERSION_STRING \

14
module/language/tree-il/compile-glil.scm
View file

@ -53,16 +53,16 @@
(or (and=> (memq #:warnings opts) cadr)
'()))
(let* ((x (make-lambda (tree-il-src x) '() '() '() x))
(x (optimize! x e opts))
(allocation (analyze-lexicals x)))
;; Go throught the warning passes.
(for-each (lambda (kind)
;; Go throught the warning passes.
(for-each (lambda (kind)
(let ((warn (assoc-ref %warning-passes kind)))
(and (procedure? warn)
(warn x))))
warnings)
warnings)
(let* ((x (make-lambda (tree-il-src x) '() '() '() x))
(x (optimize! x e opts))
(allocation (analyze-lexicals x)))
(with-fluid* *comp-module* (or (and e (car e)) (current-module))
(lambda ()

62
module/language/tree-il/fix-letrec.scm
View file

@ -78,6 +78,13 @@
simple
lambda*
complex))
((<let> vars)
(values (append vars unref)
ref
set
simple
lambda*
complex))
(else
(values unref ref set simple lambda* complex))))
(lambda (x unref ref set simple lambda* complex)
@ -108,6 +115,39 @@
(else
(lp (cdr vars) (cdr vals)
s l (cons (car vars) c))))))
((<let> (orig-vars vars) vals)
;; The point is to compile let-bound lambdas as
;; efficiently as we do letrec-bound lambdas, so
;; we use the same algorithm for analyzing the
;; vars. There is no problem recursing into the
;; bindings after the let, because all variables
;; have been renamed.
(let lp ((vars orig-vars) (vals vals)
(s '()) (l '()) (c '()))
(cond
((null? vars)
(values unref
ref
set
(append s simple)
(append l lambda*)
(append c complex)))
((memq (car vars) unref)
(lp (cdr vars) (cdr vals)
s l c))
((memq (car vars) set)
(lp (cdr vars) (cdr vals)
s l (cons (car vars) c)))
((and (lambda? (car vals))
(not (memq (car vars) set)))
(lp (cdr vars) (cdr vals)
s (cons (car vars) l) c))
;; There is no difference between simple and
;; complex, for the purposes of let. Just lump
;; them all into complex.
(else
(lp (cdr vars) (cdr vals)
s l (cons (car vars) c))))))
(else
(values unref ref set simple lambda* complex))))
'()
@ -128,7 +168,7 @@
;; expression, called for effect.
((<lexical-set> gensym exp)
(if (memq gensym unref)
(make-sequence #f (list (make-void #f) exp))
(make-sequence #f (list exp (make-void #f)))
x))
((<letrec> src names vars vals body)
@ -176,5 +216,25 @@
;; Finally, the body.
body)))))))))
((<let> src names vars vals body)
(let ((binds (map list vars names vals)))
(define (lookup set)
(map (lambda (v) (assq v binds))
(lset-intersection eq? vars set)))
(let ((u (lookup unref))
(l (lookup lambda*))
(c (lookup complex)))
(make-sequence
src
(append
;; unreferenced bindings, called for effect.
(map caddr u)
(list
;; unassigned lambdas use fix.
(make-fix src (map cadr l) (map car l) (map caddr l)
;; and the "complex" bindings.
(make-let src (map cadr c) (map car c) (map caddr c)
body))))))))
(else x)))
x)))

35
test-suite/tests/tree-il.test
View file

@ -151,25 +151,33 @@
(with-test-prefix "lexical sets"
(assert-tree-il->glil
(let (x) (y) ((const 1)) (set! (lexical x y) (const 2)))
;; unreferenced sets may be optimized away -- make sure they are ref'd
(let (x) (y) ((const 1))
(set! (lexical x y) (apply (primitive 1+) (lexical x y))))
(program 0 0 1 ()
(const 1) (bind (x #t 0)) (lexical #t #t box 0)
(const 2) (lexical #t #t set 0) (void) (call return 1)
(unbind)))
(assert-tree-il->glil
(let (x) (y) ((const 1)) (begin (set! (lexical x y) (const 2)) (const #f)))
(program 0 0 1 ()
(const 1) (bind (x #t 0)) (lexical #t #t box 0)
(const 2) (lexical #t #t set 0) (const #f) (call return 1)
(lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
(void) (call return 1)
(unbind)))
(assert-tree-il->glil
(let (x) (y) ((const 1))
(apply (primitive null?) (set! (lexical x y) (const 2))))
(begin (set! (lexical x y) (apply (primitive 1+) (lexical x y)))
(lexical x y)))
(program 0 0 1 ()
(const 1) (bind (x #t 0)) (lexical #t #t box 0)
(const 2) (lexical #t #t set 0) (void) (call null? 1) (call return 1)
(lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
(lexical #t #t ref 0) (call return 1)
(unbind)))
(assert-tree-il->glil
(let (x) (y) ((const 1))
(apply (primitive null?)
(set! (lexical x y) (apply (primitive 1+) (lexical x y)))))
(program 0 0 1 ()
(const 1) (bind (x #t 0)) (lexical #t #t box 0)
(lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void)
(call null? 1) (call return 1)
(unbind))))
(with-test-prefix "module refs"
@ -413,20 +421,19 @@
(unbind))
(eq? l1 l2))
;; second bound var is unreferenced
(assert-tree-il->glil/pmatch
(let (x) (y) ((const 1))
(if (lexical x y)
(lexical x y)
(let (a) (b) ((const 2))
(lexical x y))))
(program 0 0 2 ()
(program 0 0 1 ()
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
(lexical #t #f ref 0) (branch br-if-not ,l1)
(lexical #t #f ref 0) (call return 1)
(label ,l2)
(const 2) (bind (a #f 1)) (lexical #t #f set 1)
(lexical #t #f ref 0) (call return 1)
(unbind)
(unbind))
(eq? l1 l2)))