mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00
Code Activity

fold constants with accessors

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2011-10-10 20:39:22 +02:00
parent 9be8a338ac
commit 30fcf30fcf
2 changed files with 51 additions and 30 deletions
Download patch file Download diff file Expand all files Collapse all files

66
module/language/tree-il/peval.scm
View file

@ -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.

15
test-suite/tests/tree-il.test
View file

@ -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