steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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.
db4
Slava Pestov 2008-11-05 22:20:29 -06:00
parent 4e98751ce0
commit cc879fa9b7
20 changed files with 85 additions and 137 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
basis/bootstrap/image/image.factor
View File

@ -368,21 +368,6 @@ M: byte-array '
M: tuple ' emit-tuple ; 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 ' M: tombstone '
state>> "((tombstone))" "((empty))" ? state>> "((tombstone))" "((empty))" ?
"hashtables.private" lookup def>> first "hashtables.private" lookup def>> first

6
basis/compiler/cfg/intrinsics/allot/allot.factor
View File

@ -16,14 +16,14 @@ IN: compiler.cfg.intrinsics.allot
[ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi ; [ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi ;
: tuple-slot-regs ( layout -- vregs ) : tuple-slot-regs ( layout -- vregs )
[ size>> ds-load ] [ ^^load-literal ] bi prefix ; [ second ds-load ] [ ^^load-literal ] bi prefix ;
: emit-<tuple-boa> ( node -- ) : emit-<tuple-boa> ( node -- )
dup node-input-infos peek literal>> dup node-input-infos peek literal>>
dup tuple-layout? [ dup array? [
nip nip
ds-drop ds-drop
[ tuple-slot-regs ] [ size>> ^^allot-tuple ] bi [ tuple-slot-regs ] [ second ^^allot-tuple ] bi
[ tuple ##set-slots ] [ ds-push drop ] 2bi [ tuple ##set-slots ] [ ds-push drop ] 2bi
] [ drop emit-primitive ] if ; ] [ drop emit-primitive ] if ;

2
basis/compiler/tree/propagation/info/info.factor
View File

@ -307,5 +307,5 @@ SYMBOL: value-infos
: immutable-tuple-boa? ( #call -- ? ) : immutable-tuple-boa? ( #call -- ? )
dup word>> \ <tuple-boa> eq? [ dup word>> \ <tuple-boa> eq? [
dup in-d>> peek node-value-info dup in-d>> peek node-value-info
literal>> class>> immutable-tuple-class? literal>> first immutable-tuple-class?
] [ drop f ] if ; ] [ drop f ] if ;

2
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -281,7 +281,7 @@ generic-comparison-ops [
{ <tuple> <tuple-boa> } [ { <tuple> <tuple-boa> } [
[ [
literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if <class-info> literal>> dup array? [ first ] [ drop tuple ] if <class-info>
[ clear ] dip [ clear ] dip
] "outputs" set-word-prop ] "outputs" set-word-prop
] each ] each

2
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -379,7 +379,7 @@ TUPLE: mutable-tuple-test { x sequence } ;
[ T{ mutable-tuple-test f "hey" } x>> ] final-classes [ T{ mutable-tuple-test f "hey" } x>> ] final-classes
] unit-test ] unit-test
[ V{ tuple-layout } ] [ [ V{ array } ] [
[ T{ mutable-tuple-test f "hey" } layout-of ] final-classes [ T{ mutable-tuple-test f "hey" } layout-of ] final-classes
] unit-test ] unit-test

2
basis/compiler/tree/propagation/slots/slots.factor
View File

@ -45,7 +45,7 @@ UNION: fixed-length-sequence array byte-array string ;
: propagate-<tuple-boa> ( #call -- info ) : propagate-<tuple-boa> ( #call -- info )
in-d>> unclip-last in-d>> unclip-last
value-info literal>> class>> (propagate-tuple-constructor) ; value-info literal>> first (propagate-tuple-constructor) ;
: propagate-<complex> ( #call -- info ) : propagate-<complex> ( #call -- info )
in-d>> [ value-info ] map complex <tuple-info> ; in-d>> [ value-info ] map complex <tuple-info> ;

3
basis/prettyprint/backend/backend.factor
View File

@ -233,6 +233,3 @@ M: wrapper pprint*
] [ ] [
pprint-object pprint-object
] if ; ] if ;
M: tuple-layout pprint*
"( tuple layout )" swap present-text ;

5
basis/stack-checker/known-words/known-words.factor
View File

@ -108,7 +108,7 @@ M: object infer-call*
: infer-<tuple-boa> ( -- ) : infer-<tuple-boa> ( -- )
\ <tuple-boa> \ <tuple-boa>
peek-d literal value>> size>> 1+ { tuple } <effect> peek-d literal value>> second 1+ { tuple } <effect>
apply-word/effect ; apply-word/effect ;
: infer-(throw) ( -- ) : infer-(throw) ( -- )
@ -561,9 +561,6 @@ do-primitive alien-invoke alien-indirect alien-callback
\ <tuple> { tuple-layout } { tuple } define-primitive \ <tuple> { tuple-layout } { tuple } define-primitive
\ <tuple> make-flushable \ <tuple> make-flushable
\ <tuple-layout> { word fixnum array fixnum } { tuple-layout } define-primitive
\ <tuple-layout> make-foldable
\ datastack { } { array } define-primitive \ datastack { } { array } define-primitive
\ datastack make-flushable \ datastack make-flushable

5
core/bootstrap/layouts/layouts.factor
View File

@ -9,7 +9,7 @@ BIN: 111 tag-mask set
8 num-tags set 8 num-tags set
3 tag-bits set 3 tag-bits set
18 num-types set 17 num-types set
H{ H{
{ fixnum BIN: 000 } { fixnum BIN: 000 }
@ -29,9 +29,8 @@ tag-numbers get H{
{ byte-array 10 } { byte-array 10 }
{ callstack 11 } { callstack 11 }
{ string 12 } { string 12 }
{ tuple-layout 13 } { word 13 }
{ quotation 14 } { quotation 14 }
{ dll 15 } { dll 15 }
{ alien 16 } { alien 16 }
{ word 17 }
} assoc-union type-numbers set } assoc-union type-numbers set

10
core/bootstrap/primitives.factor
View File

@ -147,7 +147,6 @@ bootstrapping? on
"alien" "alien" create register-builtin "alien" "alien" create register-builtin
"word" "words" create register-builtin "word" "words" create register-builtin
"byte-array" "byte-arrays" create register-builtin "byte-array" "byte-arrays" create register-builtin
"tuple-layout" "classes.tuple.private" create register-builtin
! For predicate classes ! For predicate classes
"predicate-instance?" "classes.predicate" create drop "predicate-instance?" "classes.predicate" create drop
@ -272,14 +271,6 @@ bi
"callstack" "kernel" create { } define-builtin "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 "tuple" "kernel" create
[ { } define-builtin ] [ { } define-builtin ]
[ define-tuple-layout ] [ define-tuple-layout ]
@ -510,7 +501,6 @@ tuple
{ "array>quotation" "quotations.private" } { "array>quotation" "quotations.private" }
{ "quotation-xt" "quotations" } { "quotation-xt" "quotations" }
{ "<tuple>" "classes.tuple.private" } { "<tuple>" "classes.tuple.private" }
{ "<tuple-layout>" "classes.tuple.private" }
{ "profiling" "tools.profiler.private" } { "profiling" "tools.profiler.private" }
{ "become" "kernel.private" } { "become" "kernel.private" }
{ "(sleep)" "threads.private" } { "(sleep)" "threads.private" }

3
core/bootstrap/stage1.factor
View File

@ -49,4 +49,5 @@ load-help? off
1 exit 1 exit
] if ] if
] % ] %
] [ ] make bootstrap-boot-quot set ] [ ] make
bootstrap-boot-quot set

6
core/classes/tuple/tuple-docs.factor
View File

@ -348,7 +348,7 @@ $nl
{ $list { $list
{ { $snippet "\"predicate\"" } " - a quotation which tests if the top of the stack is an instance of this tuple class" } { { $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 "\"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 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." } ; { $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: <tuple> ( layout -- tuple ) HELP: <tuple> ( 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 } "." } ; { $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link new } "." } ;
HELP: <tuple-boa> ( ... layout -- tuple ) HELP: <tuple-boa> ( ... 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 } "." } ; { $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link boa } "." } ;
HELP: new HELP: new

2
core/classes/tuple/tuple-tests.factor
View File

@ -94,7 +94,7 @@ TUPLE: size-test a b c d ;
[ t ] [ [ t ] [
T{ size-test } tuple-size T{ size-test } tuple-size
size-test tuple-layout size>> = size-test tuple-layout second =
] unit-test ] unit-test
GENERIC: <yo-momma> GENERIC: <yo-momma>

34
core/classes/tuple/tuple.factor
View File

@ -10,8 +10,6 @@ IN: classes.tuple
PREDICATE: tuple-class < class PREDICATE: tuple-class < class
"metaclass" word-prop tuple-class eq? ; "metaclass" word-prop tuple-class eq? ;
M: tuple class 1 slot 2 slot { word } declare ;
ERROR: not-a-tuple object ; ERROR: not-a-tuple object ;
: check-tuple ( object -- tuple ) : check-tuple ( object -- tuple )
@ -29,10 +27,12 @@ PREDICATE: immutable-tuple-class < tuple-class ( class -- ? )
"layout" word-prop ; "layout" word-prop ;
: layout-of ( tuple -- layout ) : 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 ) : tuple-size ( tuple -- size )
layout-of size>> ; inline layout-of second ; inline
: prepare-tuple>array ( tuple -- n tuple layout ) : prepare-tuple>array ( tuple -- n tuple layout )
check-tuple [ tuple-size ] [ ] [ layout-of ] tri ; check-tuple [ tuple-size ] [ ] [ layout-of ] tri ;
@ -90,15 +90,19 @@ ERROR: bad-superclass class ;
2drop f 2drop f
] if ; inline ] if ; inline
: tuple-instance? ( object class echelon -- ? ) : tuple-instance? ( object class offset -- ? )
#! 4 slot == superclasses>> #! 4 slot == superclasses>>
rot dup tuple? [ rot dup tuple? [
layout-of 4 slot { array } declare layout-of
2dup 1 slot fixnum< [ array-nth eq? ] [ 3drop f ] if 2dup 1 slot fixnum<=
[ swap slot eq? ] [ 3drop f ] if
] [ 3drop f ] if ; inline ] [ 3drop f ] if ; inline
: layout-class-offset ( class -- n )
tuple-layout third 2 * 5 + ;
: define-tuple-predicate ( class -- ) : define-tuple-predicate ( class -- )
dup dup tuple-layout echelon>> dup dup layout-class-offset
[ tuple-instance? ] 2curry define-predicate ; [ tuple-instance? ] 2curry define-predicate ;
: class-size ( class -- n ) : class-size ( class -- n )
@ -145,10 +149,14 @@ ERROR: bad-superclass class ;
define-accessors ; define-accessors ;
: make-tuple-layout ( class -- layout ) : make-tuple-layout ( class -- layout )
[ ] [
[ [ superclass class-size ] [ "slots" word-prop length ] bi + ] {
[ superclasses dup length 1- ] tri [ , ]
<tuple-layout> ; [ [ superclass class-size ] [ "slots" word-prop length ] bi + , ]
[ superclasses length 1- , ]
[ superclasses [ [ , ] [ hashcode , ] bi ] each ]
} cleave
] { } make ;
: define-tuple-layout ( class -- ) : define-tuple-layout ( class -- )
dup make-tuple-layout "layout" set-word-prop ; 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 rank-class drop 0 ;
M: tuple-class instance? M: tuple-class instance?
dup tuple-layout echelon>> tuple-instance? ; dup layout-class-offset tuple-instance? ;
M: tuple-class (flatten-class) dup set ; M: tuple-class (flatten-class) dup set ;

79
core/generic/standard/engines/tuple/tuple.factor
View File

@ -7,18 +7,28 @@ classes.algebra math math.private kernel.private
quotations arrays definitions ; quotations arrays definitions ;
IN: generic.standard.engines.tuple 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 ; TUPLE: echelon-dispatch-engine n methods ;
C: <echelon-dispatch-engine> echelon-dispatch-engine C: <echelon-dispatch-engine> echelon-dispatch-engine
TUPLE: trivial-tuple-dispatch-engine methods ; TUPLE: trivial-tuple-dispatch-engine n methods ;
C: <trivial-tuple-dispatch-engine> trivial-tuple-dispatch-engine C: <trivial-tuple-dispatch-engine> trivial-tuple-dispatch-engine
TUPLE: tuple-dispatch-engine echelons ; TUPLE: tuple-dispatch-engine echelons ;
: push-echelon ( class method assoc -- ) : push-echelon ( class method assoc -- )
>r swap dup "layout" word-prop echelon>> r> [ swap dup "layout" word-prop third ] dip
[ ?set-at ] change-at ; [ ?set-at ] change-at ;
: echelon-sort ( assoc -- assoc' ) : echelon-sort ( assoc -- assoc' )
@ -38,19 +48,20 @@ TUPLE: tuple-dispatch-engine echelons ;
\ <tuple-dispatch-engine> convert-methods ; \ <tuple-dispatch-engine> convert-methods ;
M: trivial-tuple-dispatch-engine engine>quot 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 >alist V{ } clone [ hashcode 1array ] distribute-buckets
[ <trivial-tuple-dispatch-engine> ] map ; [ <trivial-tuple-dispatch-engine> ] with map ;
: word-hashcode% ( -- ) [ 1 slot ] % ; : class-hash-dispatch-quot ( n methods -- quot )
: class-hash-dispatch-quot ( methods -- quot )
[ [
\ dup , \ dup ,
word-hashcode% [ drop nth-hashcode% ]
hash-methods [ engine>quot ] map hash-dispatch-quot % [ hash-methods [ engine>quot ] map hash-dispatch-quot % ] 2bi
] [ ] make ; ] [ ] make ;
: engine-word-name ( -- string ) : engine-word-name ( -- string )
@ -79,29 +90,16 @@ M: engine-word irrelevant? drop t ;
dup generic get "tuple-dispatch-generic" set-word-prop ; dup generic get "tuple-dispatch-generic" set-word-prop ;
: define-engine-word ( quot -- word ) : define-engine-word ( quot -- word )
>r <engine-word> dup r> define ; [ <engine-word> dup ] dip define ;
: array-nth% ( n -- ) 2 + , [ slot { word } declare ] % ;
: tuple-layout-superclasses% ( -- )
[
{ tuple } declare
1 slot { tuple-layout } declare
4 slot { array } declare
] % ; inline
: tuple-dispatch-engine-body ( engine -- quot ) : tuple-dispatch-engine-body ( engine -- quot )
[ [
picker % picker %
tuple-layout-superclasses% tuple-layout%
[ n>> array-nth% ] [ n>> ] [ methods>> ] bi
[ [ <trivial-tuple-dispatch-engine> engine>quot ]
methods>> [ [ class-hash-dispatch-quot ]
<trivial-tuple-dispatch-engine> engine>quot if-small? %
] [
class-hash-dispatch-quot
] if-small? %
] bi
] [ ] make ; ] [ ] make ;
M: echelon-dispatch-engine engine>quot M: echelon-dispatch-engine engine>quot
@ -109,18 +107,7 @@ M: echelon-dispatch-engine engine>quot
methods>> dup assoc-empty? methods>> dup assoc-empty?
[ drop default get ] [ values first engine>quot ] if [ drop default get ] [ values first engine>quot ] if
] [ ] [
[ tuple-dispatch-engine-body
picker %
tuple-layout-superclasses%
[ n>> array-nth% ]
[
methods>> [
<trivial-tuple-dispatch-engine> engine>quot
] [
class-hash-dispatch-quot
] if-small? %
] bi
] [ ] make
] if ; ] if ;
: >=-case-quot ( default alist -- quot ) : >=-case-quot ( default alist -- quot )
@ -132,13 +119,6 @@ M: echelon-dispatch-engine engine>quot
] assoc-map ] assoc-map
alist>quot ; alist>quot ;
: tuple-layout-echelon-quot ( -- quot )
[
{ tuple } declare
1 slot { tuple-layout } declare
5 slot
] ; inline
: echelon-case-quot ( alist -- quot ) : echelon-case-quot ( alist -- quot )
#! We don't have to test for echelon 1 since all tuple #! We don't have to test for echelon 1 since all tuple
#! classes are at least at depth 1 in the inheritance #! classes are at least at depth 1 in the inheritance
@ -147,7 +127,8 @@ M: echelon-dispatch-engine engine>quot
[ [
[ [
picker % picker %
tuple-layout-echelon-quot % tuple-layout%
tuple-layout-echelon%
>=-case-quot % >=-case-quot %
] [ ] make ] [ ] make
] unless-empty ; ] unless-empty ;

2
vm/data_gc.c
View File

@ -244,8 +244,6 @@ CELL unaligned_object_size(CELL pointer)
case CALLSTACK_TYPE: case CALLSTACK_TYPE:
return callstack_size( return callstack_size(
untag_fixnum_fast(((F_CALLSTACK *)pointer)->length)); untag_fixnum_fast(((F_CALLSTACK *)pointer)->length));
case TUPLE_LAYOUT_TYPE:
return sizeof(F_TUPLE_LAYOUT);
default: default:
critical_error("Invalid header",pointer); critical_error("Invalid header",pointer);
return -1; /* can't happen */ return -1; /* can't happen */

11
vm/debug.c
View File

@ -1,5 +1,7 @@
#include "master.h" #include "master.h"
static bool full_output;
void print_chars(F_STRING* str) void print_chars(F_STRING* str)
{ {
CELL i; CELL i;
@ -39,7 +41,7 @@ void print_array(F_ARRAY* array, CELL nesting)
CELL i; CELL i;
bool trimmed; bool trimmed;
if(length > 10) if(length > 10 && !full_output)
{ {
trimmed = true; trimmed = true;
length = 10; length = 10;
@ -68,7 +70,7 @@ void print_tuple(F_TUPLE* tuple, CELL nesting)
CELL i; CELL i;
bool trimmed; bool trimmed;
if(length > 10) if(length > 10 && !full_output)
{ {
trimmed = true; trimmed = true;
length = 10; length = 10;
@ -88,7 +90,7 @@ void print_tuple(F_TUPLE* tuple, CELL nesting)
void print_nested_obj(CELL obj, F_FIXNUM nesting) void print_nested_obj(CELL obj, F_FIXNUM nesting)
{ {
if(nesting <= 0) if(nesting <= 0 && !full_output)
{ {
printf(" ... "); printf(" ... ");
return; return;
@ -342,6 +344,7 @@ void factorbug(void)
printf("d <addr> <count> -- dump memory\n"); printf("d <addr> <count> -- dump memory\n");
printf("u <addr> -- dump object at tagged <addr>\n"); printf("u <addr> -- dump object at tagged <addr>\n");
printf(". <addr> -- print object at tagged <addr>\n"); printf(". <addr> -- print object at tagged <addr>\n");
printf("t -- toggle output trimming\n");
printf("s r -- dump data, retain stacks\n"); printf("s r -- dump data, retain stacks\n");
printf(".s .r .c -- print data, retain, call stacks\n"); printf(".s .r .c -- print data, retain, call stacks\n");
printf("e -- dump environment\n"); printf("e -- dump environment\n");
@ -404,6 +407,8 @@ void factorbug(void)
print_obj(addr); print_obj(addr);
printf("\n"); printf("\n");
} }
else if(strcmp(cmd,"t") == 0)
full_output = !full_output;
else if(strcmp(cmd,"s") == 0) else if(strcmp(cmd,"s") == 0)
dump_memory(ds_bot,ds); dump_memory(ds_bot,ds);
else if(strcmp(cmd,"r") == 0) else if(strcmp(cmd,"r") == 0)

16
vm/layouts.h
View File

@ -52,13 +52,12 @@ typedef signed long long s64;
#define BYTE_ARRAY_TYPE 10 #define BYTE_ARRAY_TYPE 10
#define CALLSTACK_TYPE 11 #define CALLSTACK_TYPE 11
#define STRING_TYPE 12 #define STRING_TYPE 12
#define TUPLE_LAYOUT_TYPE 13 #define WORD_TYPE 13
#define QUOTATION_TYPE 14 #define QUOTATION_TYPE 14
#define DLL_TYPE 15 #define DLL_TYPE 15
#define ALIEN_TYPE 16 #define ALIEN_TYPE 16
#define WORD_TYPE 17
#define TYPE_COUNT 20 #define TYPE_COUNT 17
INLINE bool immediate_p(CELL obj) INLINE bool immediate_p(CELL obj)
{ {
@ -154,7 +153,8 @@ typedef struct {
/* Assembly code makes assumptions about the layout of this struct */ /* Assembly code makes assumptions about the layout of this struct */
typedef struct { typedef struct {
/* C sucks. */ /* We use a union here to force the float value to be aligned on an
8-byte boundary. */
union { union {
CELL header; CELL header;
long long padding; long long padding;
@ -222,17 +222,17 @@ typedef struct
CELL size; CELL size;
} F_STACK_FRAME; } F_STACK_FRAME;
/* These are really just arrays, but certain elements have special
significance */
typedef struct typedef struct
{ {
CELL header; CELL header;
/* tagged fixnum */ /* tagged */
CELL hashcode; CELL capacity;
/* tagged */ /* tagged */
CELL class; CELL class;
/* tagged fixnum */ /* tagged fixnum */
CELL size; CELL size;
/* tagged array */
CELL superclasses;
/* tagged fixnum */ /* tagged fixnum */
CELL echelon; CELL echelon;
} F_TUPLE_LAYOUT; } F_TUPLE_LAYOUT;

1
vm/primitives.c
View File

@ -127,7 +127,6 @@ void *primitives[] = {
primitive_array_to_quotation, primitive_array_to_quotation,
primitive_quotation_xt, primitive_quotation_xt,
primitive_tuple, primitive_tuple,
primitive_tuple_layout,
primitive_profiling, primitive_profiling,
primitive_become, primitive_become,
primitive_sleep, primitive_sleep,

16
vm/types.c
View File

@ -298,18 +298,6 @@ F_BYTE_ARRAY *growable_byte_array_append(F_BYTE_ARRAY *result, void *elts, CELL
return result; 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 */ /* Tuples */
/* push a new tuple on the stack */ /* push a new tuple on the stack */
@ -325,7 +313,7 @@ F_TUPLE *allot_tuple(F_TUPLE_LAYOUT *layout)
DEFINE_PRIMITIVE(tuple) DEFINE_PRIMITIVE(tuple)
{ {
F_TUPLE_LAYOUT *layout = untag_object(dpop()); 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_TUPLE *tuple = allot_tuple(layout);
F_FIXNUM i; F_FIXNUM i;
@ -339,7 +327,7 @@ DEFINE_PRIMITIVE(tuple)
DEFINE_PRIMITIVE(tuple_boa) DEFINE_PRIMITIVE(tuple_boa)
{ {
F_TUPLE_LAYOUT *layout = untag_object(dpop()); 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); REGISTER_UNTAGGED(layout);
F_TUPLE *tuple = allot_tuple(layout); F_TUPLE *tuple = allot_tuple(layout);