From c0f440fe8abb982ff7377b6d97ecea9250bfcd4a Mon Sep 17 00:00:00 2001
From: Taylor R Campbell <campbell@mumble.net>
Date: Sun, 10 Feb 2019 04:34:34 +0000
Subject: [PATCH] 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.
---
 src/runtime/list.scm | 214 ++++++++++++++++++++++---------------------
 src/runtime/make.scm |   6 +-
 2 files changed, 114 insertions(+), 106 deletions(-)

diff --git a/src/runtime/list.scm b/src/runtime/list.scm
index 311d53bb1..aa7edd4ff 100644
--- a/src/runtime/list.scm
+++ b/src/runtime/list.scm
@@ -628,66 +628,70 @@ USA.
 
 ;;;; 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 349053f4b..f870e4410 100644
--- 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))
-- 
2.25.1