diff options
author | Andy Wingo <wingo@pobox.com> | 2013-02-18 17:59:38 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2013-02-18 17:59:38 +0100 |
commit | 9b977c836bf147d386944c401113aba32776fa68 (patch) | |
tree | d097e1a2376e26bc6b03447445ae239d5514a7a8 /module | |
parent | 180ac9d7b0bac97bdead2813a1b0b23d19002c3e (diff) | |
parent | 739941679c2c7dc36c29c30aff7d4c1b436ba773 (diff) | |
download | guile-9b977c836bf147d386944c401113aba32776fa68.tar.gz |
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts:
libguile/array-handle.c
libguile/deprecated.h
libguile/inline.c
libguile/inline.h
module/ice-9/deprecated.scm
module/language/tree-il/peval.scm
Diffstat (limited to 'module')
-rw-r--r-- | module/ice-9/boot-9.scm | 12 | ||||
-rw-r--r-- | module/language/tree-il/peval.scm | 232 | ||||
-rw-r--r-- | module/srfi/srfi-4/gnu.scm | 8 | ||||
-rw-r--r-- | module/system/foreign.scm | 4 | ||||
-rw-r--r-- | module/texinfo.scm | 3 | ||||
-rw-r--r-- | module/texinfo/docbook.scm | 2 | ||||
-rw-r--r-- | module/texinfo/plain-text.scm | 3 | ||||
-rw-r--r-- | module/texinfo/serialize.scm | 5 |
8 files changed, 182 insertions, 87 deletions
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 735ffcfcc..5f42ef4dd 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -627,12 +627,10 @@ file with the given name already exists, the effect is unspecified." datum (syntax->datum clause) (syntax->datum whole-expr))) - (if (memv datum seen) - (warn-datum 'duplicate-case-datum)) - (if (or (pair? datum) - (array? datum) - (generalized-vector? datum)) - (warn-datum 'bad-case-datum)) + (when (memv datum seen) + (warn-datum 'duplicate-case-datum)) + (when (or (pair? datum) (array? datum)) + (warn-datum 'bad-case-datum)) (cons datum seen)) seen (map syntax->datum #'(datums ...))))) @@ -966,6 +964,8 @@ information is unavailable." #'(define-macro macro doc (lambda args body1 body ...))) ((_ (macro . args) body ...) #'(define-macro macro #f (lambda args body ...))) + ((_ macro transformer) + #'(define-macro macro #f transformer)) ((_ macro doc transformer) (or (string? (syntax->datum #'doc)) (not (syntax->datum #'doc))) diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index 5ae691ddd..2d2c30ba6 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -431,6 +431,13 @@ top-level bindings from ENV and return the resulting expression." new)) vars)) + (define (fresh-temporaries ls) + (map (lambda (elt) + (let ((new (gensym "tmp "))) + (record-new-temporary! 'tmp new 1) + new)) + ls)) + (define (assigned-lexical? sym) (var-set? (lookup-var sym))) @@ -508,7 +515,7 @@ top-level bindings from ENV and return the resulting expression." (else (residualize-call)))) - (define (inline-values exp src names gensyms body) + (define (inline-values src exp nmin nmax consumer) (let loop ((exp exp)) (match exp ;; Some expression types are always singly-valued. @@ -524,17 +531,15 @@ top-level bindings from ENV and return the resulting expression." ($ <toplevel-set>) ; could return zero values in ($ <toplevel-define>) ; the future ($ <module-set>) ; - ($ <dynset>)) ; - (and (= (length names) 1) - (make-let src names gensyms (list exp) body))) - (($ <primcall> src (? singly-valued-primitive? name)) - (and (= (length names) 1) - (make-let src names gensyms (list exp) body))) + ($ <dynset>) ; + ($ <primcall> src (? singly-valued-primitive?))) + (and (<= nmin 1) (or (not nmax) (>= nmax 1)) + (make-call src (make-lambda #f '() consumer) (list exp)))) ;; Statically-known number of values. (($ <primcall> src 'values vals) - (and (= (length names) (length vals)) - (make-let src names gensyms vals body))) + (and (<= nmin (length vals)) (or (not nmax) (>= nmax (length vals))) + (make-call src (make-lambda #f '() consumer) vals))) ;; Not going to copy code into both branches. (($ <conditional>) #f) @@ -692,6 +697,49 @@ top-level bindings from ENV and return the resulting expression." ((vhash-assq var env) => cdr) (else (error "unbound var" var)))) + ;; Find a value referenced a specific number of times. This is a hack + ;; that's used for propagating fresh data structures like rest lists and + ;; prompt tags. Usually we wouldn't copy consed data, but we can do so in + ;; some special cases like `apply' or prompts if we can account + ;; for all of its uses. + ;; + ;; You don't want to use this in general because it introduces a slight + ;; nonlinearity by running peval again (though with a small effort and size + ;; counter). + ;; + (define (find-definition x n-aliases) + (cond + ((lexical-ref? x) + (cond + ((lookup (lexical-ref-gensym x)) + => (lambda (op) + (let ((y (or (operand-residual-value op) + (visit-operand op counter 'value 10 10) + (operand-source op)))) + (cond + ((and (lexical-ref? y) + (= (lexical-refcount (lexical-ref-gensym x)) 1)) + ;; X is a simple alias for Y. Recurse, regardless of + ;; the number of aliases we were expecting. + (find-definition y n-aliases)) + ((= (lexical-refcount (lexical-ref-gensym x)) n-aliases) + ;; We found a definition that is aliased the right + ;; number of times. We still recurse in case it is a + ;; lexical. + (values (find-definition y 1) + op)) + (else + ;; We can't account for our aliases. + (values #f #f)))))) + (else + ;; A formal parameter. Can't say anything about that. + (values #f #f)))) + ((= n-aliases 1) + ;; Not a lexical: success, but only if we are looking for an + ;; unaliased value. + (values x #f)) + (else (values #f #f)))) + (define (visit exp ctx) (loop exp env counter ctx)) @@ -820,6 +868,30 @@ top-level bindings from ENV and return the resulting expression." (begin (record-operand-use op) (make-lexical-set src name (operand-sym op) (for-value exp)))))) + (($ <let> src + (names ... rest) + (gensyms ... rest-sym) + (vals ... ($ <primcall> _ 'list rest-args)) + ($ <primcall> asrc (or 'apply '@apply) + (proc args ... + ($ <lexical-ref> _ + (? (cut eq? <> rest)) + (? (lambda (sym) + (and (eq? sym rest-sym) + (= (lexical-refcount sym) 1)))))))) + (let* ((tmps (make-list (length rest-args) 'tmp)) + (tmp-syms (fresh-temporaries tmps))) + (for-tail + (make-let src + (append names tmps) + (append gensyms tmp-syms) + (append vals rest-args) + (make-call + asrc + proc + (append args + (map (cut make-lexical-ref #f <> <>) + tmps tmp-syms))))))) (($ <let> src names gensyms vals body) (define (compute-alias exp) ;; It's very common for macros to introduce something like: @@ -915,11 +987,13 @@ top-level bindings from ENV and return the resulting expression." ;; reconstruct the let-values, pevaling the consumer. (let ((producer (for-values producer))) (or (match consumer - (($ <lambda-case> src req #f #f #f () gensyms body #f) - (cond - ((inline-values producer src req gensyms body) - => for-tail) - (else #f))) + (($ <lambda-case> src req opt rest #f inits gensyms body #f) + (let* ((nmin (length req)) + (nmax (and (not rest) (+ nmin (if opt (length opt) 0))))) + (cond + ((inline-values lv-src producer nmin nmax consumer) + => for-tail) + (else #f)))) (_ #f)) (make-let-values lv-src producer (for-tail consumer))))) (($ <dynwind> src winder pre body post unwinder) @@ -1102,15 +1176,30 @@ top-level bindings from ENV and return the resulting expression." (make-primcall src 'values vals)))))) (($ <primcall> src (or 'apply '@apply) (proc args ... tail)) - (match (for-value tail) - (($ <const> _ (args* ...)) - (let ((args* (map (lambda (x) (make-const #f x)) args*))) - (for-tail (make-call src proc (append args args*))))) - (($ <primcall> _ 'list args*) - (for-tail (make-call src proc (append args args*)))) - (tail - (let ((args (append (map for-value args) (list tail)))) - (make-primcall src '@apply (cons (for-value proc) args)))))) + (let lp ((tail* (find-definition tail 1)) (speculative? #t)) + (define (copyable? x) + ;; Inlining a result from find-definition effectively copies it, + ;; relying on the let-pruning to remove its original binding. We + ;; shouldn't copy non-constant expressions. + (or (not speculative?) (constant-expression? x))) + (match tail* + (($ <const> _ (args* ...)) + (let ((args* (map (cut make-const #f <>) args*))) + (for-tail (make-call src proc (append args args*))))) + (($ <primcall> _ 'cons + ((and head (? copyable?)) (and tail (? copyable?)))) + (for-tail (make-primcall src '@apply + (cons proc + (append args (list head tail)))))) + (($ <primcall> _ 'list + (and args* ((? copyable?) ...))) + (for-tail (make-call src proc (append args args*)))) + (tail* + (if speculative? + (lp (for-value tail) #f) + (let ((args (append (map for-value args) (list tail*)))) + (make-primcall src '@apply + (cons (for-value proc) args)))))))) (($ <primcall> src (? constructor-primitive? name) args) (cond @@ -1219,20 +1308,39 @@ top-level bindings from ENV and return the resulting expression." (($ <call> src orig-proc orig-args) ;; todo: augment the global env with specialized functions - (let ((proc (visit orig-proc 'operator))) + (let revisit-proc ((proc (visit orig-proc 'operator))) (match proc (($ <primitive-ref> _ name) (for-tail (make-primcall src name orig-args))) (($ <lambda> _ _ - ($ <lambda-case> _ req opt #f #f inits gensyms body #f)) - ;; Simple case: no rest, no keyword arguments. + ($ <lambda-case> _ req opt rest #f inits gensyms body #f)) + ;; Simple case: no keyword arguments. ;; todo: handle the more complex cases (let* ((nargs (length orig-args)) (nreq (length req)) (nopt (if opt (length opt) 0)) (key (source-expression proc))) + (define (inlined-call) + (make-let src + (append req + (or opt '()) + (if rest (list rest) '())) + gensyms + (if (> nargs (+ nreq nopt)) + (append (list-head orig-args (+ nreq nopt)) + (list + (make-primcall + #f 'list + (drop orig-args (+ nreq nopt))))) + (append orig-args + (drop inits (- nargs nreq)) + (if rest + (list (make-const #f '())) + '()))) + body)) + (cond - ((or (< nargs nreq) (> nargs (+ nreq nopt))) + ((or (< nargs nreq) (and (not rest) (> nargs (+ nreq nopt)))) ;; An error, or effecting arguments. (make-call src (for-call orig-proc) (map for-value orig-args))) ((or (and=> (find-counter key counter) counter-recursive?) @@ -1256,12 +1364,7 @@ top-level bindings from ENV and return the resulting expression." (lp (counter-prev counter))))))) (log 'inline-recurse key) - (loop (make-let src (append req (or opt '())) - gensyms - (append orig-args - (drop inits (- nargs nreq))) - body) - env counter ctx)) + (loop (inlined-call) env counter ctx)) (else ;; An integration at the top-level, the first ;; recursion of a recursive procedure, or a nested @@ -1292,12 +1395,7 @@ top-level bindings from ENV and return the resulting expression." (make-top-counter effort-limit operand-size-limit abort key)))) (define result - (loop (make-let src (append req (or opt '())) - gensyms - (append orig-args - (drop inits (- nargs nreq))) - body) - env new-counter ctx)) + (loop (inlined-call) env new-counter ctx)) (if counter ;; The nested inlining attempt succeeded. @@ -1307,6 +1405,31 @@ top-level bindings from ENV and return the resulting expression." (log 'inline-end result exp) result))))) + (($ <let> _ _ _ vals _) + ;; Attempt to inline `let' in the operator position. + ;; + ;; We have to re-visit the proc in value mode, since the + ;; `let' bindings might have been introduced or renamed, + ;; whereas the lambda (if any) in operator position has not + ;; been renamed. + (if (or (and-map constant-expression? vals) + (and-map constant-expression? orig-args)) + ;; The arguments and the let-bound values commute. + (match (for-value orig-proc) + (($ <let> lsrc names syms vals body) + (log 'inline-let orig-proc) + (for-tail + (make-let lsrc names syms vals + (make-call src body orig-args)))) + ;; It's possible for a `let' to go away after the + ;; visit due to the fact that visiting a procedure in + ;; value context will prune unused bindings, whereas + ;; visiting in operator mode can't because it doesn't + ;; traverse through lambdas. In that case re-visit + ;; the procedure. + (proc (revisit-proc proc))) + (make-call src (for-call orig-proc) + (map for-value orig-args)))) (_ (make-call src (for-call orig-proc) (map for-value orig-args)))))) (($ <lambda> src meta body) @@ -1365,37 +1488,6 @@ top-level bindings from ENV and return the resulting expression." (($ <primcall> _ 'make-prompt-tag (or () ((? constant-expression?)))) #t) (_ #f))) - (define (find-definition x n-aliases) - (cond - ((lexical-ref? x) - (cond - ((lookup (lexical-ref-gensym x)) - => (lambda (op) - (let ((y (or (operand-residual-value op) - (visit-operand op counter 'value 10 10)))) - (cond - ((and (lexical-ref? y) - (= (lexical-refcount (lexical-ref-gensym x)) 1)) - ;; X is a simple alias for Y. Recurse, regardless of - ;; the number of aliases we were expecting. - (find-definition y n-aliases)) - ((= (lexical-refcount (lexical-ref-gensym x)) n-aliases) - ;; We found a definition that is aliased the right - ;; number of times. We still recurse in case it is a - ;; lexical. - (values (find-definition y 1) - op)) - (else - ;; We can't account for our aliases. - (values #f #f)))))) - (else - ;; A formal parameter. Can't say anything about that. - (values #f #f)))) - ((= n-aliases 1) - ;; Not a lexical: success, but only if we are looking for an - ;; unaliased value. - (values x #f)) - (else (values #f #f)))) (let ((tag (for-value tag)) (body (for-tail body))) diff --git a/module/srfi/srfi-4/gnu.scm b/module/srfi/srfi-4/gnu.scm index 39d6350e7..7f595d628 100644 --- a/module/srfi/srfi-4/gnu.scm +++ b/module/srfi/srfi-4/gnu.scm @@ -1,6 +1,6 @@ ;;; Extensions to SRFI-4 -;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 2009, 2010, 2011, 2012, 2013 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 @@ -101,14 +101,14 @@ `(define (,(symbol-append 'any-> tag 'vector) obj) (cond ((,(symbol-append tag 'vector?) obj) obj) ((pair? obj) (,(symbol-append 'list-> tag 'vector) obj)) - ((generalized-vector? obj) - (let* ((len (generalized-vector-length obj)) + ((and (array? obj) (eqv? 1 (array-rank obj))) + (let* ((len (array-length obj)) (v (,(symbol-append 'make- tag 'vector) len))) (let lp ((i 0)) (if (< i len) (begin (,(symbol-append tag 'vector-set!) - v i (generalized-vector-ref obj i)) + v i (array-ref obj i)) (lp (1+ i))) v)))) (else (scm-error 'wrong-type-arg #f "" '() (list obj)))))) diff --git a/module/system/foreign.scm b/module/system/foreign.scm index e6e965545..01a71b8b9 100644 --- a/module/system/foreign.scm +++ b/module/system/foreign.scm @@ -1,4 +1,4 @@ -;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 2010, 2011, 2013 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 @@ -25,7 +25,7 @@ float double short unsigned-short - int unsigned-int long unsigned-long size_t + int unsigned-int long unsigned-long size_t ssize_t ptrdiff_t int8 uint8 uint16 int16 uint32 int32 diff --git a/module/texinfo.scm b/module/texinfo.scm index 519db485d..edee5b397 100644 --- a/module/texinfo.scm +++ b/module/texinfo.scm @@ -1,6 +1,6 @@ ;;;; (texinfo) -- parsing of texinfo into SXML ;;;; -;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. ;;;; Copyright (C) 2004, 2009 Andy Wingo <wingo at pobox dot com> ;;;; Copyright (C) 2001,2002 Oleg Kiselyov <oleg at pobox dot com> ;;;; @@ -187,6 +187,7 @@ lambda. Only present for @code{INLINE-ARGS}, @code{EOL-ARGS}, (sample INLINE-TEXT) (samp INLINE-TEXT) (code INLINE-TEXT) + (math INLINE-TEXT) (kbd INLINE-TEXT) (key INLINE-TEXT) (var INLINE-TEXT) diff --git a/module/texinfo/docbook.scm b/module/texinfo/docbook.scm index c5a8d659f..f3f993db8 100644 --- a/module/texinfo/docbook.scm +++ b/module/texinfo/docbook.scm @@ -135,7 +135,7 @@ each other. @xref{texinfo docbook sdocbook-flatten,,sdocbook-flatten}, for more information." '(para programlisting informalexample indexterm variablelist orderedlist refsect1 refsect2 refsect3 refsect4 title example - note itemizedlist)) + note itemizedlist informaltable)) (define (inline-command? command) (not (memq command *sdocbook-block-commands*))) diff --git a/module/texinfo/plain-text.scm b/module/texinfo/plain-text.scm index 87e43e5bb..83e5e38f9 100644 --- a/module/texinfo/plain-text.scm +++ b/module/texinfo/plain-text.scm @@ -1,6 +1,6 @@ ;;;; (texinfo plain-text) -- rendering stexinfo as plain text ;;;; -;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 2009, 2010, 2011, 2013 Free Software Foundation, Inc. ;;;; Copyright (C) 2003,2004,2009 Andy Wingo <wingo at pobox dot com> ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -238,6 +238,7 @@ (sample ,code) (samp ,code) (code ,code) + (math ,passthrough) (kbd ,code) (key ,key) (var ,var) diff --git a/module/texinfo/serialize.scm b/module/texinfo/serialize.scm index 1436ad5f9..d0c6f50e5 100644 --- a/module/texinfo/serialize.scm +++ b/module/texinfo/serialize.scm @@ -1,6 +1,6 @@ ;;;; (texinfo serialize) -- rendering stexinfo as texinfo ;;;; -;;;; Copyright (C) 2009, 2012 Free Software Foundation, Inc. +;;;; Copyright (C) 2009, 2012, 2013 Free Software Foundation, Inc. ;;;; Copyright (C) 2003,2004,2009 Andy Wingo <wingo at pobox dot com> ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -185,7 +185,8 @@ (define (wrap strings) (fill-string (string-concatenate strings) - #:line-width 72)) + #:line-width 72 + #:break-long-words? #f)) (define (paragraph exp lp command type formals args accum) (list* "\n\n" |