summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2011-10-10 20:39:22 +0200
committerAndy Wingo <wingo@pobox.com>2011-10-10 22:34:48 +0200
commit30fcf30fcfa758ff6f480fc63559c1f5d074cfea (patch)
treec7d00b96bc5c6cd2ce418e18dd273a4087180da9
parent9be8a338acf82d387846ea30819be75a9098048b (diff)
downloadguile-30fcf30fcfa758ff6f480fc63559c1f5d074cfea.tar.gz
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.
-rw-r--r--module/language/tree-il/peval.scm66
-rw-r--r--test-suite/tests/tree-il.test15
2 files changed, 51 insertions, 30 deletions
diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index 8091e16b2..0d6abb2f1 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/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 789e8fd15..8b4c900c3 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