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

(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)))

41
module/language/cps/slot-allocation.scm
View file

@ -354,6 +354,38 @@ are comparable with eqv?. A tmp slot may be used."
(_ #f))
(lp (1+ n)))))
;; Results of function calls that are not used don't need to be
;; allocated to slots.
(define (compute-unused-results!)
(define (ktrunc-get-kargs n)
(match (vector-ref contv n)
(($ $ktrunc arity kargs) (cfa-k-idx cfa kargs))
(_ #f)))
(let ((candidates (make-bitvector (vector-length contv) #f)))
;; Find all $kargs that are the successors of $ktrunc nodes.
(let lp ((n 0))
(when (< n (vector-length contv))
(and=> (ktrunc-get-kargs n)
(lambda (kargs)
(bitvector-set! candidates kargs #t)))
(lp (1+ n))))
;; For $kargs that only have $ktrunc predecessors, remove unused
;; variables from the needs-slotv set.
(let lp ((n 0))
(let ((n (bit-position #t candidates n)))
(when n
(match (cfa-predecessors cfa n)
;; At least one ktrunc is in the predecessor set, so we
;; only need to do the check for nodes with >1
;; predecessor.
((or (_) ((? ktrunc-get-kargs) ...))
(for-each (lambda (var)
(when (dead-after-def? (cfa-k-sym cfa n) var dfa)
(bitvector-set! needs-slotv var #f)))
(vector-ref defv n)))
(_ #f))
(lp (1+ n)))))))
;; Compute the set of variables whose allocation should be delayed
;; until a "hint" is known about where to allocate them. This is
;; the case for some procedure arguments.
@ -463,6 +495,10 @@ are comparable with eqv?. A tmp slot may be used."
(result-live (fold allocate!
post-live result-vars value-slots))
(result-slots (map (cut vector-ref slots <>) result-vars))
;; Filter out unused results.
(value-slots (filter-map (lambda (val result) (and result val))
value-slots result-slots))
(result-slots (filter (lambda (x) x) result-slots))
(result-moves (parallel-move value-slots
result-slots
(compute-tmp-slot result-live
@ -513,6 +549,10 @@ are comparable with eqv?. A tmp slot may be used."
(result-live (fold allocate!
handler-live result-vars value-slots))
(result-slots (map (cut vector-ref slots <>) result-vars))
;; Filter out unused results.
(value-slots (filter-map (lambda (val result) (and result val))
value-slots result-slots))
(result-slots (filter (lambda (x) x) result-slots))
(moves (parallel-move value-slots
result-slots
(compute-tmp-slot result-live
@ -599,6 +639,7 @@ are comparable with eqv?. A tmp slot may be used."
(compute-conts!)
(compute-constants!)
(compute-uses-and-defs!)
(compute-unused-results!)
(compute-needs-hint!)
(visit-entry)