Use arity-dispatched procedures for MAP, FOR-EACH, &c.

Requires shuffling initialization order in make.scm a little bit so
that we can call MAKE-ARITY-DISPATCHED-PROCEDURE in list.scm.

Saves a trip through the microcode to compute the lexpr for each call
to MAP and FOR-EACH, which turned up hot in profiles.

diff --git a/src/runtime/list.scm b/src/runtime/list.scm
index 311d53bb11a34039eafa7d9cedff1df2d72a01f9..aa7edd4ff80b74d95453e49026485a4d28bafeb6 100644 (file)
--- a/src/runtime/list.scm
+++ b/src/runtime/list.scm
@@ -628,66 +628,70 @@ USA.
 \f
 ;;;; Mapping Procedures
 
-(define (map procedure first . rest)
-
-  (define (map-1 l)
-    (if (pair? l)
-       (let ((head (cons (procedure (car l)) '())))
-         (let loop ((l (cdr l)) (previous head))
-           (if (pair? l)
-               (let ((new (cons (procedure (car l)) '())))
-                 (set-cdr! previous new)
-                 (loop (cdr l) new))
-               (if (not (null? l))
-                   (bad-end))))
-         head)
-       (begin
-         (if (not (null? l))
-             (bad-end))
-         '())))
-
-  (define (map-2 l1 l2)
-    (if (and (pair? l1) (pair? l2))
-       (let ((head (cons (procedure (car l1) (car l2)) '())))
-         (let loop ((l1 (cdr l1)) (l2 (cdr l2)) (previous head))
-           (if (and (pair? l1) (pair? l2))
-               (let ((new (cons (procedure (car l1) (car l2)) '())))
-                 (set-cdr! previous new)
-                 (loop (cdr l1) (cdr l2) new))
-               (if (not (and (or (null? l1) (pair? l1))
-                             (or (null? l2) (pair? l2))))
-                   (bad-end))))
-         head)
-       (begin
-         (if (not (and (or (null? l1) (pair? l1))
-                       (or (null? l2) (pair? l2))))
-             (bad-end))
-         '())))
-
-  (define (map-n lists)
-    (let ((head (cons unspecific '())))
-      (let loop ((lists lists) (previous head))
-       (let split ((lists lists) (cars '()) (cdrs '()))
-         (if (pair? lists)
-             (if (pair? (car lists))
-                 (split (cdr lists)
-                        (cons (car (car lists)) cars)
-                        (cons (cdr (car lists)) cdrs))
-                 (if (not (null? (car lists)))
-                     (bad-end)))
-             (let ((new (cons (apply procedure (reverse! cars)) '())))
-               (set-cdr! previous new)
-               (loop (reverse! cdrs) new)))))
-      (cdr head)))
-
-  (define (bad-end)
-    (mapper-error (cons first rest) 'map))
-
-  (if (pair? rest)
-      (if (pair? (cdr rest))
-         (map-n (cons first rest))
-         (map-2 first (car rest)))
-      (map-1 first)))
+(define map
+  (make-arity-dispatched-procedure
+   (named-lambda (map self procedure first . rest)
+     self                              ;ignore
+     (define (bad-end)
+       (mapper-error (cons first rest) 'map))
+     (define (map-n lists)
+       (let ((head (cons unspecific '())))
+        (let loop ((lists lists) (previous head))
+          (let split ((lists lists) (cars '()) (cdrs '()))
+            (if (pair? lists)
+                (if (pair? (car lists))
+                    (split (cdr lists)
+                           (cons (car (car lists)) cars)
+                           (cons (cdr (car lists)) cdrs))
+                    (if (not (null? (car lists)))
+                        (bad-end)))
+                (let ((new (cons (apply procedure (reverse! cars)) '())))
+                  (set-cdr! previous new)
+                  (loop (reverse! cdrs) new)))))
+        (cdr head)))
+     (map-n (cons first rest)))
+   #f                                  ;zero arguments
+   #f                                  ;one argument (procedure)
+   (named-lambda (map procedure first)
+     (define (bad-end)
+       (mapper-error (list first) 'map))
+     (define (map-1 l)
+       (if (pair? l)
+          (let ((head (cons (procedure (car l)) '())))
+            (let loop ((l (cdr l)) (previous head))
+              (if (pair? l)
+                  (let ((new (cons (procedure (car l)) '())))
+                    (set-cdr! previous new)
+                    (loop (cdr l) new))
+                  (if (not (null? l))
+                      (bad-end))))
+            head)
+          (begin
+            (if (not (null? l))
+                (bad-end))
+            '())))
+     (map-1 first))
+   (named-lambda (map procedure first second)
+     (define (bad-end)
+       (mapper-error (list first second) 'map))
+     (define (map-2 l1 l2)
+       (if (and (pair? l1) (pair? l2))
+          (let ((head (cons (procedure (car l1) (car l2)) '())))
+            (let loop ((l1 (cdr l1)) (l2 (cdr l2)) (previous head))
+              (if (and (pair? l1) (pair? l2))
+                  (let ((new (cons (procedure (car l1) (car l2)) '())))
+                    (set-cdr! previous new)
+                    (loop (cdr l1) (cdr l2) new))
+                  (if (not (and (or (null? l1) (pair? l1))
+                                (or (null? l2) (pair? l2))))
+                      (bad-end))))
+            head)
+          (begin
+            (if (not (and (or (null? l1) (pair? l1))
+                          (or (null? l2) (pair? l2))))
+                (bad-end))
+            '())))
+     (map-2 first second))))
 
 (define (mapper-error lists caller)
   (for-each (lambda (list)
@@ -712,49 +716,53 @@ USA.
               (combiner (list-ref form 3))
               (initial-value (list-ref form 4)))
           `(set! ,name
-                 (named-lambda (,name ,@extra-vars procedure first . rest)
-
-                   (define (map-1 l)
-                     (if (pair? l)
-                         (,combiner (procedure (car l))
-                                    (map-1 (cdr l)))
-                         (begin
-                           (if (not (null? l))
-                               (bad-end))
-                           ,initial-value)))
-
-                   (define (map-2 l1 l2)
-                     (if (and (pair? l1) (pair? l2))
-                         (,combiner (procedure (car l1) (car l2))
-                                    (map-2 (cdr l1) (cdr l2)))
-                         (begin
-                           (if (not (and (or (null? l1) (pair? l1))
-                                         (or (null? l2) (pair? l2))))
-                               (bad-end))
-                           ,initial-value)))
-
-                   (define (map-n lists)
-                     (let split ((lists lists) (cars '()) (cdrs '()))
-                       (if (pair? lists)
-                           (if (pair? (car lists))
-                               (split (cdr lists)
-                                      (cons (car (car lists)) cars)
-                                      (cons (cdr (car lists)) cdrs))
-                               (begin
-                                 (if (not (null? (car lists)))
-                                     (bad-end))
-                                 ,initial-value))
-                           (,combiner (apply procedure (reverse! cars))
-                                      (map-n (reverse! cdrs))))))
-
-                   (define (bad-end)
-                     (mapper-error (cons first rest) ',name))
-
-                   (if (pair? rest)
-                       (if (pair? (cdr rest))
-                           (map-n (cons first rest))
-                           (map-2 first (car rest)))
-                       (map-1 first)))))))))
+                 (make-arity-dispatched-procedure
+                  (named-lambda (,name self ,@extra-vars procedure
+                                       first . rest)
+                    self               ;ignore
+                    (define (bad-end)
+                      (mapper-error (cons first rest) ',name))
+                    (define (map-n lists)
+                      (let split ((lists lists) (cars '()) (cdrs '()))
+                        (if (pair? lists)
+                            (if (pair? (car lists))
+                                (split (cdr lists)
+                                       (cons (car (car lists)) cars)
+                                       (cons (cdr (car lists)) cdrs))
+                                (begin
+                                  (if (not (null? (car lists)))
+                                      (bad-end))
+                                  ,initial-value))
+                            (,combiner (apply procedure (reverse! cars))
+                                       (map-n (reverse! cdrs))))))
+                    (map-n (cons first rest)))
+                  ,@(map (lambda (argument) argument #f)
+                         `(zero-arguments ,@extra-vars procedure))
+                  (named-lambda (,name ,@extra-vars procedure first)
+                    (define (bad-end)
+                      (mapper-error (list first) ',name))
+                    (define (map-1 l)
+                      (if (pair? l)
+                          (,combiner (procedure (car l))
+                                     (map-1 (cdr l)))
+                          (begin
+                            (if (not (null? l))
+                                (bad-end))
+                            ,initial-value)))
+                    (map-1 first))
+                  (named-lambda (,name ,@extra-vars procedure first second)
+                    (define (bad-end)
+                      (mapper-error (list first second) ',name))
+                    (define (map-2 l1 l2)
+                      (if (and (pair? l1) (pair? l2))
+                          (,combiner (procedure (car l1) (car l2))
+                                     (map-2 (cdr l1) (cdr l2)))
+                          (begin
+                            (if (not (and (or (null? l1) (pair? l1))
+                                          (or (null? l2) (pair? l2))))
+                                (bad-end))
+                            ,initial-value)))
+                    (map-2 first second)))))))))
 
   (mapper for-each () begin unspecific)
   (mapper map* (initial-value) cons initial-value)

diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index 349053f4b4aaaa23b8400295edaa6d98b6834fad..f870e44101bd0f9fe748e6e6b7cbd4e7ee39bb6d 100644 (file)
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -360,15 +360,15 @@ USA.
         ("boot" . (runtime boot-definitions))
         ("queue" . (runtime simple-queue))
         ("equals" . (runtime equality))
+        ("vector" . (runtime vector))
+        ("procedure" . (runtime procedure))
         ("list" . (runtime list))
         ("primitive-arithmetic" . (runtime primitive-arithmetic))
         ("srfi-1" . (runtime srfi-1))
-        ("thread-low" . (runtime thread))
-        ("vector" . (runtime vector))))
+        ("thread-low" . (runtime thread))))
       (files1
        '(("string" . (runtime string))
         ("symbol" . (runtime symbol))
-        ("procedure" . (runtime procedure))
         ("random" . (runtime random-number))
         ("dispatch-tag" . (runtime tagged-dispatch))
         ("poplat" . (runtime population))