Remove delegation slot

db4
Slava Pestov 2008-09-03 03:46:56 -05:00
parent 5ae4165570
commit e1716d92b3
15 changed files with 37 additions and 44 deletions

View File

@ -23,9 +23,8 @@ DEFER: record-literal-allocation
[ <slot-value> [ swap record-literal-allocation ] keep ] map ; [ <slot-value> [ swap record-literal-allocation ] keep ] map ;
: object-slots ( object -- slots/f ) : object-slots ( object -- slots/f )
#! Delegation
{ {
{ [ dup class immutable-tuple-class? ] [ tuple-slots rest-slice ] } { [ dup class immutable-tuple-class? ] [ tuple-slots ] }
{ [ dup complex? ] [ [ real-part ] [ imaginary-part ] bi 2array ] } { [ dup complex? ] [ [ real-part ] [ imaginary-part ] bi 2array ] }
[ drop f ] [ drop f ]
} cond ; } cond ;
@ -37,7 +36,6 @@ DEFER: record-literal-allocation
if* ; if* ;
M: #push escape-analysis* M: #push escape-analysis*
#! Delegation.
[ out-d>> first ] [ literal>> ] bi record-literal-allocation ; [ out-d>> first ] [ literal>> ] bi record-literal-allocation ;
: record-unknown-allocation ( #call -- ) : record-unknown-allocation ( #call -- )
@ -59,7 +57,7 @@ M: #push escape-analysis*
[ second node-value-info literal>> ] 2bi [ second node-value-info literal>> ] 2bi
dup fixnum? [ dup fixnum? [
{ {
{ [ over tuple class<= ] [ 3 - ] } { [ over tuple class<= ] [ 2 - ] }
{ [ over complex class<= ] [ 1 - ] } { [ over complex class<= ] [ 1 - ] }
[ drop f ] [ drop f ]
} cond nip } cond nip

View File

@ -67,15 +67,14 @@ MEMO: builtin-predicate-expansion ( word -- nodes )
MEMO: (tuple-boa-expansion) ( n -- quot ) MEMO: (tuple-boa-expansion) ( n -- quot )
[ [
1- [ 3 + ] map <reversed> [ 2 + ] map <reversed>
[ '[ [ , set-slot ] keep ] % ] each [ '[ [ , set-slot ] keep ] % ] each
[ f over 2 set-slot ] %
] [ ] make ; ] [ ] make ;
: tuple-boa-expansion ( layout -- quot ) : tuple-boa-expansion ( layout -- quot )
#! No memoization here since otherwise we'd hang on to #! No memoization here since otherwise we'd hang on to
#! tuple layout objects. #! tuple layout objects.
[ \ (tuple) , size>> (tuple-boa-expansion) % ] [ ] make splice-quot ; size>> (tuple-boa-expansion) \ (tuple) prefix splice-quot ;
: expand-tuple-boa ( #call -- node ) : expand-tuple-boa ( #call -- node )
last-literal tuple-boa-expansion ; last-literal tuple-boa-expansion ;

View File

@ -60,15 +60,13 @@ slots ;
: <value-info> ( -- info ) \ value-info new ; : <value-info> ( -- info ) \ value-info new ;
: read-only-slots ( values class -- slots ) : read-only-slots ( values class -- slots )
#! Delegation. all-slots
all-slots rest-slice
[ read-only>> [ drop f ] unless ] 2map [ read-only>> [ drop f ] unless ] 2map
{ f f } prepend ; f prefix ;
DEFER: <literal-info> DEFER: <literal-info>
: init-literal-info ( info -- info ) : init-literal-info ( info -- info )
#! Delegation.
dup literal>> class >>class dup literal>> class >>class
dup literal>> dup real? [ [a,a] >>interval ] [ dup literal>> dup real? [ [a,a] >>interval ] [
[ [-inf,inf] >>interval ] dip [ [-inf,inf] >>interval ] dip
@ -79,10 +77,8 @@ DEFER: <literal-info>
2array >>slots 2array >>slots
] } ] }
{ [ dup tuple? ] [ { [ dup tuple? ] [
[ [ tuple-slots [ <literal-info> ] map ] [ class ] bi
tuple-slots rest-slice read-only-slots >>slots
[ <literal-info> ] map
] [ class ] bi read-only-slots >>slots
] } ] }
[ drop ] [ drop ]
} cond } cond

View File

@ -32,19 +32,18 @@ UNION: fixed-length-sequence array byte-array string ;
{ <tuple-boa> <complex> } memq? ; { <tuple-boa> <complex> } memq? ;
: fold-<tuple-boa> ( values class -- info ) : fold-<tuple-boa> ( values class -- info )
[ , f , [ literal>> ] map % ] { } make >tuple [ [ literal>> ] map ] dip prefix >tuple
<literal-info> ; <literal-info> ;
: (propagate-tuple-constructor) ( values class -- info ) : (propagate-tuple-constructor) ( values class -- info )
[ [ value-info ] map ] dip [ read-only-slots ] keep [ [ value-info ] map ] dip [ read-only-slots ] keep
over 2 tail-slice [ dup [ literal?>> ] when ] all? [ over rest-slice [ dup [ literal?>> ] when ] all? [
[ 2 tail-slice ] dip fold-<tuple-boa> [ rest-slice ] dip fold-<tuple-boa>
] [ ] [
<tuple-info> <tuple-info>
] if ; ] if ;
: propagate-<tuple-boa> ( #call -- info ) : propagate-<tuple-boa> ( #call -- info )
#! Delegation
in-d>> unclip-last in-d>> unclip-last
value-info literal>> class>> (propagate-tuple-constructor) ; value-info literal>> class>> (propagate-tuple-constructor) ;
@ -69,7 +68,6 @@ UNION: fixed-length-sequence array byte-array string ;
[ 1 = ] [ length>> ] bi* and ; [ 1 = ] [ length>> ] bi* and ;
: value-info-slot ( slot info -- info' ) : value-info-slot ( slot info -- info' )
#! Delegation.
{ {
{ [ over 0 = ] [ 2drop fixnum <class-info> ] } { [ over 0 = ] [ 2drop fixnum <class-info> ] }
{ [ 2dup length-accessor? ] [ nip length>> ] } { [ 2dup length-accessor? ] [ nip length>> ] }

View File

@ -30,7 +30,7 @@ TUPLE: empty-tuple ;
[ dup cons boa 10 [ nip dup cons boa ] each-integer car>> ] [ dup cons boa 10 [ nip dup cons boa ] each-integer car>> ]
[ 2 cons boa { [ ] [ ] } dispatch ] [ 2 cons boa { [ ] [ ] } dispatch ]
[ dup [ drop f ] [ "A" throw ] if ] [ dup [ drop f ] [ "A" throw ] if ]
[ [ ] [ ] curry curry dup 3 slot swap 4 slot dup 3 slot swap 4 slot drop ] [ [ ] [ ] curry curry dup 2 slot swap 3 slot dup 2 slot swap 3 slot drop ]
[ [ ] [ ] curry curry call ] [ [ ] [ ] curry curry call ]
[ <complex> <complex> dup 1 slot drop 2 slot drop ] [ <complex> <complex> dup 1 slot drop 2 slot drop ]
[ 1 cons boa over [ "A" throw ] when car>> ] [ 1 cons boa over [ "A" throw ] when car>> ]

View File

@ -163,10 +163,12 @@ M: byte-vector >pprint-sequence ;
M: curry >pprint-sequence ; M: curry >pprint-sequence ;
M: compose >pprint-sequence ; M: compose >pprint-sequence ;
M: hashtable >pprint-sequence >alist ; M: hashtable >pprint-sequence >alist ;
M: tuple >pprint-sequence tuple>array ;
M: wrapper >pprint-sequence wrapped>> 1array ; M: wrapper >pprint-sequence wrapped>> 1array ;
M: callstack >pprint-sequence callstack>array ; M: callstack >pprint-sequence callstack>array ;
M: tuple >pprint-sequence
[ class f 2array ] [ tuple-slots ] bi append ;
GENERIC: pprint-narrow? ( obj -- ? ) GENERIC: pprint-narrow? ( obj -- ? )
M: object pprint-narrow? drop f ; M: object pprint-narrow? drop f ;

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>> { tuple } <effect> peek-d literal value>> size>> 1+ { tuple } <effect>
apply-word/effect ; apply-word/effect ;
: infer-(throw) ( -- ) : infer-(throw) ( -- )

View File

@ -105,8 +105,11 @@ IN: stack-checker.transforms
\ new [ \ new [
dup tuple-class? [ dup tuple-class? [
dup inlined-dependency depends-on dup inlined-dependency depends-on
dup all-slots rest-slice ! delegate slot [
[ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make [ all-slots [ initial>> literalize , ] each ]
[ literalize , ] bi
\ boa ,
] [ ] make
] [ drop f ] if ] [ drop f ] if
] 1 define-transform ] 1 define-transform

View File

@ -281,18 +281,12 @@ bi
"tuple" "kernel" create "tuple" "kernel" create
[ { } define-builtin ] [ { } define-builtin ]
[ define-tuple-layout ] [ define-tuple-layout ]
[ bi
{ "delegate" } make-slots
[ drop ] [ finalize-tuple-slots ] 2bi
[ "slots" set-word-prop ]
[ define-accessors ]
2bi
] tri
! Create special tombstone values ! Create special tombstone values
"tombstone" "hashtables.private" create "tombstone" "hashtables.private" create
tuple tuple
{ } define-tuple-class { "state" } define-tuple-class
"((empty))" "hashtables.private" create "((empty))" "hashtables.private" create
"tombstone" "hashtables.private" lookup f "tombstone" "hashtables.private" lookup f

View File

@ -21,7 +21,7 @@ load-help? off
! using the host image's hashing algorithms. We don't ! using the host image's hashing algorithms. We don't
! use each-object here since the catch stack isn't yet ! use each-object here since the catch stack isn't yet
! set up. ! set up.
begin-scan begin-scan USE: accessors USE: kernel.private
[ hashtable? ] pusher [ (each-object) ] dip [ hashtable? ] pusher [ (each-object) ] dip
end-scan end-scan
[ rehash ] each [ rehash ] each

View File

@ -58,3 +58,10 @@ ERROR: invalid-slot-name name ;
} case } case
dup check-duplicate-slots dup check-duplicate-slots
3dup check-slot-shadowing ; 3dup check-slot-shadowing ;
: literal>tuple ( seq -- tuple )
{
{ [ dup length 1 = ] [ first new ] }
{ [ dup second not ] [ [ 2 tail ] [ first ] bi slots>tuple ] }
[ "Not implemented" throw ]
} cond ;

View File

@ -21,8 +21,7 @@ ERROR: not-a-tuple object ;
superclasses [ "slots" word-prop ] map concat ; superclasses [ "slots" word-prop ] map concat ;
PREDICATE: immutable-tuple-class < tuple-class ( class -- ? ) PREDICATE: immutable-tuple-class < tuple-class ( class -- ? )
#! Delegation all-slots [ read-only>> ] all? ;
all-slots rest-slice [ read-only>> ] all? ;
<PRIVATE <PRIVATE
@ -126,7 +125,7 @@ ERROR: bad-superclass class ;
} cond ; } cond ;
: boa-check-quot ( class -- quot ) : boa-check-quot ( class -- quot )
all-slots 1 tail [ class>> instance-check-quot ] map spread>quot ; all-slots [ class>> instance-check-quot ] map spread>quot ;
: define-boa-check ( class -- ) : define-boa-check ( class -- )
dup boa-check-quot "boa-check" set-word-prop ; dup boa-check-quot "boa-check" set-word-prop ;

View File

@ -7,9 +7,9 @@ IN: quotations
<PRIVATE <PRIVATE
: uncurry dup 3 slot swap 4 slot ; inline : uncurry dup 2 slot swap 3 slot ; inline
: uncompose dup 3 slot swap 4 slot ; inline : uncompose dup 2 slot swap 3 slot ; inline
PRIVATE> PRIVATE>

View File

@ -83,7 +83,7 @@ IN: bootstrap.syntax
"B{" [ \ } [ >byte-array ] parse-literal ] define-syntax "B{" [ \ } [ >byte-array ] parse-literal ] define-syntax
"BV{" [ \ } [ >byte-vector ] parse-literal ] define-syntax "BV{" [ \ } [ >byte-vector ] parse-literal ] define-syntax
"H{" [ \ } [ >hashtable ] parse-literal ] define-syntax "H{" [ \ } [ >hashtable ] parse-literal ] define-syntax
"T{" [ \ } [ >tuple ] parse-literal ] define-syntax "T{" [ \ } [ literal>tuple ] parse-literal ] define-syntax
"W{" [ \ } [ first <wrapper> ] parse-literal ] define-syntax "W{" [ \ } [ first <wrapper> ] parse-literal ] define-syntax
"POSTPONE:" [ scan-word parsed ] define-syntax "POSTPONE:" [ scan-word parsed ] define-syntax

View File

@ -345,11 +345,8 @@ DEFINE_PRIMITIVE(tuple_boa)
F_TUPLE *tuple = allot_tuple(layout); F_TUPLE *tuple = allot_tuple(layout);
UNREGISTER_UNTAGGED(layout); UNREGISTER_UNTAGGED(layout);
/* set delegate slot */
put(AREF(tuple,0),F);
F_FIXNUM i; F_FIXNUM i;
for(i = size - 1; i >= 1; i--) for(i = size - 1; i >= 0; i--)
put(AREF(tuple,i),dpop()); put(AREF(tuple,i),dpop());
dpush(tag_tuple(tuple)); dpush(tag_tuple(tuple));