Hi all, Here's my patch for https://bugs.call-cc.org/ticket/1623. The commit message should provide sufficient details to understand what it does, I hope.
This super simple benchmark runs 25% faster with -O3:
(define (foo #!optional (a 1) (b 2))
(+ a b))
(time
(let lp ((i 0))
(unless (= i 100000000)
(foo 1 3)
(lp (add1 i)))))
I'm not 100% sure it's worth the extra complexity given that this
is not a huge speedup and this kind of code isn't very common.
On the other hand, it's kind of neat and there might be cases where
code benefits a lot from this. The SRFI-13 code for example gets
almost all rest argument list reification eliminated when compiled
with this new version.
The srfi-13 benchmarks in our chicken-benchmarks repo don't show much
of a difference, though.
Cheers,
Peter
From b0f618859980703cc37b49bca0309b1b6e6b456a Mon Sep 17 00:00:00 2001
From: Peter Bex <pe...@more-magic.net>
Date: Sat, 17 Aug 2019 13:30:09 +0200
Subject: [PATCH] Replace car/cdr/null? on rest args with direct argvector
references where possible
In the generated C code, we don't need C_build_rest() to dynamically
build a list containing everything in the argvector beyond the named
arguments. Instead, we can try to detect references to positional
list accesses of the rest argument and convert those directly into
accesses of the argvector. This means we build up less stack, causing
less GC pressure, which should reduce the number of minor GCs in tight
loops involving procedures with rest arguments.
The change introduces three new forms into the core language,
specifically for accessing rest arguments: ##core#rest-{car,cdr,null?}
These new forms represent a chain of calls to (cd...dr <rest-var>)
culminating in either a car, cdr or null? call.
When traversing a chain of rest-cdr calls, variables holding
intermediate cdrs may be eliminated, because only the final rest-cdr
or rest-car or rest-null? call matters.
When we see (if (null? <rest-cdr>) '() (rest-cdr <rest-cdr>)), the
variable which holds the result is marked as a rest-cdr variable.
This allows us to eventually eliminate any intermediate cdr calls on
the rest list. This pattern is common in hand-rolled code, but it is
also generated by let-optionals*, which is in turn used by #!optional.
This catches the majority of rest arg usages.
In analyze-expression, the rest variable in ##core#rest-cdr nodes is
marked as captured to avoid total elimination of it. This is
necessary, so that in closure conversion we still know that its home
closure is one that accepts rest arguments, and when inlining (see
below).
We also need to propagate rest-cdr to aliased variables, so that extra
"let"s don't block rest-cdr optimizations from happening.
One complicating factor is that the optimizer replaces calls to
scheme#{car,cdr,null?} with ##core#inline forms very early on.
This happens after the very first analysis. So, we cannot match
directly on scheme#{car,cdr,null?}, but need to mark calls that look
like (##core#inline "C_i_{car,cdr,nullp}") instead.
Another tricky thing is that procedures with rest args may be inlined
or contracted. When this happens, the "home" procedure of the rest arg
changes, so we can't replace references to rest arg cdrs with direct
argvector references anymore. Therefore, we must rewrite the procedure
body when inlining it and potentially even re-introduce the rest
variable in a let binding.
To illustrate, let's look at an example with optional arguments and
how it will be optimized:
(lambda (#!optional (a 1) (b 2) (c 3))
(print a b c))
this is equivalent to:
(lambda rest
(let-optionals* rest ((a 1)
(b 2)
(c 3))
(print a b c)))
and this is equivalent to and will get optimized as follows:
(lambda rest
(let* ((a (if (null? rest) 1 (car rest)))
(pre-b (if (null? rest) '() (cdr rest)))
(b (if (null? pre-b) 2 (car pre-b)))
(pre-c (if (null? pre-b) '() (cdr pre-b)))
(c (if (null? pre-c) 3 (car pre-c))))
(print a b c)))
=={track rest-cdr call chain and replace with ##core#rest-... nodes}==>
(lambda rest
(let* ((a (if (##core#rest-null? rest 0) 1 (##core#rest-car rest 0)))
(pre-b (if (##core#rest-null? rest 1) '() (##core#rest-cdr rest 1)))
(b (if (##core#rest-null? rest 1) 2 (##core#rest-car rest 1)))
(pre-c (if (##core#rest-null? rest 2) '() (##core#rest-cdr rest 2)))
(c (if (##core#rest-null? rest 2) 3 (##core#rest-car rest 2))))
(print a b c)))
=={eliminate unreferenced variables}==>
(lambda rest
(let* ((a (if (##core#rest-null? rest 0) 1 (##core#rest-car rest 0)))
(b (if (##core#rest-null? rest 1) 2 (##core#rest-car rest 1)))
(c (if (##core#rest-null? rest 2) 3 (##core#rest-car rest 2))))
(print a b c)))
Which, in C, basically translates to
(print <C_get_rest_arg(0)> <C_get_rest_arg(1)> <C_get_rest_arg(2)>)
This is how it's supposed to work conceptually. The actual expansion
involves more LET variables, and the replacement happens in multiple
steps.
Also note that incorrect code like (null? (cdr (cdr (cdr rest)))) which
will normally crash with an error if rest does not contain at least 3
items will now simply return #t. This is unfortunate but not a huge
deal considering this should be rare and also allowed by the spec I
think ("it is an error" doesn't mean "has to raise an exception").
Any other accesses of car or cdr beyond the list's end *are* translated
to code which will result in a runtime error, though.
This change should go a long way to improving #1623
---
batch-driver.scm | 2 +-
c-backend.scm | 16 ++++++---
chicken.h | 3 +-
core.scm | 82 +++++++++++++++++++++++++++++++++++++-----
optimizer.scm | 32 +++++++++++++++++
support.scm | 71 ++++++++++++++++++++++++++++++------
tests/syntax-tests.scm | 18 ++++++++++
7 files changed, 199 insertions(+), 25 deletions(-)
diff --git a/batch-driver.scm b/batch-driver.scm
index 82ed562e..f4393a49 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -146,7 +146,7 @@
((potential-values)
(set! pvals (cdar es)))
((replacable home contains contained-in use-expr closure-size rest-parameter
- captured-variables explicit-rest)
+ captured-variables explicit-rest rest-cdr rest-null?)
(printf "\t~a=~s" (caar es) (cdar es)) )
((references)
(set! refs (cdar es)) )
diff --git a/c-backend.scm b/c-backend.scm
index 10134fbc..c3d3b1f0 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -181,6 +181,16 @@
(expr (car subs) i)
(gen ")[" (+ (first params) 1) #\]) )
+ ((##core#rest-car)
+ (let* ((n (lambda-literal-argument-count ll))
+ (idx (+ (second params) n)))
+ (gen "C_get_rest_arg(c," idx ",av)")))
+
+ ((##core#rest-null?)
+ (let* ((n (lambda-literal-argument-count ll))
+ (idx (+ (second params) n)))
+ (gen "C_rest_nullp(c, " idx ")")))
+
((##core#unbox)
(gen "((C_word*)")
(expr (car subs) i)
@@ -632,8 +642,6 @@
(customizable (lambda-literal-customizable ll))
(empty-closure (and customizable (zero? (lambda-literal-closure-size ll))))
(varlist (intersperse (make-variable-list (if empty-closure (sub1 n) n) "t") #\,))
- (rest (lambda-literal-rest-argument ll))
- (rest-mode (lambda-literal-rest-argument-mode ll))
(direct (lambda-literal-direct ll))
(allocated (lambda-literal-allocated ll)) )
(gen #t)
@@ -679,8 +687,6 @@
(let* ([id (car p)]
[ll (cdr p)]
[argc (lambda-literal-argument-count ll)]
- [rest (lambda-literal-rest-argument ll)]
- [rest-mode (lambda-literal-rest-argument-mode ll)]
[customizable (lambda-literal-customizable ll)]
[empty-closure (and customizable (zero? (lambda-literal-closure-size ll)))] )
(when empty-closure (set! argc (sub1 argc)))
@@ -923,7 +929,7 @@
(apply gen arglist)
(gen ");}"))
(else
- (gen #t "C_save_and_reclaim((void *)" id #\, n ",av);}")))
+ (gen #t "C_save_and_reclaim((void *)" id ",c,av);}")))
(when (> demand 0)
(gen #t "a=C_alloc(" demand ");")))))
(else (gen #\})))
diff --git a/chicken.h b/chicken.h
index dbf6f17b..f6a46ed5 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1244,6 +1244,8 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
#define C_offset_pointer(x, y) (C_pointer_address(x) + (y))
#define C_do_apply(c, av) ((C_proc)(void *)C_block_item((av)[0], 0))((c), (av))
#define C_kontinue(k, r) do { C_word avk[ 2 ]; avk[ 0 ] = (k); avk[ 1 ] = (r); ((C_proc)(void *)C_block_item((k),0))(2, avk); } while(0)
+#define C_get_rest_arg(c, n, av) ((n) >= (c) ? ((n) == (c) ? C_i_car(C_SCHEME_END_OF_LIST) : C_i_cdr(C_SCHEME_END_OF_LIST)) : (av)[(n)])
+#define C_rest_nullp(c, n) (C_mk_bool((n) >= (c)))
#define C_fetch_byte(x, p) (((unsigned C_byte *)C_data_pointer(x))[ p ])
#define C_poke_integer(x, i, n) (C_set_block_item(x, C_unfix(i), C_num_to_int(n)), C_SCHEME_UNDEFINED)
#define C_pointer_to_block(p, x) (C_set_block_item(p, 0, (C_word)C_data_pointer(x)), C_SCHEME_UNDEFINED)
@@ -1629,7 +1631,6 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
#define C_i_true2(dummy1, dummy2) ((dummy1), (dummy2), C_SCHEME_TRUE)
#define C_i_true3(dummy1, dummy2, dummy3) ((dummy1), (dummy2), (dummy3), C_SCHEME_TRUE)
-
/* debug client interface */
typedef struct C_DEBUG_INFO {
diff --git a/core.scm b/core.scm
index 9f39bb30..f9768954 100644
--- a/core.scm
+++ b/core.scm
@@ -178,6 +178,9 @@
; [##core#call {<safe-flag> [<debug-info>]} <exp-f> <exp>...]
; [##core#callunit {<unitname>} <exp>...]
; [##core#switch {<count>} <exp> <const1> <body1> ... <defaultbody>]
+; [##core#rest-car {restvar depth [<debug-info>]}]
+; [##core#rest-cdr {restvar depth [<debug-info>]}]
+; [##core#rest-null? {restvar depth [<debug-info>]} <restvar>]
; [##core#cond <exp> <exp> <exp>]
; [##core#provide <id>]
; [##core#recurse {<tail-flag>} <exp1> ...]
@@ -257,6 +260,8 @@
; extended-binding -> <boolean> If true: variable names an extended binding
; unused -> <boolean> If true: variable is a formal parameter that is never used
; rest-parameter -> #f | 'list If true: variable holds rest-argument list
+; rest-cdr -> (rvar . n) Variable references the cdr of rest list rvar after n cdrs (0 = rest list itself)
+; rest-null? -> (rvar . n) Variable checks if the cdr of rest list rvar after n cdrs is empty (0 = rest list itself)
; constant -> <boolean> If true: variable has fixed value
; hidden-refs -> <boolean> If true: procedure that refers to hidden global variables
; inline-transient -> <boolean> If true: was introduced during inlining
@@ -2096,7 +2101,8 @@
(case class
((quote ##core#undefined ##core#provide ##core#proc) #f)
- ((##core#variable)
+ ;; Uneliminated rest-cdr calls need to hang on to rest var
+ ((##core#variable ##core#rest-cdr)
(let ((var (first params)))
(ref var n)
(unless (memq var localenv)
@@ -2160,7 +2166,8 @@
(db-put! db var 'unknown #t) )
vars)
(when rest
- (db-put! db rest 'rest-parameter 'list) )
+ (db-put! db rest 'rest-parameter 'list)
+ (db-put! db rest 'rest-cdr (cons rest 0)))
(when (simple-lambda-node? n) (db-put! db id 'simple #t))
(let ([tl toplevel-scope])
(unless toplevel-lambda-id (set! toplevel-lambda-id id))
@@ -2204,10 +2211,47 @@
(for-each (lambda (x) (walk x env lenv fenv here)) xs) )
(define (assign var val env here)
+ ;; Propagate rest-cdr and rest-null? onto aliased variables
+ (and-let* (((eq? '##core#variable (node-class val)))
+ (v (db-get db (first (node-parameters val)) 'rest-cdr)))
+ (db-put! db var 'rest-cdr v) )
+
+ (and-let* (((eq? '##core#variable (node-class val)))
+ (v (db-get db (first (node-parameters val)) 'rest-null?)))
+ (db-put! db var 'rest-null? v) )
+
(cond ((eq? '##core#undefined (node-class val))
(db-put! db var 'undefined #t) )
((and (eq? '##core#variable (node-class val)) ; assignment to itself
(eq? var (first (node-parameters val))) ) )
+
+ ;; Propagate info from ##core#rest-{cdr,null?} nodes to var
+ ((eq? '##core#rest-cdr (node-class val))
+ (let ((restvar (car (node-parameters val)))
+ (depth (cadr (node-parameters val))))
+ (db-put! db var 'rest-cdr (cons restvar (add1 depth))) ) )
+
+ ((eq? '##core#rest-null? (node-class val))
+ (let ((restvar (car (node-parameters val)))
+ (depth (cadr (node-parameters val))))
+ (db-put! db var 'rest-null? (cons restvar depth)) ) )
+
+ ;; (##core#cond (null? r) '() (cdr r)) => result is tagged as a rest-cdr var
+ ((and-let* (((eq? '##core#cond (node-class val)))
+ (subs (node-subexpressions val))
+ ((eq? '##core#variable (node-class (car subs))))
+ ((db-get db (first (node-parameters (car subs))) 'rest-null?))
+ (node-when-null (cadr subs))
+ ((eq? 'quote (node-class node-when-null)))
+ ((eq? '() (first (node-parameters node-when-null))))
+ (rest-cdr-node (caddr subs))
+ ((eq? '##core#rest-cdr (node-class rest-cdr-node))))
+ rest-cdr-node)
+ => (lambda (rest-cdr-node)
+ (let ((restvar (car (node-parameters rest-cdr-node)))
+ (depth (cadr (node-parameters rest-cdr-node))))
+ (db-put! db var 'rest-cdr (cons restvar (add1 depth))) )) )
+
((or (memq var env)
(variable-mark var '##compiler#constant)
(not (variable-visible? var block-compilation)))
@@ -2257,8 +2301,8 @@
[assigned-locally #f]
[undefined #f]
[global #f]
- [rest-parameter #f]
[nreferences 0]
+ [rest-cdr #f]
[ncall-sites 0] )
(set! current-analysis-database-size (fx+ current-analysis-database-size 1))
@@ -2282,7 +2326,7 @@
[(global) (set! global #t)]
[(value) (set! value (cdr prop))]
[(local-value) (set! local-value (cdr prop))]
- [(rest-parameter) (set! rest-parameter #t)] ) )
+ [(rest-cdr) (set! rest-cdr (cdr prop))] ) )
plist)
(set! value (and (not unknown) value))
@@ -2397,8 +2441,10 @@
(rest
(db-put! db (first lparams) 'explicit-rest #t) ) ) ) ) ) ) ) ) )
- ;; Make 'removable, if it has no references and is not assigned to, and if it
- ;; has either a value that does not cause any side-effects or if it is 'undefined:
+ ;; Make 'removable, if it has no references and is not assigned to, and one of the following:
+ ;; - it has either a value that does not cause any side-effects
+ ;; - it is 'undefined
+ ;; - it holds only a 'rest-cdr reference (strictly speaking, it may bomb but we don't care)
(when (and (not assigned)
(null? references)
(or (and value
@@ -2408,7 +2454,8 @@
(variable-mark varname '##core#always-bound)
(intrinsic? varname)))
(not (expression-has-side-effects? value db)) ))
- undefined) )
+ undefined
+ rest-cdr) )
(quick-put! plist 'removable #t) )
;; Make 'replacable, if
@@ -2494,7 +2541,7 @@
(params (node-parameters n)) )
(case (node-class n)
- ((##core#variable)
+ ((##core#variable ##core#rest-cdr)
(let ((var (first params)))
(if (memq var lexicals)
(list var)
@@ -2590,6 +2637,25 @@
(make-node '##core#unbox '() (list val))
val) ) )
+ ((##core#rest-cdr ##core#rest-car ##core#rest-null?)
+ (let* ((rest-var (first params))
+ (val (ref-var n here closure)))
+ (unless (eq? val n)
+ ;; If it's captured, replacement in optimizer was incorrect
+ (quit-compiling "Saw rest op `~s' for captured variable. This should not happen!" class) )
+ ;; If rest-cdrs have not all been eliminated, restore
+ ;; them as regular cdr calls on the rest list variable.
+ ;; This can be improved, as it can actually introduce
+ ;; many more cdr calls than necessary.
+ (if (eq? class '##core#rest-cdr)
+ (let lp ((cdr-calls (add1 (second params)))
+ (var (varnode rest-var)))
+ (if (zero? cdr-calls)
+ (transform var here closure)
+ (lp (sub1 cdr-calls)
+ (make-node '##core#inline (list "C_i_cdr") (list var)))))
+ val) ) )
+
((if ##core#call ##core#inline ##core#inline_allocate ##core#callunit
##core#inline_ref ##core#inline_update ##core#debug-event
##core#switch ##core#cond ##core#direct_call ##core#recurse ##core#return
diff --git a/optimizer.scm b/optimizer.scm
index fbf60bac..3b390d8e 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -189,6 +189,35 @@
entry) )
n) )
+
+ (define (maybe-replace-rest-arg-calls node)
+ ;; Ugh, we need to match on the core inlined string instead of
+ ;; the call to the intrinsic itself, because rewrites will have
+ ;; introduced this after the first iteration.
+ (or (and-let* (((eq? '##core#inline (node-class node)))
+ (native (->string (car (node-parameters node)))) ;; NOTE: should always be string?
+ (replacement-op (cond
+ ((string=? native "C_i_car") '##core#rest-car)
+ ((string=? native "C_i_cdr") '##core#rest-cdr)
+ ((string=? native "C_i_nullp") '##core#rest-null?)
+ (else #f)))
+ (arg (first (node-subexpressions node)))
+ ((eq? '##core#variable (node-class arg)))
+ (var (first (node-parameters arg)))
+ ((not (db-get db var 'captured)))
+ (info (db-get db var 'rest-cdr))
+ (restvar (car info))
+ (depth (cdr info))
+ ((not (test var 'assigned))))
+ ;; callee is intrinsic and accesses rest arg sublist
+ (debugging 'o "known list op on rest arg sublist"
+ (call-info (node-parameters node) replacement-op) var depth)
+ (touch)
+ (make-node replacement-op
+ (cons* restvar depth (cdr (node-parameters node)))
+ (list) ) )
+ node) )
+
(define (walk n fids gae)
(if (memq n broken-constant-nodes)
n
@@ -208,6 +237,9 @@
fids gae) )
(else n1) ) )
+ ((##core#inline)
+ (maybe-replace-rest-arg-calls n1))
+
((##core#call)
(maybe-constant-fold-call
n1
diff --git a/support.scm b/support.scm
index 729d44aa..64882012 100644
--- a/support.scm
+++ b/support.scm
@@ -650,20 +650,32 @@
(let* ((rlist (if copy? (map gensym vars) vars))
(body (if copy?
(copy-node-tree-and-rename body vars rlist db cfk)
- body) ) )
+ body) )
+ (rarg-aliases (map (lambda (r) (gensym 'rarg)) rargs)) )
+ (replace-rest-ops-in-known-call! db body rest (last rlist) rarg-aliases)
(let loop ((vars (take rlist argc))
(vals largs))
(if (null? vars)
(if rest
- (make-node
- 'let (list (last rlist))
- (list (if (null? rargs)
- (qnode '())
- (make-node
- '##core#inline_allocate
- (list "C_a_i_list" (* 3 (length rargs)))
- rargs) )
- body) )
+ ;; NOTE: If contraction happens before rest-op
+ ;; detection, we might needlessly build a list.
+ (let loop2 ((rarg-values rargs)
+ (rarg-aliases rarg-aliases))
+ (if (null? rarg-aliases)
+ (if (null? (db-get-list db rest 'references))
+ body
+ (make-node
+ 'let (list (last rlist))
+ (list (if (null? rargs)
+ (qnode '())
+ (make-node
+ '##core#inline_allocate
+ (list "C_a_i_list" (* 3 (length rargs)))
+ rargs) )
+ body) ))
+ (make-node 'let (list (car rarg-aliases))
+ (list (car rarg-values)
+ (loop2 (cdr rarg-values) (cdr rarg-aliases))))))
body)
(make-node 'let (list (car vars))
(list (car vals)
@@ -718,6 +730,45 @@
(map (cut walk <> rl) subs))) ) ) )
(walk node rlist) ) )
+;; Replace rest-{car,cdr,null?} with equivalent code which accesses
+;; the rest argument directly.
+(define (replace-rest-ops-in-known-call! db node rest-var rest-alias rest-args)
+ (define (walk n)
+ (let ((subs (node-subexpressions n))
+ (params (node-parameters n))
+ (class (node-class n)) )
+ (case class
+ ((##core#rest-null?)
+ (if (eq? rest-var (first params))
+ (copy-node! (qnode (<= (length rest-args) (second params))) n)
+ n))
+ ((##core#rest-car)
+ (if (eq? rest-var (first params))
+ (let ((depth (second params))
+ (len (length rest-args)))
+ (if (> len depth)
+ (copy-node! (varnode (list-ref rest-args depth)) n)
+ ;; Emit code which will crash at runtime, because
+ ;; there aren't enough arguments...
+ (copy-node! (make-node '##core#inline
+ (list (if (= len depth) "C_i_car" "C_i_cdr"))
+ (list (qnode '())))
+ n)))
+ n))
+ ((##core#rest-cdr)
+ (cond ((eq? rest-var (first params))
+ (collect! db rest-var 'references n) ; Restore this reference
+ (let lp ((i (add1 (second params)))
+ (new-node (varnode rest-alias)))
+ (if (zero? i)
+ (copy-node! new-node n)
+ (lp (sub1 i)
+ (make-node '##core#inline (list "C_i_cdr") (list new-node))))))
+ (else n)))
+ (else (for-each walk subs)) ) ) )
+
+ (walk node) )
+
;; Maybe move to scrutinizer. It's generic enough to keep it here though
(define (tree-copy t)
(let rec ([t t])
diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
index 1c98d94c..68c08483 100644
--- a/tests/syntax-tests.scm
+++ b/tests/syntax-tests.scm
@@ -864,6 +864,24 @@
(assert (equal? '(3 4 5 (6 7)) (test-optional&rest 3 4 5 6 7)))
+(define (test-optional&rest-cdrs x y #!optional z #!rest r)
+ (list x y z (cdr (cdr r))))
+
+(assert (equal? '(3 4 5 ()) (test-optional&rest-cdrs 3 4 5 6 7)))
+
+;; Ensure that rest conversion is not applied too aggressively.
+;; (only when the consequence is () should it be applied)
+(define (rest-nonnull-optimization . rest)
+ (let ((x (if (null? (cdr rest))
+ '(foo)
+ (cdr rest))))
+ (null? x)))
+
+(assert (not (rest-nonnull-optimization 1)))
+(assert (not (rest-nonnull-optimization 1 2)))
+
+(assert (equal? '(3 4 5 ()) (test-optional&rest-cdrs 3 4 5 6 7)))
+
(define (test-optional&key x y #!optional z #!key i (j 1))
(list x y z i: i j: j))
--
2.20.1
signature.asc
Description: PGP signature
