diff options
-rw-r--r-- | libguile/_scm.h | 2 | ||||
-rw-r--r-- | module/language/tree-il/compile-glil.scm | 14 | ||||
-rw-r--r-- | module/language/tree-il/fix-letrec.scm | 62 | ||||
-rw-r--r-- | test-suite/tests/tree-il.test | 25 |
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))) |