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

procedures with rest arguments can get inlined

Browse source 
* module/language/tree-il/peval.scm (peval): Allow inlining of
  procedures with rest arguments.

* test-suite/tests/peval.test ("partial evaluation"): Add a test.
This commit is contained in:
Andy Wingo 2013-02-15 11:19:10 +01:00
parent 30c3dac7a6
commit 564f5e7054
2 changed files with 33 additions and 15 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -1221,15 +1221,35 @@ top-level bindings from ENV and return the resulting expression."
(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.
($ <lambda-case> _ req opt rest #f inits gensyms body #f))
;; Simple case: no keyword arguments.
;; todo: handle the more complex cases
(let* ((nargs (length orig-args))
(nreq (length req))
(nopt (if opt (length opt) 0))
(key (source-expression proc)))
(define (inlined-application)
(make-let src
(append req
(or opt '())
(if rest (list rest) '()))
gensyms
(if (> nargs (+ nreq nopt))
(append (list-head orig-args (+ nreq nopt))
(list
(make-application
#f
(make-primitive-ref #f 'list)
(drop orig-args (+ nreq nopt)))))
(append orig-args
(drop inits (- nargs nreq))
(if rest
(list (make-const #f '()))
'())))
body))
(cond
((or (< nargs nreq) (> nargs (+ nreq nopt)))
((or (< nargs nreq) (and (not rest) (> nargs (+ nreq nopt))))
;; An error, or effecting arguments.
(make-application src (for-call orig-proc)
(map for-value orig-args)))
@ -1254,12 +1274,7 @@ top-level bindings from ENV and return the resulting expression."
(lp (counter-prev counter)))))))
(log 'inline-recurse key)
(loop (make-let src (append req (or opt '()))
gensyms
(append orig-args
(drop inits (- nargs nreq)))
body)
env counter ctx))
(loop (inlined-application) env counter ctx))
(else
;; An integration at the top-level, the first
;; recursion of a recursive procedure, or a nested
@ -1290,12 +1305,7 @@ top-level bindings from ENV and return the resulting expression."
(make-top-counter effort-limit operand-size-limit
abort key))))
(define result
(loop (make-let src (append req (or opt '()))
gensyms
(append orig-args
(drop inits (- nargs nreq)))
body)
env new-counter ctx))
(loop (inlined-application) env new-counter ctx))
(if counter
;; The nested inlining attempt succeeded.

8
test-suite/tests/peval.test
View file

@ -842,6 +842,14 @@
((const #t) v))))
(const #t))
(pass-if-peval
;; Applications of procedures with rest arguments can get inlined.
((lambda (x y . z)
(list x y z))
1 2 3 4)
(let (z) (_) ((apply (primitive list) (const 3) (const 4)))
(apply (primitive list) (const 1) (const 2) (lexical z _))))
(pass-if-peval
;; Constant folding: cons of #nil does not make list
(cons 1 #nil)