~ chicken-core (chicken-5) 4bb4631943d477324ebf2570fc295c4cbfe752d1

commit 4bb4631943d477324ebf2570fc295c4cbfe752d1
Author:     Peter Bex <peter@more-magic.net>
AuthorDate: Thu Nov 21 17:06:26 2019 +0100
Commit:     Evan Hanson <evhan@foldling.org>
CommitDate: Sun Nov 24 15:39:07 2019 +1300

    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))
    
    Signed-off-by: Evan Hanson <evhan@foldling.org>

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