mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-18 17:50:29 +02:00
Code Activity

(call-with-values foo (lambda (a . b) a)) avoids consing rest list

Browse source 
* module/language/cps/slot-allocation.scm (allocate-slots): Don't
  allocate slots to unused results of function calls.  This can allow us
  to avoid consing a rest list for call-with-values with an ignored rest
  parameter, and can improve the parallel move code.

* module/language/cps/compile-bytecode.scm (compile-fun): Adapt to avoid
  emitting bind-rest in values context if the rest arg is unused.
This commit is contained in:
Andy Wingo 2013-12-06 11:08:45 +01:00
parent d297e544d9
commit fa48a2f79a
2 changed files with 61 additions and 5 deletions
Download patch file Download diff file Expand all files Collapse all files

25
module/language/cps/compile-bytecode.scm
View file

@ -201,7 +201,11 @@
(< (+ n 2) (cfa-k-count cfa))
(cfa-k-sym cfa (+ n 2)))))
(($ $ktrunc ($ $arity req () rest () #f) kargs)
(compile-trunc label k exp (length req) (and rest #t) nlocals)
(compile-trunc label k exp (length req)
(and rest
(match (vector-ref contv (cfa-k-idx cfa kargs))
(($ $kargs names (_ ... rest)) rest)))
nlocals)
(unless (and (= k-idx (1+ n))
(< (+ n 2) (cfa-k-count cfa))
(eq? (cfa-k-sym cfa (+ n 2)) kargs))
@ -260,7 +264,15 @@
(lookup-parallel-moves label allocation))
(for-each maybe-load-constant arg-slots (cons proc args))
(emit-call asm proc-slot nargs)
(emit-receive asm dst proc-slot nlocals)))
(cond
(dst
(emit-receive asm dst proc-slot nlocals))
(else
;; FIXME: Only allow more values if there is a rest arg.
;; Express values truncation by the presence of an
;; unused rest arg instead of implicitly.
(emit-receive-values asm proc-slot #t 1)
(emit-reset-frame asm nlocals)))))
(($ $primcall 'current-module)
(emit-current-module asm dst))
(($ $primcall 'cached-toplevel-box (scope name bound?))
@ -321,7 +333,10 @@
(emit-br asm k)
(emit-label asm receive-args)
(emit-receive-values asm proc-slot (->bool rest) nreq)
(when rest
(when (and rest
(match (vector-ref contv (cfa-k-idx cfa khandler-body))
(($ $kargs names (_ ... rest))
(maybe-slot rest))))
(emit-bind-rest asm (+ proc-slot 1 nreq)))
(for-each (match-lambda
((src . dst) (emit-mov asm dst src)))
@ -425,7 +440,7 @@
(($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
(($ $primcall '> (a b)) (binary emit-br-if-< b a))))
(define (compile-trunc label k exp nreq rest? nlocals)
(define (compile-trunc label k exp nreq rest-var nlocals)
(match exp
(($ $call proc args)
(let* ((proc-slot (lookup-call-proc-slot label allocation))
@ -440,7 +455,7 @@
;; Express values truncation by the presence of an
;; unused rest arg instead of implicitly.
(emit-receive-values asm proc-slot #t nreq)
(when rest?
(when (and rest-var (maybe-slot rest-var))
(emit-bind-rest asm (+ proc-slot 1 nreq)))
(for-each (match-lambda
((src . dst) (emit-mov asm dst src)))