From a95bb533b5d40e65a91b1ffe30182edbf752b308 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 6 Nov 2008 09:08:17 -0600
Subject: [PATCH] Remove more redundant branches from tuple type predicates and
 generic words with methods on tuple classes

---
 core/classes/tuple/tuple.factor               | 21 ++++++++++----
 .../standard/engines/tuple/tuple.factor       | 29 ++++++++++++++-----
 2 files changed, 37 insertions(+), 13 deletions(-)

diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index c2f93ead3e..a56a4df029 100644
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -90,20 +90,29 @@ ERROR: bad-superclass class ;
         2drop f
     ] if ; inline
 
+: tuple-instance-1? ( object class -- ? )
+    swap dup tuple? [
+        layout-of 7 slot eq?
+    ] [ 2drop f ] if ; inline
+
 : tuple-instance? ( object class offset -- ? )
-    #! 4 slot == superclasses>>
     rot dup tuple? [
         layout-of
         2dup 1 slot fixnum<=
         [ swap slot eq? ] [ 3drop f ] if
     ] [ 3drop f ] if ; inline
 
-: layout-class-offset ( class -- n )
-    tuple-layout third 2 * 5 + ;
+: layout-class-offset ( echelon -- n )
+    2 * 5 + ;
+
+: echelon-of ( class -- n )
+    tuple-layout third ;
 
 : define-tuple-predicate ( class -- )
-    dup dup layout-class-offset
-    [ tuple-instance? ] 2curry define-predicate ;
+    dup dup echelon-of {
+        { 1 [ [ tuple-instance-1? ] curry ] }
+        [ layout-class-offset [ tuple-instance? ] 2curry ]
+    } case define-predicate ;
 
 : class-size ( class -- n )
     superclasses [ "slots" word-prop length ] sigma ;
@@ -292,7 +301,7 @@ M: tuple-class reset-class
 M: tuple-class rank-class drop 0 ;
 
 M: tuple-class instance?
-    dup layout-class-offset tuple-instance? ;
+    dup echelon-of layout-class-offset tuple-instance? ;
 
 M: tuple-class (flatten-class) dup set ;
 
diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor
index 34447fb92d..04368099fb 100644
--- a/core/generic/standard/engines/tuple/tuple.factor
+++ b/core/generic/standard/engines/tuple/tuple.factor
@@ -48,10 +48,14 @@ TUPLE: tuple-dispatch-engine echelons ;
     \ <tuple-dispatch-engine> convert-methods ;
 
 M: trivial-tuple-dispatch-engine engine>quot
-    [
-        [ n>> nth-superclass% ]
-        [ methods>> engines>quots* linear-dispatch-quot % ] bi
-    ] [ ] make ;
+    [ n>> ] [ methods>> ] bi dup assoc-empty? [
+        2drop default get [ drop ] prepend
+    ] [
+        [
+            [ nth-superclass% ]
+            [ engines>quots* linear-dispatch-quot % ] bi*
+        ] [ ] make
+    ] if ;
 
 : hash-methods ( n methods -- buckets )
     >alist V{ } clone [ hashcode 1array ] distribute-buckets
@@ -119,11 +123,19 @@ M: echelon-dispatch-engine engine>quot
     ] assoc-map
     alist>quot ;
 
+: simplify-echelon-alist ( default alist -- default' alist' )
+    dup empty? [
+        dup first first 1 <= [
+            nip unclip second swap
+            simplify-echelon-alist
+        ] when
+    ] unless ;
+
 : 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
+    default get swap simplify-echelon-alist
     [
         [
             picker %
@@ -140,8 +152,11 @@ M: tuple-dispatch-engine engine>quot
             echelons>> unclip-last
             [
                 [
-                    engine>quot define-engine-word
-                    [ remember-engine ] [ 1quotation ] bi
+                    engine>quot
+                    over 0 = [
+                        define-engine-word
+                        [ remember-engine ] [ 1quotation ] bi
+                    ] unless
                     dup default set
                 ] assoc-map
             ]