[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.2-159-g30fcf30

[Andy Wingo]

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