From a95bb533b5d40e65a91b1ffe30182edbf752b308 Mon Sep 17 00:00:00 2001 From: Slava Pestov 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 ; \ 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 ]