diff options
author | Andy Wingo <wingo@pobox.com> | 2011-10-10 20:39:22 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2011-10-10 22:34:48 +0200 |
commit | 30fcf30fcfa758ff6f480fc63559c1f5d074cfea (patch) | |
tree | c7d00b96bc5c6cd2ce418e18dd273a4087180da9 | |
parent | 9be8a338acf82d387846ea30819be75a9098048b (diff) | |
download | guile-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.scm | 66 | ||||
-rw-r--r-- | test-suite/tests/tree-il.test | 15 |
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 |