From fa48a2f79aa623739b0d7d7046378964d6b72b9b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 6 Dec 2013 11:08:45 +0100 Subject: [PATCH] (call-with-values foo (lambda (a . b) a)) avoids consing rest list * 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. --- module/language/cps/compile-bytecode.scm | 25 ++++++++++++--- module/language/cps/slot-allocation.scm | 41 ++++++++++++++++++++++++ 2 files changed, 61 insertions(+), 5 deletions(-) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index aef2265be..216fca620 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -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))) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index ba8398222..d1d02ddb1 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -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)