[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.2-159-g30fcf
From: |
Andy Wingo |
Subject: |
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.2-159-g30fcf30 |
Date: |
Mon, 10 Oct 2011 20:34:56 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=30fcf30fcfa758ff6f480fc63559c1f5d074cfea
The branch, stable-2.0 has been updated
via 30fcf30fcfa758ff6f480fc63559c1f5d074cfea (commit)
via 9be8a338acf82d387846ea30819be75a9098048b (commit)
from d62dd766856492e494ff560c05e750f006c58612 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 30fcf30fcfa758ff6f480fc63559c1f5d074cfea
Author: Andy Wingo <address@hidden>
Date: Mon Oct 10 20:39:22 2011 +0200
fold constants with accessors
* module/language/tree-il/peval.scm (peval): Factor constant folding out
to a helper. Use it in the accessor case in addition to the normal
effect-free-primitive case.
* test-suite/tests/tree-il.test: Add a test.
commit 9be8a338acf82d387846ea30819be75a9098048b
Author: Andy Wingo <address@hidden>
Date: Mon Oct 10 20:19:07 2011 +0200
recognize string primitives
* module/language/tree-il/primitives.scm
(*interesting-primitive-names*): Add string?, string-length, and ref
and set.
(*primitive-accessors*): Add string-ref.
(*effect-free-primitives*): Add string-length and string?
(*effect+exception-free-primitives*): Add string?.
(*singly-valued-primitives*): Add string-length and ref and set.
-----------------------------------------------------------------------
Summary of changes:
module/language/tree-il/peval.scm | 66 +++++++++++++++++--------------
module/language/tree-il/primitives.scm | 14 +++++--
test-suite/tests/tree-il.test | 15 +++++++
3 files changed, 61 insertions(+), 34 deletions(-)
diff --git a/module/language/tree-il/peval.scm
b/module/language/tree-il/peval.scm
index 8091e16..0d6abb2 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -423,6 +423,38 @@ top-level bindings from ENV and return the resulting
expression."
(lambda _
(values #f '()))))
+ (define (make-values src values)
+ (match values
+ ((single) single) ; 1 value
+ ((_ ...) ; 0, or 2 or more values
+ (make-application src (make-primitive-ref src 'values)
+ values))))
+
+ (define (fold-constants src name args ctx)
+ (define (residualize-call)
+ (make-application src (make-primitive-ref #f name) args))
+ (cond
+ ((every const? args)
+ (let-values (((success? values)
+ (apply-primitive name (map const-exp args))))
+ (log 'fold success? values name args)
+ (if success?
+ (case ctx
+ ((effect) (make-void src))
+ ((test)
+ ;; Values truncation: only take the first
+ ;; value.
+ (if (pair? values)
+ (make-const src (car values))
+ (make-values src '())))
+ (else
+ (make-values src (map (cut make-const src <>) values))))
+ (residualize-call))))
+ ((and (eq? ctx 'effect) (types-check? name args))
+ (make-void #f))
+ (else
+ (residualize-call))))
+
(define (inline-values exp src names gensyms body)
(let loop ((exp exp))
(match exp
@@ -497,13 +529,6 @@ top-level bindings from ENV and return the resulting
expression."
(and tail
(make-sequence src (append head (list tail)))))))))))
- (define (make-values src values)
- (match values
- ((single) single) ; 1 value
- ((_ ...) ; 0, or 2 or more values
- (make-application src (make-primitive-ref src 'values)
- values))))
-
(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
@@ -999,31 +1024,12 @@ top-level bindings from ENV and return the resulting
expression."
(else
(make-application src proc (list k (make-const #f
elts))))))))
((_ . args)
- (make-application src proc args))))
+ (or (fold-constants src name args ctx)
+ (make-application src proc args)))))
(($ <primitive-ref> _ (? effect-free-primitive? name))
(let ((args (map for-value orig-args)))
- (if (every const? args) ; only simple constants
- (let-values (((success? values)
- (apply-primitive name (map const-exp args))))
- (log 'fold success? values exp)
- (if success?
- (case ctx
- ((effect) (make-void #f))
- ((test)
- ;; Values truncation: only take the first
- ;; value.
- (if (pair? values)
- (make-const #f (car values))
- (make-values src '())))
- (else
- (make-values src (map (cut make-const src <>)
- values))))
- (make-application src proc args)))
- (cond
- ((and (eq? ctx 'effect) (types-check? name args))
- (make-void #f))
- (else
- (make-application src proc args))))))
+ (or (fold-constants src name args ctx)
+ (make-application src proc args))))
(($ <lambda> _ _
($ <lambda-case> _ req opt #f #f inits gensyms body #f))
;; Simple case: no rest, no keyword arguments.
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index 65b93b5..172150b 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -45,7 +45,8 @@
+ * - / 1- 1+ quotient remainder modulo
ash logand logior logxor
not
- pair? null? list? symbol? vector? acons cons cons*
+ pair? null? list? symbol? vector? string? struct?
+ acons cons cons*
list vector
@@ -68,7 +69,9 @@
@prompt call-with-prompt @abort abort-to-prompt
make-prompt-tag
- struct? struct-vtable make-struct struct-ref struct-set!
+ string-length string-ref string-set!
+
+ struct-vtable make-struct struct-ref struct-set!
bytevector-u8-ref bytevector-u8-set!
bytevector-s8-ref bytevector-s8-set!
@@ -120,6 +123,7 @@
car cdr
memq memv
struct-vtable struct-ref
+ string-ref
bytevector-u8-ref bytevector-s8-ref
bytevector-u16-ref bytevector-u16-native-ref
bytevector-s16-ref bytevector-s16-native-ref
@@ -136,7 +140,8 @@
= < > <= >= zero?
+ * - / 1- 1+ quotient remainder modulo
not
- pair? null? list? symbol? vector? struct?
+ pair? null? list? symbol? vector? struct? string?
+ string-length
;; These all should get expanded out by expand-primitives!.
caar cadr cdar cddr
caaar caadr cadar caddr cdaar cdadr cddar cdddr
@@ -151,7 +156,7 @@
'(values
eq? eqv? equal?
not
- pair? null? list? symbol? vector? struct?
+ pair? null? list? symbol? vector? struct? string?
acons cons cons* list vector))
;; Primitives that only return one value.
@@ -176,6 +181,7 @@
fluid-ref fluid-set!
make-prompt-tag
struct? struct-vtable make-struct struct-ref struct-set!
+ string-length string-ref string-set!
bytevector-u8-ref bytevector-u8-set!
bytevector-s8-ref bytevector-s8-set!
u8vector-ref u8vector-set! s8vector-ref s8vector-set!
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 789e8fd..8b4c900 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -759,6 +759,21 @@
(loop (cdr l) (+ sum (car l)))))
(const 10))
+ (pass-if-peval resolve-primitives
+ (let ((string->chars
+ (lambda (s)
+ (define (char-at n)
+ (string-ref s n))
+ (define (len)
+ (string-length s))
+ (let loop ((i 0))
+ (if (< i (len))
+ (cons (char-at i)
+ (loop (1+ i)))
+ '())))))
+ (string->chars "yo"))
+ (apply (primitive list) (const #\y) (const #\o)))
+
(pass-if-peval
;; Primitives in module-refs are resolved (the expansion of `pmatch'
;; below leads to calls to (@@ (system base pmatch) car) and
hooks/post-receive
--
GNU Guile
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.2-159-g30fcf30,
Andy Wingo <=