From cc879fa9b7c1febf7d6d5aec38aa55f496d63d28 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 5 Nov 2008 22:20:29 -0600 Subject: [PATCH] Tuple layouts are now arrays, instead of built-in types. The superclass array is now part of the tuple layout object itself, and class hashcodes are stored alongside class words there. This removes 2 indirections when reading a superclass, and 3 when reading a superclass hashcode. --- basis/bootstrap/image/image.factor | 15 ---- .../cfg/intrinsics/allot/allot.factor | 6 +- .../tree/propagation/info/info.factor | 2 +- .../known-words/known-words.factor | 2 +- .../tree/propagation/propagation-tests.factor | 2 +- .../tree/propagation/slots/slots.factor | 2 +- basis/prettyprint/backend/backend.factor | 3 - .../known-words/known-words.factor | 5 +- core/bootstrap/layouts/layouts.factor | 5 +- core/bootstrap/primitives.factor | 10 --- core/bootstrap/stage1.factor | 3 +- core/classes/tuple/tuple-docs.factor | 6 +- core/classes/tuple/tuple-tests.factor | 2 +- core/classes/tuple/tuple.factor | 34 +++++--- .../standard/engines/tuple/tuple.factor | 79 +++++++------------ vm/data_gc.c | 2 - vm/debug.c | 11 ++- vm/layouts.h | 16 ++-- vm/primitives.c | 1 - vm/types.c | 16 +--- 20 files changed, 85 insertions(+), 137 deletions(-) diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 643899102e..fdc8451173 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -368,21 +368,6 @@ M: byte-array ' M: tuple ' emit-tuple ; -M: tuple-layout ' - [ - [ - { - [ hashcode>> , ] - [ class>> , ] - [ size>> , ] - [ superclasses>> , ] - [ echelon>> , ] - } cleave - ] { } make [ ' ] map - \ tuple-layout type-number - object tag-number [ emit-seq ] emit-object - ] cache-object ; - M: tombstone ' state>> "((tombstone))" "((empty))" ? "hashtables.private" lookup def>> first diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor index f0796c59f0..ceac5e960c 100644 --- a/basis/compiler/cfg/intrinsics/allot/allot.factor +++ b/basis/compiler/cfg/intrinsics/allot/allot.factor @@ -16,14 +16,14 @@ IN: compiler.cfg.intrinsics.allot [ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi ; : tuple-slot-regs ( layout -- vregs ) - [ size>> ds-load ] [ ^^load-literal ] bi prefix ; + [ second ds-load ] [ ^^load-literal ] bi prefix ; : emit- ( node -- ) dup node-input-infos peek literal>> - dup tuple-layout? [ + dup array? [ nip ds-drop - [ tuple-slot-regs ] [ size>> ^^allot-tuple ] bi + [ tuple-slot-regs ] [ second ^^allot-tuple ] bi [ tuple ##set-slots ] [ ds-push drop ] 2bi ] [ drop emit-primitive ] if ; diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index 5f8de4eb49..d1d8189f7a 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -307,5 +307,5 @@ SYMBOL: value-infos : immutable-tuple-boa? ( #call -- ? ) dup word>> \ eq? [ dup in-d>> peek node-value-info - literal>> class>> immutable-tuple-class? + literal>> first immutable-tuple-class? ] [ drop f ] if ; diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index a1ccaa95bd..3b698e0001 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -281,7 +281,7 @@ generic-comparison-ops [ { } [ [ - literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if + literal>> dup array? [ first ] [ drop tuple ] if [ clear ] dip ] "outputs" set-word-prop ] each diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 19ee051ac6..101320f92c 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -379,7 +379,7 @@ TUPLE: mutable-tuple-test { x sequence } ; [ T{ mutable-tuple-test f "hey" } x>> ] final-classes ] unit-test -[ V{ tuple-layout } ] [ +[ V{ array } ] [ [ T{ mutable-tuple-test f "hey" } layout-of ] final-classes ] unit-test diff --git a/basis/compiler/tree/propagation/slots/slots.factor b/basis/compiler/tree/propagation/slots/slots.factor index 08a8520d0a..83e71c3363 100644 --- a/basis/compiler/tree/propagation/slots/slots.factor +++ b/basis/compiler/tree/propagation/slots/slots.factor @@ -45,7 +45,7 @@ UNION: fixed-length-sequence array byte-array string ; : propagate- ( #call -- info ) in-d>> unclip-last - value-info literal>> class>> (propagate-tuple-constructor) ; + value-info literal>> first (propagate-tuple-constructor) ; : propagate- ( #call -- info ) in-d>> [ value-info ] map complex ; diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index f8445c7783..b749bd63eb 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -233,6 +233,3 @@ M: wrapper pprint* ] [ pprint-object ] if ; - -M: tuple-layout pprint* - "( tuple layout )" swap present-text ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 2c0bae5328..c40b94fd3c 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -108,7 +108,7 @@ M: object infer-call* : infer- ( -- ) \ - peek-d literal value>> size>> 1+ { tuple } + peek-d literal value>> second 1+ { tuple } apply-word/effect ; : infer-(throw) ( -- ) @@ -561,9 +561,6 @@ do-primitive alien-invoke alien-indirect alien-callback \ { tuple-layout } { tuple } define-primitive \ make-flushable -\ { word fixnum array fixnum } { tuple-layout } define-primitive -\ make-foldable - \ datastack { } { array } define-primitive \ datastack make-flushable diff --git a/core/bootstrap/layouts/layouts.factor b/core/bootstrap/layouts/layouts.factor index 08df740305..26100277a8 100644 --- a/core/bootstrap/layouts/layouts.factor +++ b/core/bootstrap/layouts/layouts.factor @@ -9,7 +9,7 @@ BIN: 111 tag-mask set 8 num-tags set 3 tag-bits set -18 num-types set +17 num-types set H{ { fixnum BIN: 000 } @@ -29,9 +29,8 @@ tag-numbers get H{ { byte-array 10 } { callstack 11 } { string 12 } - { tuple-layout 13 } + { word 13 } { quotation 14 } { dll 15 } { alien 16 } - { word 17 } } assoc-union type-numbers set diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index bbc86c2e3c..3accb8a9b8 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -147,7 +147,6 @@ bootstrapping? on "alien" "alien" create register-builtin "word" "words" create register-builtin "byte-array" "byte-arrays" create register-builtin -"tuple-layout" "classes.tuple.private" create register-builtin ! For predicate classes "predicate-instance?" "classes.predicate" create drop @@ -272,14 +271,6 @@ bi "callstack" "kernel" create { } define-builtin -"tuple-layout" "classes.tuple.private" create { - { "hashcode" { "fixnum" "math" } read-only } - { "class" { "word" "words" } initial: t read-only } - { "size" { "fixnum" "math" } read-only } - { "superclasses" { "array" "arrays" } initial: { } read-only } - { "echelon" { "fixnum" "math" } read-only } -} define-builtin - "tuple" "kernel" create [ { } define-builtin ] [ define-tuple-layout ] @@ -510,7 +501,6 @@ tuple { "array>quotation" "quotations.private" } { "quotation-xt" "quotations" } { "" "classes.tuple.private" } - { "" "classes.tuple.private" } { "profiling" "tools.profiler.private" } { "become" "kernel.private" } { "(sleep)" "threads.private" } diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index efa7c4b877..26a27ecefb 100644 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -49,4 +49,5 @@ load-help? off 1 exit ] if ] % -] [ ] make bootstrap-boot-quot set +] [ ] make +bootstrap-boot-quot set diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index e16be25ce4..4d2c537522 100644 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -348,7 +348,7 @@ $nl { $list { { $snippet "\"predicate\"" } " - a quotation which tests if the top of the stack is an instance of this tuple class" } { { $snippet "\"slots\"" } " - a sequence of " { $link slot-spec } " instances" } - { { $snippet "\"tuple-layout\"" } " - a " { $link tuple-layout } " instance" } + { { $snippet "\"tuple-layout\"" } " - an array with the tuple size and superclasses encoded in a format amneable to fast method dispatch" } } } ; HELP: define-tuple-predicate @@ -405,11 +405,11 @@ HELP: tuple>array ( tuple -- array ) { $description "Outputs an array having the tuple's slots as elements. The first element is the tuple class word and remainder are declared slots." } ; HELP: ( layout -- tuple ) -{ $values { "layout" tuple-layout } { "tuple" tuple } } +{ $values { "layout" "a tuple layout array" } { "tuple" tuple } } { $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link new } "." } ; HELP: ( ... layout -- tuple ) -{ $values { "..." "values" } { "layout" tuple-layout } { "tuple" tuple } } +{ $values { "..." "values" } { "layout" "a tuple layout array" } { "tuple" tuple } } { $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link boa } "." } ; HELP: new diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 5c91bdf8dd..dc078f5ac3 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -94,7 +94,7 @@ TUPLE: size-test a b c d ; [ t ] [ T{ size-test } tuple-size - size-test tuple-layout size>> = + size-test tuple-layout second = ] unit-test GENERIC: diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index ef2cf616be..e9c560bd90 100644 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -10,8 +10,6 @@ IN: classes.tuple PREDICATE: tuple-class < class "metaclass" word-prop tuple-class eq? ; -M: tuple class 1 slot 2 slot { word } declare ; - ERROR: not-a-tuple object ; : check-tuple ( object -- tuple ) @@ -29,10 +27,12 @@ PREDICATE: immutable-tuple-class < tuple-class ( class -- ? ) "layout" word-prop ; : layout-of ( tuple -- layout ) - 1 slot { tuple-layout } declare ; inline + 1 slot { array } declare ; inline + +M: tuple class layout-of 2 slot { word } declare ; : tuple-size ( tuple -- size ) - layout-of size>> ; inline + layout-of second ; inline : prepare-tuple>array ( tuple -- n tuple layout ) check-tuple [ tuple-size ] [ ] [ layout-of ] tri ; @@ -90,15 +90,19 @@ ERROR: bad-superclass class ; 2drop f ] if ; inline -: tuple-instance? ( object class echelon -- ? ) +: tuple-instance? ( object class offset -- ? ) #! 4 slot == superclasses>> rot dup tuple? [ - layout-of 4 slot { array } declare - 2dup 1 slot fixnum< [ array-nth eq? ] [ 3drop f ] if + 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 + ; + : define-tuple-predicate ( class -- ) - dup dup tuple-layout echelon>> + dup dup layout-class-offset [ tuple-instance? ] 2curry define-predicate ; : class-size ( class -- n ) @@ -145,10 +149,14 @@ ERROR: bad-superclass class ; define-accessors ; : make-tuple-layout ( class -- layout ) - [ ] - [ [ superclass class-size ] [ "slots" word-prop length ] bi + ] - [ superclasses dup length 1- ] tri - ; + [ + { + [ , ] + [ [ superclass class-size ] [ "slots" word-prop length ] bi + , ] + [ superclasses length 1- , ] + [ superclasses [ [ , ] [ hashcode , ] bi ] each ] + } cleave + ] { } make ; : define-tuple-layout ( class -- ) dup make-tuple-layout "layout" set-word-prop ; @@ -284,7 +292,7 @@ M: tuple-class reset-class M: tuple-class rank-class drop 0 ; M: tuple-class instance? - dup tuple-layout echelon>> tuple-instance? ; + dup 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 250ccef6cc..34447fb92d 100644 --- a/core/generic/standard/engines/tuple/tuple.factor +++ b/core/generic/standard/engines/tuple/tuple.factor @@ -7,18 +7,28 @@ classes.algebra math math.private kernel.private quotations arrays definitions ; IN: generic.standard.engines.tuple +: nth-superclass% ( n -- ) 2 * 5 + , \ slot , ; inline + +: nth-hashcode% ( n -- ) 2 * 6 + , \ slot , ; inline + +: tuple-layout% ( -- ) + [ { tuple } declare 1 slot { array } declare ] % ; inline + +: tuple-layout-echelon% ( -- ) + [ 4 slot ] % ; inline + TUPLE: echelon-dispatch-engine n methods ; C: echelon-dispatch-engine -TUPLE: trivial-tuple-dispatch-engine methods ; +TUPLE: trivial-tuple-dispatch-engine n methods ; C: trivial-tuple-dispatch-engine TUPLE: tuple-dispatch-engine echelons ; : push-echelon ( class method assoc -- ) - >r swap dup "layout" word-prop echelon>> r> + [ swap dup "layout" word-prop third ] dip [ ?set-at ] change-at ; : echelon-sort ( assoc -- assoc' ) @@ -38,19 +48,20 @@ TUPLE: tuple-dispatch-engine echelons ; \ convert-methods ; M: trivial-tuple-dispatch-engine engine>quot - methods>> engines>quots* linear-dispatch-quot ; + [ + [ n>> nth-superclass% ] + [ methods>> engines>quots* linear-dispatch-quot % ] bi + ] [ ] make ; -: hash-methods ( methods -- buckets ) +: hash-methods ( n methods -- buckets ) >alist V{ } clone [ hashcode 1array ] distribute-buckets - [ ] map ; + [ ] with map ; -: word-hashcode% ( -- ) [ 1 slot ] % ; - -: class-hash-dispatch-quot ( methods -- quot ) +: class-hash-dispatch-quot ( n methods -- quot ) [ \ dup , - word-hashcode% - hash-methods [ engine>quot ] map hash-dispatch-quot % + [ drop nth-hashcode% ] + [ hash-methods [ engine>quot ] map hash-dispatch-quot % ] 2bi ] [ ] make ; : engine-word-name ( -- string ) @@ -79,29 +90,16 @@ M: engine-word irrelevant? drop t ; dup generic get "tuple-dispatch-generic" set-word-prop ; : define-engine-word ( quot -- word ) - >r dup r> define ; - -: array-nth% ( n -- ) 2 + , [ slot { word } declare ] % ; - -: tuple-layout-superclasses% ( -- ) - [ - { tuple } declare - 1 slot { tuple-layout } declare - 4 slot { array } declare - ] % ; inline + [ dup ] dip define ; : tuple-dispatch-engine-body ( engine -- quot ) [ picker % - tuple-layout-superclasses% - [ n>> array-nth% ] - [ - methods>> [ - engine>quot - ] [ - class-hash-dispatch-quot - ] if-small? % - ] bi + tuple-layout% + [ n>> ] [ methods>> ] bi + [ engine>quot ] + [ class-hash-dispatch-quot ] + if-small? % ] [ ] make ; M: echelon-dispatch-engine engine>quot @@ -109,18 +107,7 @@ M: echelon-dispatch-engine engine>quot methods>> dup assoc-empty? [ drop default get ] [ values first engine>quot ] if ] [ - [ - picker % - tuple-layout-superclasses% - [ n>> array-nth% ] - [ - methods>> [ - engine>quot - ] [ - class-hash-dispatch-quot - ] if-small? % - ] bi - ] [ ] make + tuple-dispatch-engine-body ] if ; : >=-case-quot ( default alist -- quot ) @@ -132,13 +119,6 @@ M: echelon-dispatch-engine engine>quot ] assoc-map alist>quot ; -: tuple-layout-echelon-quot ( -- quot ) - [ - { tuple } declare - 1 slot { tuple-layout } declare - 5 slot - ] ; 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 @@ -147,7 +127,8 @@ M: echelon-dispatch-engine engine>quot [ [ picker % - tuple-layout-echelon-quot % + tuple-layout% + tuple-layout-echelon% >=-case-quot % ] [ ] make ] unless-empty ; diff --git a/vm/data_gc.c b/vm/data_gc.c index 2e05395d19..9aa4f88de6 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -244,8 +244,6 @@ CELL unaligned_object_size(CELL pointer) case CALLSTACK_TYPE: return callstack_size( untag_fixnum_fast(((F_CALLSTACK *)pointer)->length)); - case TUPLE_LAYOUT_TYPE: - return sizeof(F_TUPLE_LAYOUT); default: critical_error("Invalid header",pointer); return -1; /* can't happen */ diff --git a/vm/debug.c b/vm/debug.c index 0869d6a885..2550931c72 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -1,5 +1,7 @@ #include "master.h" +static bool full_output; + void print_chars(F_STRING* str) { CELL i; @@ -39,7 +41,7 @@ void print_array(F_ARRAY* array, CELL nesting) CELL i; bool trimmed; - if(length > 10) + if(length > 10 && !full_output) { trimmed = true; length = 10; @@ -68,7 +70,7 @@ void print_tuple(F_TUPLE* tuple, CELL nesting) CELL i; bool trimmed; - if(length > 10) + if(length > 10 && !full_output) { trimmed = true; length = 10; @@ -88,7 +90,7 @@ void print_tuple(F_TUPLE* tuple, CELL nesting) void print_nested_obj(CELL obj, F_FIXNUM nesting) { - if(nesting <= 0) + if(nesting <= 0 && !full_output) { printf(" ... "); return; @@ -342,6 +344,7 @@ void factorbug(void) printf("d -- dump memory\n"); printf("u -- dump object at tagged \n"); printf(". -- print object at tagged \n"); + printf("t -- toggle output trimming\n"); printf("s r -- dump data, retain stacks\n"); printf(".s .r .c -- print data, retain, call stacks\n"); printf("e -- dump environment\n"); @@ -404,6 +407,8 @@ void factorbug(void) print_obj(addr); printf("\n"); } + else if(strcmp(cmd,"t") == 0) + full_output = !full_output; else if(strcmp(cmd,"s") == 0) dump_memory(ds_bot,ds); else if(strcmp(cmd,"r") == 0) diff --git a/vm/layouts.h b/vm/layouts.h index 7ebfe50dd4..6dc29efdae 100755 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -52,13 +52,12 @@ typedef signed long long s64; #define BYTE_ARRAY_TYPE 10 #define CALLSTACK_TYPE 11 #define STRING_TYPE 12 -#define TUPLE_LAYOUT_TYPE 13 +#define WORD_TYPE 13 #define QUOTATION_TYPE 14 #define DLL_TYPE 15 #define ALIEN_TYPE 16 -#define WORD_TYPE 17 -#define TYPE_COUNT 20 +#define TYPE_COUNT 17 INLINE bool immediate_p(CELL obj) { @@ -154,7 +153,8 @@ typedef struct { /* Assembly code makes assumptions about the layout of this struct */ typedef struct { -/* C sucks. */ +/* We use a union here to force the float value to be aligned on an +8-byte boundary. */ union { CELL header; long long padding; @@ -222,17 +222,17 @@ typedef struct CELL size; } F_STACK_FRAME; +/* These are really just arrays, but certain elements have special +significance */ typedef struct { CELL header; - /* tagged fixnum */ - CELL hashcode; + /* tagged */ + CELL capacity; /* tagged */ CELL class; /* tagged fixnum */ CELL size; - /* tagged array */ - CELL superclasses; /* tagged fixnum */ CELL echelon; } F_TUPLE_LAYOUT; diff --git a/vm/primitives.c b/vm/primitives.c index 84cad12326..69e77f81ed 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -127,7 +127,6 @@ void *primitives[] = { primitive_array_to_quotation, primitive_quotation_xt, primitive_tuple, - primitive_tuple_layout, primitive_profiling, primitive_become, primitive_sleep, diff --git a/vm/types.c b/vm/types.c index ccc7cbdba3..5e2ed4bed9 100755 --- a/vm/types.c +++ b/vm/types.c @@ -298,18 +298,6 @@ F_BYTE_ARRAY *growable_byte_array_append(F_BYTE_ARRAY *result, void *elts, CELL return result; } -/* Tuple layouts */ -DEFINE_PRIMITIVE(tuple_layout) -{ - F_TUPLE_LAYOUT *layout = allot_object(TUPLE_LAYOUT_TYPE,sizeof(F_TUPLE_LAYOUT)); - layout->echelon = dpop(); - layout->superclasses = dpop(); - layout->size = dpop(); - layout->class = dpop(); - layout->hashcode = untag_word(layout->class)->hashcode; - dpush(tag_object(layout)); -} - /* Tuples */ /* push a new tuple on the stack */ @@ -325,7 +313,7 @@ F_TUPLE *allot_tuple(F_TUPLE_LAYOUT *layout) DEFINE_PRIMITIVE(tuple) { F_TUPLE_LAYOUT *layout = untag_object(dpop()); - F_FIXNUM size = to_fixnum(layout->size); + F_FIXNUM size = untag_fixnum_fast(layout->size); F_TUPLE *tuple = allot_tuple(layout); F_FIXNUM i; @@ -339,7 +327,7 @@ DEFINE_PRIMITIVE(tuple) DEFINE_PRIMITIVE(tuple_boa) { F_TUPLE_LAYOUT *layout = untag_object(dpop()); - F_FIXNUM size = to_fixnum(layout->size); + F_FIXNUM size = untag_fixnum_fast(layout->size); REGISTER_UNTAGGED(layout); F_TUPLE *tuple = allot_tuple(layout);