From 3fc580e15c0c9b7bdf544785969c93cf1fb6c023 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 15 Aug 2012 23:48:36 -0700
Subject: [PATCH] Remove alternate/optimized types of scode combinations from
 runtime.

---
 src/compiler/fggen/canon.scm |  7 +---
 src/compiler/fggen/fggen.scm |  7 +---
 src/runtime/codwlk.scm       |  9 +----
 src/runtime/conpar.scm       |  9 -----
 src/runtime/framex.scm       | 22 ------------
 src/runtime/scomb.scm        | 67 ++++++------------------------------
 src/runtime/unpars.scm       |  6 ----
 7 files changed, 14 insertions(+), 113 deletions(-)

diff --git a/src/compiler/fggen/canon.scm b/src/compiler/fggen/canon.scm
index 8b376f215..dae64f82d 100644
--- a/src/compiler/fggen/canon.scm
+++ b/src/compiler/fggen/canon.scm
@@ -867,12 +867,7 @@ ARBITRARY:	The expression may be executed more than once.  It
       (binary-entry disjunction)
       (standard-entry variable)
       (standard-entry the-environment)
-      (dispatch-entries (combination-1 combination-2 combination
-				       primitive-combination-0
-				       primitive-combination-1
-				       primitive-combination-2
-				       primitive-combination-3)
-			canonicalize/combination)
+      (dispatch-entry combination canonicalize/combination)
       (dispatch-entries (lambda lexpr extended-lambda) canonicalize/lambda)
       (dispatch-entry sequence-2 canonicalize/sequence))
     (named-lambda (canonicalize/expression expression bound context)
diff --git a/src/compiler/fggen/fggen.scm b/src/compiler/fggen/fggen.scm
index 32c8eb946..9ce8396e7 100644
--- a/src/compiler/fggen/fggen.scm
+++ b/src/compiler/fggen/fggen.scm
@@ -991,12 +991,7 @@ USA.
       (standard-entry variable)
       (dispatch-entries (lambda lexpr extended-lambda) generate/lambda)
       (dispatch-entry sequence-2 generate/sequence)
-      (dispatch-entries (combination-1 combination-2 combination
-				       primitive-combination-0
-				       primitive-combination-1
-				       primitive-combination-2
-				       primitive-combination-3)
-			generate/combination)
+      (dispatch-entry combination generate/combination)
       (dispatch-entry comment generate/comment))
     (named-lambda (generate/expression block continuation context expression)
       ((vector-ref dispatch-vector (object-type expression))
diff --git a/src/runtime/codwlk.scm b/src/runtime/codwlk.scm
index 396b41cc9..92342fc0e 100644
--- a/src/runtime/codwlk.scm
+++ b/src/runtime/codwlk.scm
@@ -111,14 +111,7 @@ USA.
 			    (kernel (car entry)))))
 		    `((ACCESS ,walk/access)
 		      (ASSIGNMENT ,walk/assignment)
-		      ((COMBINATION
-			COMBINATION-1
-			COMBINATION-2
-			PRIMITIVE-COMBINATION-0
-			PRIMITIVE-COMBINATION-1
-			PRIMITIVE-COMBINATION-2
-			PRIMITIVE-COMBINATION-3)
-		       ,walk/combination)
+		      (COMBINATION ,walk/combination)
 		      (COMMENT ,walk/comment)
 		      (CONDITIONAL ,walk/conditional)
 		      (DEFINITION ,walk/definition)
diff --git a/src/runtime/conpar.scm b/src/runtime/conpar.scm
index 5ff34ebf2..02f233bbc 100644
--- a/src/runtime/conpar.scm
+++ b/src/runtime/conpar.scm
@@ -806,20 +806,11 @@ USA.
 
     (standard-subproblem 'ACCESS-CONTINUE 2)
     (standard-subproblem 'ASSIGNMENT-CONTINUE 3)
-    (standard-subproblem 'COMBINATION-1-PROCEDURE 3)
-    (standard-subproblem 'COMBINATION-2-FIRST-OPERAND 3)
-    (standard-subproblem 'COMBINATION-2-PROCEDURE 4)
     (standard-subproblem 'CONDITIONAL-DECIDE 3)
     (standard-subproblem 'DEFINITION-CONTINUE 3)
     (standard-subproblem 'DISJUNCTION-DECIDE 3)
     (standard-subproblem 'EVAL-ERROR 3)
     (standard-subproblem 'FORCE-SNAP-THUNK 2)
-    (standard-subproblem 'PRIMITIVE-COMBINATION-1-APPLY 2)
-    (standard-subproblem 'PRIMITIVE-COMBINATION-2-APPLY 3)
-    (standard-subproblem 'PRIMITIVE-COMBINATION-2-FIRST-OPERAND 3)
-    (standard-subproblem 'PRIMITIVE-COMBINATION-3-APPLY 4)
-    (standard-subproblem 'PRIMITIVE-COMBINATION-3-FIRST-OPERAND 4)
-    (standard-subproblem 'PRIMITIVE-COMBINATION-3-SECOND-OPERAND 3)
     (standard-subproblem 'SEQUENCE-2-SECOND 3)
 
     (standard-subproblem 'COMBINATION-SAVE-VALUE length/combination-save-value)
diff --git a/src/runtime/framex.scm b/src/runtime/framex.scm
index 941bee16c..9f17a15bc 100644
--- a/src/runtime/framex.scm
+++ b/src/runtime/framex.scm
@@ -115,12 +115,6 @@ USA.
 	    undefined-environment
 	    (validate-subexpression frame (select-subexpression expression)))))
 
-(define (method/primitive-combination-3-first-operand frame)
-  (let ((expression (stack-frame/ref frame 1)))
-    (values expression
-	    (stack-frame/ref frame 3)
-	    (validate-subexpression frame (&vector-ref expression 2)))))
-
 (define (method/combination-save-value frame)
   (let ((expression (stack-frame/ref frame 1)))
     (values expression
@@ -276,28 +270,12 @@ USA.
     (record-method 'SEQUENCE-2-SECOND method))
   (let ((method (method/standard &pair-cdr)))
     (record-method 'ASSIGNMENT-CONTINUE method)
-    (record-method 'COMBINATION-1-PROCEDURE method)
     (record-method 'DEFINITION-CONTINUE method))
   (let ((method (method/standard &triple-first)))
     (record-method 'CONDITIONAL-DECIDE method))
-  (let ((method (method/standard &triple-second)))
-    (record-method 'COMBINATION-2-PROCEDURE method))
-  (let ((method (method/standard &triple-third)))
-    (record-method 'COMBINATION-2-FIRST-OPERAND method)
-    (record-method 'PRIMITIVE-COMBINATION-2-FIRST-OPERAND method))
-  (record-method 'PRIMITIVE-COMBINATION-3-SECOND-OPERAND
-		 (method/standard &vector-fourth))
   (let ((method (method/expression-only &pair-car)))
     (record-method 'ACCESS-CONTINUE method))
-  (record-method 'PRIMITIVE-COMBINATION-1-APPLY
-		 (method/expression-only &pair-cdr))
-  (record-method 'PRIMITIVE-COMBINATION-2-APPLY
-		 (method/expression-only &triple-second))
-  (record-method 'PRIMITIVE-COMBINATION-3-APPLY
-		 (method/expression-only &vector-second))
   (record-method 'COMBINATION-SAVE-VALUE method/combination-save-value)
-  (record-method 'PRIMITIVE-COMBINATION-3-FIRST-OPERAND
-		 method/primitive-combination-3-first-operand)
   (record-method 'EVAL-ERROR method/eval-error)
   (record-method 'FORCE-SNAP-THUNK method/force-snap-thunk)
   (let ((method (method/application-frame 3)))
diff --git a/src/runtime/scomb.scm b/src/runtime/scomb.scm
index 6d466552c..ebf03b6be 100644
--- a/src/runtime/scomb.scm
+++ b/src/runtime/scomb.scm
@@ -150,79 +150,34 @@ USA.
 ;;;; Combination
 
 (define (combination? object)
-  (or (object-type? (ucode-type combination) object)
-      (object-type? (ucode-type combination-1) object)
-      (object-type? (ucode-type combination-2) object)
-      (object-type? (ucode-type primitive-combination-0) object)
-      (object-type? (ucode-type primitive-combination-1) object)
-      (object-type? (ucode-type primitive-combination-2) object)
-      (object-type? (ucode-type primitive-combination-3) object)))
+  (object-type? (ucode-type combination) object))
 
 (define-guarantee combination "SCode combination")
 
 (define (make-combination operator operands)
   (&typed-vector-cons (ucode-type combination)
 		      (cons operator operands)))
-
-(define-syntax combination-dispatch
-  (sc-macro-transformer
-   (lambda (form environment)
-     (let ((name (list-ref form 1))
-	   (combination (close-syntax (list-ref form 2) environment))
-	   (case-0 (close-syntax (list-ref form 3) environment))
-	   (case-1 (close-syntax (list-ref form 4) environment))
-	   (case-2 (close-syntax (list-ref form 5) environment))
-	   (case-n (close-syntax (list-ref form 6) environment)))
-       `(COND ((OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-0)
-			     ,combination)
-	       ,case-0)
-	      ((OR (OBJECT-TYPE? (UCODE-TYPE COMBINATION-1) ,combination)
-		   (OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-1)
-				 ,combination))
-	       ,case-1)
-	      ((OR (OBJECT-TYPE? (UCODE-TYPE COMBINATION-2) ,combination)
-		   (OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-2)
-				 ,combination))
-	       ,case-2)
-	      ((OR (OBJECT-TYPE? (UCODE-TYPE COMBINATION) ,combination)
-		   (OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-3)
-				 ,combination))
-	       ,case-n)
-	      (ELSE
-	       (ERROR:NOT-COMBINATION ,combination ',name)))))))
 
 (define (combination-size combination)
-  (combination-dispatch combination-size combination
-			1 2 3 (&vector-length combination)))
+  (guarantee-combination combination 'COMBINATION-SIZE)
+  (&vector-length combination))
 
 (define (combination-operator combination)
-  (combination-dispatch combination-operator combination
-			(object-new-type (ucode-type primitive) combination)
-			(&pair-car combination)
-			(&triple-first combination)
-			(&vector-ref combination 0)))
+  (guarantee-combination combination 'COMBINATION-OPERATOR)
+  (&vector-ref combination 0))
 
 (define (combination-operands combination)
-  (combination-dispatch
-   combination-operands combination
-   '()
-   (list (&pair-cdr combination))
-   (list (&triple-second combination) (&triple-third combination))
-   (&subvector->list combination 1 (&vector-length combination))))
+  (guarantee-combination combination 'COMBINATION-OPERANDS)
+  (&subvector->list combination 1 (&vector-length combination)))
 
 (define (combination-components combination receiver)
-  (combination-dispatch
-   combination-components combination
-   (receiver (object-new-type (ucode-type primitive) combination) '())
-   (receiver (&pair-car combination) (list (&pair-cdr combination)))
-   (receiver (&triple-first combination)
-	     (list (&triple-second combination) (&triple-third combination)))
-   (receiver (&vector-ref combination 0)
-	     (&subvector->list combination 1 (&vector-length combination)))))
+  (guarantee-combination combination 'COMBINATION-OPERANDS)
+  (receiver (&vector-ref combination 0)
+	    (&subvector->list combination 1 (&vector-length combination))))
 
 (define (combination-subexpressions expression)
   (combination-components expression cons))
-
+
 ;;;; Unassigned?
 
 (define (make-unassigned? name)
diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm
index bde57101a..502ad1f16 100644
--- a/src/runtime/unpars.scm
+++ b/src/runtime/unpars.scm
@@ -296,12 +296,6 @@ USA.
     (PRIMITIVE . PRIMITIVE-PROCEDURE)
     (LEXPR . LAMBDA)
     (EXTENDED-LAMBDA . LAMBDA)
-    (COMBINATION-1 . COMBINATION)
-    (COMBINATION-2 . COMBINATION)
-    (PRIMITIVE-COMBINATION-0 . COMBINATION)
-    (PRIMITIVE-COMBINATION-1 . COMBINATION)
-    (PRIMITIVE-COMBINATION-2 . COMBINATION)
-    (PRIMITIVE-COMBINATION-3 . COMBINATION)
     (SEQUENCE-2 . SEQUENCE)))
 
 (define (unparse/false object)
-- 
2.25.1