From 4e98751ce027dd181b3c6a6eb17f6a0cac0cc7b0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 5 Nov 2008 20:23:38 -0600
Subject: [PATCH] Remove a conditional branch from all tuple dispatches, since
 we don't have to check if the class height is at least 1; and remove memory
 accesses from tuple dispatch where all tuples are height 1

---
 .../standard/engines/tuple/tuple.factor       | 45 +++++++++++--------
 core/generic/standard/standard.factor         | 29 ++++++------
 2 files changed, 42 insertions(+), 32 deletions(-)

diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor
index 8c61aa4240..250ccef6cc 100644
--- a/core/generic/standard/engines/tuple/tuple.factor
+++ b/core/generic/standard/engines/tuple/tuple.factor
@@ -123,8 +123,8 @@ M: echelon-dispatch-engine engine>quot
         ] [ ] make
     ] if ;
 
-: >=-case-quot ( alist -- quot )
-    default get [ drop ] prepend swap
+: >=-case-quot ( default alist -- quot )
+    [ [ drop ] prepend ] dip
     [
         [ [ dup ] swap [ fixnum>= ] curry compose ]
         [ [ drop ] prepose ]
@@ -132,31 +132,40 @@ M: echelon-dispatch-engine engine>quot
     ] assoc-map
     alist>quot ;
 
-: tuple-layout-echelon% ( -- )
+: tuple-layout-echelon-quot ( -- quot )
     [
         { tuple } declare
         1 slot { tuple-layout } declare
         5 slot
-    ] % ; inline
+    ] ; inline
+
+: echelon-case-quot ( alist -- quot )
+    #! We don't have to test for echelon 1 since all tuple
+    #! classes are at least at depth 1 in the inheritance
+    #! hierarchy.
+    dup first first 1 = [ unclip second ] [ default get ] if swap
+    [
+        [
+            picker %
+            tuple-layout-echelon-quot %
+            >=-case-quot %
+        ] [ ] make
+    ] unless-empty ;
 
 M: tuple-dispatch-engine engine>quot
     [
-        picker %
-        tuple-layout-echelon%
         [
             tuple assumed set
-            echelons>> dup empty? [
-                unclip-last
+            echelons>> unclip-last
+            [
                 [
-                    [
-                        engine>quot define-engine-word
-                        [ remember-engine ] [ 1quotation ] bi
-                        dup default set
-                    ] assoc-map
-                ]
-                [ first2 engine>quot 2array ] bi*
-                suffix
-            ] unless
+                    engine>quot define-engine-word
+                    [ remember-engine ] [ 1quotation ] bi
+                    dup default set
+                ] assoc-map
+            ]
+            [ first2 engine>quot 2array ] bi*
+            suffix
         ] with-scope
-        >=-case-quot %
+        echelon-case-quot %
     ] [ ] make ;
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index d22d20a0fc..284a58836f 100644
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -60,21 +60,22 @@ ERROR: no-method object generic ;
     [ 1quotation ] [ extra-values \ drop <repetition> ] bi*
     prepend [ ] like ;
 
+: <standard-engine> ( word -- engine )
+    object bootstrap-word assumed set {
+        [ generic set ]
+        [ "engines" word-prop forget-all ]
+        [ V{ } clone "engines" set-word-prop ]
+        [
+            "methods" word-prop
+            [ generic get mangle-method ] assoc-map
+            [ find-default default set ]
+            [ <big-dispatch-engine> ]
+            bi
+        ]
+    } cleave ;
+
 : single-combination ( word -- quot )
-    [
-        object bootstrap-word assumed set {
-            [ generic set ]
-            [ "engines" word-prop forget-all ]
-            [ V{ } clone "engines" set-word-prop ]
-            [
-                "methods" word-prop
-                [ generic get mangle-method ] assoc-map
-                [ find-default default set ]
-                [ <big-dispatch-engine> ]
-                bi engine>quot
-            ]
-        } cleave
-    ] with-scope ;
+    [ <standard-engine> engine>quot ] with-scope ;
 
 ERROR: inconsistent-next-method class generic ;