Hi all, I had a quick look at improving case-lambda handling, and to my surprise that was very easy to do. All the rest-cdr tracking is already in place, and case-lambda basically expands to a rest lambda which dispatches on the length of the rest arg and then picks it apart. The arguments themselves are already handled correctly by ##core#rest-car, so the only thing that was getting in the way of optimizing away the consing of the rest list was the (length rest-list) call at the top!
The attached patch simply adds another core form ##core#rest-length which is optimized away to check the "c" argument in the C code which indicates the length of the argvector instead of taking the length of the rest list variable. Cheers, Peter
From 96b1d2584a622b6ef8a9ed65daad4acffb00d1df Mon Sep 17 00:00:00 2001
From: Peter Bex <pe...@more-magic.net>
Date: Thu, 21 Nov 2019 17:06:26 +0100
Subject: [PATCH] Add new ##core#rest-length form which speeds up case-lambda
A case-lambda form will simply expand into something like
(lambda rest
(case (length rest)
((0) zero-arg-case)
((1) one-arg-case)
...))
The length call is the only thing that is "special", as can be
verified with a simple test case like this:
(define foo
(case-lambda
((x) (+ x 1))
((x y) (* x y))))
(print (foo 1))
(print (foo 2 3))
---
NEWS | 2 +-
c-backend.scm | 9 +++++++++
core.scm | 10 ++++++++--
optimizer.scm | 1 +
4 files changed, 19 insertions(+), 3 deletions(-)
diff --git a/NEWS b/NEWS
index dde34053..477ffa40 100644
--- a/NEWS
+++ b/NEWS
@@ -38,7 +38,7 @@
- Inline files no longer refer to unexported foreign stub functions
(fixes #1440, thanks to "megane").
- In some cases, rest argument lists do not need to be reified, which
- should make using optional arguments faster (#1623).
+ should make using optional arguments and case-lambda faster (#1623).
- Module system
- Trying to export a foreign variable, define-inlined procedure or
diff --git a/c-backend.scm b/c-backend.scm
index 2af59829..ef8c12b1 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -199,6 +199,15 @@
(gen "C_rest_nullp(c," (+ depth n) ")")
(gen "C_mk_bool(C_unfix(C_i_length(t" (sub1 n) ")) >= " depth ")"))))
+ ((##core#rest-length)
+ (let* ((n (lambda-literal-argument-count ll))
+ (depth (second params))
+ (have-av? (not (or (lambda-literal-customizable ll)
+ (lambda-literal-direct ll)))))
+ (if have-av?
+ (gen "C_fix(c - " (+ depth n) ")")
+ (gen "C_u_i_length(t" (sub1 n) ")"))))
+
((##core#unbox)
(gen "((C_word*)")
(expr (car subs) i)
diff --git a/core.scm b/core.scm
index baeacb67..4623122b 100644
--- a/core.scm
+++ b/core.scm
@@ -180,7 +180,8 @@
; [##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#rest-null? {restvar depth [<debug-info>]}]
+; [##core#rest-length {restvar depth [<debug-info>]}]
; [##core#cond <exp> <exp> <exp>]
; [##core#provide <id>]
; [##core#recurse {<tail-flag>} <exp1> ...]
@@ -2634,7 +2635,7 @@
(make-node '##core#unbox '() (list val))
val) ) )
- ((##core#rest-cdr ##core#rest-car ##core#rest-null?)
+ ((##core#rest-cdr ##core#rest-car ##core#rest-null? ##core#rest-length)
(let* ((rest-var (first params))
(val (ref-var n here closure)))
(unless (eq? val n)
@@ -2665,6 +2666,11 @@
(list "C_i_greater_or_equal_p")
(list (qnode (second params))
(make-node '##core#inline (list "C_i_length") (list (varnode rest-var))))) here closure))
+ ((and (eq? class '##core#rest-length)
+ (test here 'customizable))
+ (transform (make-node '##core#inline
+ (list "C_i_length")
+ (list (varnode rest-var) (second params))) here closure))
(else val)) ) )
((if ##core#call ##core#inline ##core#inline_allocate ##core#callunit
diff --git a/optimizer.scm b/optimizer.scm
index b14b72f3..384557af 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -200,6 +200,7 @@
((member native '("C_i_car" "C_u_i_car")) '##core#rest-car)
((member native '("C_i_cdr" "C_u_i_cdr")) '##core#rest-cdr)
((member native '("C_i_nullp")) '##core#rest-null?)
+ ((member native '("C_i_length" "C_u_i_length")) '##core#rest-length)
(else #f)))
(arg (first (node-subexpressions node)))
((eq? '##core#variable (node-class arg)))
--
2.20.1
signature.asc
Description: PGP signature
