Remove delegation slot
parent
5ae4165570
commit
e1716d92b3
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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>> ] }
|
||||||
|
|
|
@ -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>> ]
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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) ( -- )
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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>
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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));
|
||||||
|
|
Loading…
Reference in New Issue