summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/_scm.h2
-rw-r--r--module/language/tree-il/compile-glil.scm14
-rw-r--r--module/language/tree-il/fix-letrec.scm62
-rw-r--r--test-suite/tests/tree-il.test25
4 files changed, 85 insertions, 18 deletions
diff --git a/libguile/_scm.h b/libguile/_scm.h
index 737e01edd..627c51e03 100644
--- a/libguile/_scm.h
+++ b/libguile/_scm.h
@@ -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 \
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index 503e0a44f..8886fa352 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -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 ()
diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm
index 0ed7b6bab..9b66d9ed5 100644
--- a/module/language/tree-il/fix-letrec.scm
+++ b/module/language/tree-il/fix-letrec.scm
@@ -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)))
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index d993e4ff2..73ea9c1a7 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -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)
+ (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)) (begin (set! (lexical x y) (const 2)) (const #f)))
+ (let (x) (y) ((const 1))
+ (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) (const #f) (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) (const 2))))
+ (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)
- (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) (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)))