From d825841db0eb920150d6734b8928b6a3decbca0e Mon Sep 17 00:00:00 2001 From: Ian Price Date: Wed, 26 Oct 2011 20:24:05 +0100 Subject: [PATCH 1/5] Fix R6RS `fold-left' so the accumulator is the first argument. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * module/rnrs/lists.scm (fold-left): New procedure. * module/rnrs/records/syntactic.scm (define-record-type): Fix to use corrected `fold-left'. * test-suite/tests/r6rs-lists.test: Add tests. Signed-off-by: Ludovic Courtès --- module/rnrs/lists.scm | 12 +++++++++--- module/rnrs/records/syntactic.scm | 4 ++-- test-suite/tests/r6rs-lists.test | 26 ++++++++++++++++++++++++++ 3 files changed, 37 insertions(+), 5 deletions(-) diff --git a/module/rnrs/lists.scm b/module/rnrs/lists.scm index 812ce5f98..0671e7753 100644 --- a/module/rnrs/lists.scm +++ b/module/rnrs/lists.scm @@ -22,8 +22,7 @@ remv remq memp member memv memq assp assoc assv assq cons*) (import (rnrs base (6)) (only (guile) filter member memv memq assoc assv assq cons*) - (rename (only (srfi srfi-1) fold - any + (rename (only (srfi srfi-1) any every remove member @@ -32,7 +31,6 @@ partition fold-right filter-map) - (fold fold-left) (any exists) (every for-all) (remove remp) @@ -40,6 +38,14 @@ (member memp-internal) (assoc assp-internal))) + (define (fold-left combine nil list . lists) + (define (fold nil lists) + (if (exists null? lists) + nil + (fold (apply combine nil (map car lists)) + (map cdr lists)))) + (fold nil (cons list lists))) + (define (remove obj list) (remp (lambda (elt) (equal? obj elt)) list)) (define (remv obj list) (remp (lambda (elt) (eqv? obj elt)) list)) (define (remq obj list) (remp (lambda (elt) (eq? obj elt)) list)) diff --git a/module/rnrs/records/syntactic.scm b/module/rnrs/records/syntactic.scm index a497b90e3..bde6f9348 100644 --- a/module/rnrs/records/syntactic.scm +++ b/module/rnrs/records/syntactic.scm @@ -134,13 +134,13 @@ (let* ((fields (if (unspecified? _fields) '() _fields)) (field-names (list->vector (map car fields))) (field-accessors - (fold-left (lambda (x c lst) + (fold-left (lambda (lst x c) (cons #`(define #,(cadr x) (record-accessor record-name #,c)) lst)) '() fields (sequence (length fields)))) (field-mutators - (fold-left (lambda (x c lst) + (fold-left (lambda (lst x c) (if (caddr x) (cons #`(define #,(caddr x) (record-mutator record-name diff --git a/test-suite/tests/r6rs-lists.test b/test-suite/tests/r6rs-lists.test index ba645ed01..030091f32 100644 --- a/test-suite/tests/r6rs-lists.test +++ b/test-suite/tests/r6rs-lists.test @@ -30,3 +30,29 @@ (let ((d '((3 a) (1 b) (4 c)))) (equal? (assp even? d) '(4 c))))) +(with-test-prefix "fold-left" + (pass-if "fold-left sum" + (equal? (fold-left + 0 '(1 2 3 4 5)) + 15)) + (pass-if "fold-left reverse" + (equal? (fold-left (lambda (a e) (cons e a)) '() '(1 2 3 4 5)) + '(5 4 3 2 1))) + (pass-if "fold-left max-length" + (equal? (fold-left (lambda (max-len s) + (max max-len (string-length s))) + 0 + '("longest" "long" "longer")) + 7)) + (pass-if "fold-left with-cons" + (equal? (fold-left cons '(q) '(a b c)) + '((((q) . a) . b) . c))) + (pass-if "fold-left sum-multiple" + (equal? (fold-left + 0 '(1 2 3) '(4 5 6)) + 21)) + (pass-if "fold-left pairlis" + (equal? (fold-left (lambda (accum e1 e2) + (cons (cons e1 e2) accum)) + '((d . 4)) + '(a b c) + '(1 2 3)) + '((c . 3) (b . 2) (a . 1) (d . 4))))) From 16d3e0133d9e5fd1052be69bfeec3b243d832ed4 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 9 Nov 2011 15:22:01 +0100 Subject: [PATCH 2/5] peval: don't copy assigned lexical bindings * module/language/tree-il/peval.scm (peval): Since constant-expression? is used to determine whether to copy values, return #f if any lexical is assigned. --- module/language/tree-il/peval.scm | 28 +++++++++++++++++----------- 1 file changed, 17 insertions(+), 11 deletions(-) diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index 0d6abb2f1..9524133bf 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -530,16 +530,18 @@ top-level bindings from ENV and return the resulting expression." (make-sequence src (append head (list tail))))))))))) (define (constant-expression? x) - ;; Return true if X is constant---i.e., if it is known to have no - ;; effects, does not allocate storage for a mutable object, and does - ;; not access mutable data (like `car' or toplevel references). + ;; Return true if X is constant, for the purposes of copying or + ;; elision---i.e., if it is known to have no effects, does not + ;; allocate storage for a mutable object, and does not access + ;; mutable data (like `car' or toplevel references). (let loop ((x x)) (match x (($ ) #t) (($ ) #t) (($ ) #t) - (($ _ req opt rest kw inits _ body alternate) - (and (every loop inits) (loop body) + (($ _ req opt rest kw inits syms body alternate) + (and (not (any assigned-lexical? syms)) + (every loop inits) (loop body) (or (not alternate) (loop alternate)))) (($ _ _ gensym) (not (assigned-lexical? gensym))) @@ -556,10 +558,12 @@ top-level bindings from ENV and return the resulting expression." (and (loop body) (every loop args))) (($ _ exps) (every loop exps)) - (($ _ _ _ vals body) - (and (every loop vals) (loop body))) - (($ _ _ _ _ vals body) - (and (every loop vals) (loop body))) + (($ _ _ syms vals body) + (and (not (any assigned-lexical? syms)) + (every loop vals) (loop body))) + (($ _ _ _ syms vals body) + (and (not (any assigned-lexical? syms)) + (every loop vals) (loop body))) (($ _ _ _ vals body) (and (every loop vals) (loop body))) (($ _ exp body) @@ -830,8 +834,10 @@ top-level bindings from ENV and return the resulting expression." (ops (make-bound-operands vars new vals visit)) (env* (fold extend-env env gensyms ops)) (body* (visit body counter ctx))) - (if (and (const? body*) - (every constant-expression? vals)) + (if (and (const? body*) (every constant-expression? vals)) + ;; We may have folded a loop completely, even though there + ;; might be cyclical references between the bound values. + ;; Handle this degenerate case specially. body* (prune-bindings ops in-order? body* counter ctx (lambda (names gensyms vals body) From 5e9b9059a334be0427eeb37eee6627dd595dc567 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 9 Nov 2011 16:41:56 +0100 Subject: [PATCH 3/5] fix serialization. * module/language/tree-il.scm (unparse-tree-il): Fix serialization. --- module/language/tree-il.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index da511522c..1d391c4e1 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -310,9 +310,9 @@ (( exp body) `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body))) - (( body winder unwinder) - `(dynwind ,(unparse-tree-il body) - ,(unparse-tree-il winder) ,(unparse-tree-il unwinder))) + (( winder body unwinder) + `(dynwind ,(unparse-tree-il winder) ,(unparse-tree-il body) + ,(unparse-tree-il unwinder))) (( fluids vals body) `(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals) From 8ee0b28b4d51dac704c151bf7f6d1874018ed3ae Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 9 Nov 2011 15:23:58 +0100 Subject: [PATCH 4/5] peval: fix dynwind bug. * module/language/tree-il/peval.scm (peval): The compiler will copy the winder and unwinder values, so make sure that they are constant, and if not, create lexical bindings. Fixes http://debbugs.gnu.org/9844. * test-suite/tests/tree-il.test ("partial evaluation"): Add a couple tests. --- module/language/tree-il/peval.scm | 35 +++++++++++++++++++++++++++++-- test-suite/tests/tree-il.test | 20 ++++++++++++++++++ 2 files changed, 53 insertions(+), 2 deletions(-) diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index 9524133bf..634c6c91c 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -870,8 +870,39 @@ top-level bindings from ENV and return the resulting expression." (_ #f)) (make-let-values lv-src producer (for-tail consumer))))) (($ src winder body unwinder) - (make-dynwind src (for-value winder) (for-tail body) - (for-value unwinder))) + (let ((pre (for-value winder)) + (body (for-tail body)) + (post (for-value unwinder))) + (cond + ((not (constant-expression? pre)) + (cond + ((not (constant-expression? post)) + (let ((pre-sym (gensym "pre ")) (post-sym (gensym "post "))) + (record-new-temporary! 'pre pre-sym 1) + (record-new-temporary! 'post post-sym 1) + (make-let src '(pre post) (list pre-sym post-sym) (list pre post) + (make-dynwind src + (make-lexical-ref #f 'pre pre-sym) + body + (make-lexical-ref #f 'post post-sym))))) + (else + (let ((pre-sym (gensym "pre "))) + (record-new-temporary! 'pre pre-sym 1) + (make-let src '(pre) (list pre-sym) (list pre) + (make-dynwind src + (make-lexical-ref #f 'pre pre-sym) + body + post)))))) + ((not (constant-expression? post)) + (let ((post-sym (gensym "post "))) + (record-new-temporary! 'post post-sym 1) + (make-let src '(post) (list post-sym) (list post) + (make-dynwind src + pre + body + (make-lexical-ref #f 'post post-sym))))) + (else + (make-dynwind src pre body post))))) (($ src fluids vals body) (make-dynlet src (map for-value fluids) (map for-value vals) (for-tail body))) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 011fef5a4..e9ac34f8f 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -1455,6 +1455,26 @@ (cdr (list (bar) 0)) (begin (apply (toplevel bar)) (apply (primitive list) (const 0)))) + (pass-if-peval + resolve-primitives + ;; Non-constant guards get lexical bindings. + (dynamic-wind foo (lambda () bar) baz) + (let (pre post) (_ _) ((toplevel foo) (toplevel baz)) + (dynwind (lexical pre _) (toplevel bar) (lexical post _)))) + + (pass-if-peval + resolve-primitives + ;; Constant guards don't need lexical bindings. + (dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz)) + (dynwind + (lambda () + (lambda-case + ((() #f #f #f () ()) (toplevel foo)))) + (toplevel bar) + (lambda () + (lambda-case + ((() #f #f #f () ()) (toplevel baz)))))) + (pass-if-peval resolve-primitives ;; Prompt is removed if tag is unreferenced From acdf4fcc059df325f66698090359b3455725c865 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 9 Nov 2011 16:44:59 +0100 Subject: [PATCH 5/5] simplify primitives.scm for dynwind * module/language/tree-il/primitives.scm (*primitive-expand-table*): Remove a dynwind hack, as we have a good inliner now. --- module/language/tree-il/primitives.scm | 43 ++++++++------------------ 1 file changed, 13 insertions(+), 30 deletions(-) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 172150bdf..f7bb5cab2 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -473,36 +473,19 @@ 'dynamic-wind (case-lambda ((src pre thunk post) - ;; Here we will make concessions to the fact that our inliner is - ;; lame, and add a hack. - (cond - ((lambda? thunk) - (let ((PRE (gensym " pre")) - (POST (gensym " post"))) - (make-let - src - '(pre post) - (list PRE POST) - (list pre post) - (make-dynwind - src - (make-lexical-ref #f 'pre PRE) - (make-application #f thunk '()) - (make-lexical-ref #f 'post POST))))) - (else - (let ((PRE (gensym " pre")) - (THUNK (gensym " thunk")) - (POST (gensym " post"))) - (make-let - src - '(pre thunk post) - (list PRE THUNK POST) - (list pre thunk post) - (make-dynwind - src - (make-lexical-ref #f 'pre PRE) - (make-application #f (make-lexical-ref #f 'thunk THUNK) '()) - (make-lexical-ref #f 'post POST))))))) + (let ((PRE (gensym " pre")) + (THUNK (gensym " thunk")) + (POST (gensym " post"))) + (make-let + src + '(pre thunk post) + (list PRE THUNK POST) + (list pre thunk post) + (make-dynwind + src + (make-lexical-ref #f 'pre PRE) + (make-application #f (make-lexical-ref #f 'thunk THUNK) '()) + (make-lexical-ref #f 'post POST))))) (else #f))) (hashq-set! *primitive-expand-table*