Merge branch 'master' of git://factorcode.org/git/factor
Eduardo Cavazos
commit
d2d2660af4
|
|
@ -358,7 +358,7 @@ M: byte-array '
|
|||
|
||||
! Tuples
|
||||
: (emit-tuple) ( tuple -- pointer )
|
||||
[ tuple>array rest-slice ]
|
||||
[ tuple-slots ]
|
||||
[ class transfer-word tuple-layout ] bi prefix [ ' ] map
|
||||
tuple type-number dup [ emit-seq ] emit-object ;
|
||||
|
||||
|
|
@ -384,9 +384,9 @@ M: tuple-layout '
|
|||
] cache-object ;
|
||||
|
||||
M: tombstone '
|
||||
delegate
|
||||
"((tombstone))" "((empty))" ? "hashtables.private" lookup
|
||||
def>> first [ emit-tuple ] cache-object ;
|
||||
state>> "((tombstone))" "((empty))" ?
|
||||
"hashtables.private" lookup def>> first
|
||||
[ emit-tuple ] cache-object ;
|
||||
|
||||
! Arrays
|
||||
M: array '
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel classes.tuple classes.tuple.private math arrays
|
||||
byte-arrays words stack-checker.known-words ;
|
||||
IN: compiler.tree.intrinsics
|
||||
IN: compiler.intrinsics
|
||||
|
||||
: (tuple) ( layout -- tuple )
|
||||
"BUG: missing (tuple) intrinsic" throw ;
|
||||
|
|
@ -4,8 +4,9 @@ USING: kernel accessors sequences sequences.deep combinators fry
|
|||
classes.algebra namespaces assocs words math math.private
|
||||
math.partial-dispatch math.intervals classes classes.tuple
|
||||
classes.tuple.private layouts definitions stack-checker.state
|
||||
stack-checker.branches compiler.tree
|
||||
compiler.tree.intrinsics
|
||||
stack-checker.branches
|
||||
compiler.intrinsics
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
compiler.tree.propagation.info
|
||||
compiler.tree.propagation.branches ;
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ compiler.tree.propagation compiler.tree.cleanup
|
|||
compiler.tree.combinators compiler.tree sequences math math.private
|
||||
kernel tools.test accessors slots.private quotations.private
|
||||
prettyprint classes.tuple.private classes classes.tuple
|
||||
compiler.tree.intrinsics namespaces compiler.tree.propagation.info
|
||||
compiler.intrinsics namespaces compiler.tree.propagation.info
|
||||
stack-checker.errors kernel.private ;
|
||||
|
||||
\ escape-analysis must-infer
|
||||
|
|
|
|||
|
|
@ -4,8 +4,8 @@ USING: kernel accessors sequences classes.tuple
|
|||
classes.tuple.private arrays math math.private slots.private
|
||||
combinators deques search-deques namespaces fry classes
|
||||
classes.algebra stack-checker.state
|
||||
compiler.intrinsics
|
||||
compiler.tree
|
||||
compiler.tree.intrinsics
|
||||
compiler.tree.propagation.info
|
||||
compiler.tree.escape-analysis.nodes
|
||||
compiler.tree.escape-analysis.allocations ;
|
||||
|
|
@ -23,9 +23,8 @@ DEFER: record-literal-allocation
|
|||
[ <slot-value> [ swap record-literal-allocation ] keep ] map ;
|
||||
|
||||
: 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 ] }
|
||||
[ drop f ]
|
||||
} cond ;
|
||||
|
|
@ -37,7 +36,6 @@ DEFER: record-literal-allocation
|
|||
if* ;
|
||||
|
||||
M: #push escape-analysis*
|
||||
#! Delegation.
|
||||
[ out-d>> first ] [ literal>> ] bi record-literal-allocation ;
|
||||
|
||||
: record-unknown-allocation ( #call -- )
|
||||
|
|
@ -59,7 +57,7 @@ M: #push escape-analysis*
|
|||
[ second node-value-info literal>> ] 2bi
|
||||
dup fixnum? [
|
||||
{
|
||||
{ [ over tuple class<= ] [ 3 - ] }
|
||||
{ [ over tuple class<= ] [ 2 - ] }
|
||||
{ [ over complex class<= ] [ 1 - ] }
|
||||
[ drop f ]
|
||||
} cond nip
|
||||
|
|
|
|||
|
|
@ -1,17 +1,32 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors sequences words namespaces
|
||||
classes.builtin
|
||||
USING: kernel arrays accessors sequences sequences.private words
|
||||
fry namespaces math math.order memoize classes.builtin
|
||||
classes.tuple.private slots.private combinators layouts
|
||||
byte-arrays alien.accessors
|
||||
compiler.intrinsics
|
||||
compiler.tree
|
||||
compiler.tree.builder
|
||||
compiler.tree.normalization
|
||||
compiler.tree.propagation
|
||||
compiler.tree.propagation.info
|
||||
compiler.tree.cleanup
|
||||
compiler.tree.def-use
|
||||
compiler.tree.dead-code
|
||||
compiler.tree.combinators ;
|
||||
IN: compiler.tree.finalization
|
||||
|
||||
! This pass runs after propagation, so that it can expand
|
||||
! built-in type predicates and memory allocation; these cannot
|
||||
! be expanded before propagation since we need to see 'fixnum?'
|
||||
! instead of 'tag 0 eq?' and so on, for semantic reasoning.
|
||||
! We also delete empty stack shuffles and copies to facilitate
|
||||
! tail call optimization in the code generator. After this pass
|
||||
! runs, stack flow information is no longer accurate, since we
|
||||
! punt in 'splice-quot' and don't update everything that we
|
||||
! should; this simplifies the code, improves performance, and we
|
||||
! don't need the stack flow information after this pass anyway.
|
||||
|
||||
GENERIC: finalize* ( node -- nodes )
|
||||
|
||||
M: #copy finalize* drop f ;
|
||||
|
|
@ -21,9 +36,6 @@ M: #shuffle finalize*
|
|||
[ in>> ] [ out>> ] bi sequence=
|
||||
[ drop f ] when ;
|
||||
|
||||
: builtin-predicate? ( word -- ? )
|
||||
"predicating" word-prop builtin-class? ;
|
||||
|
||||
: splice-quot ( quot -- nodes )
|
||||
[
|
||||
build-tree
|
||||
|
|
@ -35,10 +47,80 @@ M: #shuffle finalize*
|
|||
but-last
|
||||
] with-scope ;
|
||||
|
||||
: builtin-predicate? ( #call -- ? )
|
||||
word>> "predicating" word-prop builtin-class? ;
|
||||
|
||||
MEMO: builtin-predicate-expansion ( word -- nodes )
|
||||
def>> splice-quot ;
|
||||
|
||||
: expand-builtin-predicate ( #call -- nodes )
|
||||
word>> builtin-predicate-expansion ;
|
||||
|
||||
: first-literal ( #call -- obj ) node-input-infos first literal>> ;
|
||||
|
||||
: last-literal ( #call -- obj ) node-input-infos peek literal>> ;
|
||||
|
||||
: expand-tuple-boa? ( #call -- ? )
|
||||
dup word>> \ <tuple-boa> eq? [
|
||||
last-literal tuple-layout?
|
||||
] [ drop f ] if ;
|
||||
|
||||
MEMO: (tuple-boa-expansion) ( n -- quot )
|
||||
[
|
||||
[ 2 + ] map <reversed>
|
||||
[ '[ [ , set-slot ] keep ] % ] each
|
||||
] [ ] make ;
|
||||
|
||||
: tuple-boa-expansion ( layout -- quot )
|
||||
#! No memoization here since otherwise we'd hang on to
|
||||
#! tuple layout objects.
|
||||
size>> (tuple-boa-expansion) \ (tuple) prefix splice-quot ;
|
||||
|
||||
: expand-tuple-boa ( #call -- node )
|
||||
last-literal tuple-boa-expansion ;
|
||||
|
||||
MEMO: <array>-expansion ( n -- quot )
|
||||
[
|
||||
[ swap (array) ] %
|
||||
[ \ 2dup , , [ swap set-array-nth ] % ] each
|
||||
\ nip ,
|
||||
] [ ] make splice-quot ;
|
||||
|
||||
: expand-<array>? ( #call -- ? )
|
||||
dup word>> \ <array> eq? [
|
||||
first-literal dup integer?
|
||||
[ 0 32 between? ] [ drop f ] if
|
||||
] [ drop f ] if ;
|
||||
|
||||
: expand-<array> ( #call -- node )
|
||||
first-literal <array>-expansion ;
|
||||
|
||||
: bytes>cells ( m -- n ) cell align cell /i ;
|
||||
|
||||
MEMO: <byte-array>-expansion ( n -- quot )
|
||||
[
|
||||
[ (byte-array) ] %
|
||||
bytes>cells [ cell * ] map
|
||||
[ [ 0 over ] % , [ set-alien-unsigned-cell ] % ] each
|
||||
] [ ] make splice-quot ;
|
||||
|
||||
: expand-<byte-array>? ( #call -- ? )
|
||||
dup word>> \ <byte-array> eq? [
|
||||
first-literal dup integer?
|
||||
[ 0 128 between? ] [ drop f ] if
|
||||
] [ drop f ] if ;
|
||||
|
||||
: expand-<byte-array> ( #call -- nodes )
|
||||
first-literal <byte-array>-expansion ;
|
||||
|
||||
M: #call finalize*
|
||||
dup word>> builtin-predicate? [
|
||||
word>> def>> splice-quot
|
||||
] when ;
|
||||
{
|
||||
{ [ dup builtin-predicate? ] [ expand-builtin-predicate ] }
|
||||
{ [ dup expand-tuple-boa? ] [ expand-tuple-boa ] }
|
||||
{ [ dup expand-<array>? ] [ expand-<array> ] }
|
||||
{ [ dup expand-<byte-array>? ] [ expand-<byte-array> ] }
|
||||
[ ]
|
||||
} cond ;
|
||||
|
||||
M: node finalize* ;
|
||||
|
||||
|
|
|
|||
|
|
@ -60,15 +60,13 @@ slots ;
|
|||
: <value-info> ( -- info ) \ value-info new ;
|
||||
|
||||
: read-only-slots ( values class -- slots )
|
||||
#! Delegation.
|
||||
all-slots rest-slice
|
||||
all-slots
|
||||
[ read-only>> [ drop f ] unless ] 2map
|
||||
{ f f } prepend ;
|
||||
f prefix ;
|
||||
|
||||
DEFER: <literal-info>
|
||||
|
||||
: init-literal-info ( info -- info )
|
||||
#! Delegation.
|
||||
dup literal>> class >>class
|
||||
dup literal>> dup real? [ [a,a] >>interval ] [
|
||||
[ [-inf,inf] >>interval ] dip
|
||||
|
|
@ -79,10 +77,8 @@ DEFER: <literal-info>
|
|||
2array >>slots
|
||||
] }
|
||||
{ [ dup tuple? ] [
|
||||
[
|
||||
tuple-slots rest-slice
|
||||
[ <literal-info> ] map
|
||||
] [ class ] bi read-only-slots >>slots
|
||||
[ tuple-slots [ <literal-info> ] map ] [ class ] bi
|
||||
read-only-slots >>slots
|
||||
] }
|
||||
[ drop ]
|
||||
} cond
|
||||
|
|
|
|||
|
|
@ -7,6 +7,7 @@ classes.algebra combinators generic.math splitting fry locals
|
|||
classes.tuple alien.accessors classes.tuple.private slots.private
|
||||
definitions
|
||||
stack-checker.state
|
||||
compiler.intrinsics
|
||||
compiler.tree.comparisons
|
||||
compiler.tree.propagation.info
|
||||
compiler.tree.propagation.nodes
|
||||
|
|
@ -253,7 +254,7 @@ generic-comparison-ops [
|
|||
[ 2nip ] curry "outputs" set-word-prop
|
||||
] each
|
||||
|
||||
{ <tuple> <tuple-boa> } [
|
||||
{ <tuple> <tuple-boa> (tuple) } [
|
||||
[
|
||||
literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if <class-info>
|
||||
[ clear ] dip
|
||||
|
|
|
|||
|
|
@ -32,19 +32,18 @@ UNION: fixed-length-sequence array byte-array string ;
|
|||
{ <tuple-boa> <complex> } memq? ;
|
||||
|
||||
: fold-<tuple-boa> ( values class -- info )
|
||||
[ , f , [ literal>> ] map % ] { } make >tuple
|
||||
[ [ literal>> ] map ] dip prefix >tuple
|
||||
<literal-info> ;
|
||||
|
||||
: (propagate-tuple-constructor) ( values class -- info )
|
||||
[ [ value-info ] map ] dip [ read-only-slots ] keep
|
||||
over 2 tail-slice [ dup [ literal?>> ] when ] all? [
|
||||
[ 2 tail-slice ] dip fold-<tuple-boa>
|
||||
over rest-slice [ dup [ literal?>> ] when ] all? [
|
||||
[ rest-slice ] dip fold-<tuple-boa>
|
||||
] [
|
||||
<tuple-info>
|
||||
] if ;
|
||||
|
||||
: propagate-<tuple-boa> ( #call -- info )
|
||||
#! Delegation
|
||||
in-d>> unclip-last
|
||||
value-info literal>> class>> (propagate-tuple-constructor) ;
|
||||
|
||||
|
|
@ -69,7 +68,6 @@ UNION: fixed-length-sequence array byte-array string ;
|
|||
[ 1 = ] [ length>> ] bi* and ;
|
||||
|
||||
: value-info-slot ( slot info -- info' )
|
||||
#! Delegation.
|
||||
{
|
||||
{ [ over 0 = ] [ 2drop fixnum <class-info> ] }
|
||||
{ [ 2dup length-accessor? ] [ nip length>> ] }
|
||||
|
|
|
|||
|
|
@ -30,7 +30,7 @@ TUPLE: empty-tuple ;
|
|||
[ dup cons boa 10 [ nip dup cons boa ] each-integer car>> ]
|
||||
[ 2 cons boa { [ ] [ ] } dispatch ]
|
||||
[ 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 ]
|
||||
[ <complex> <complex> dup 1 slot drop 2 slot drop ]
|
||||
[ 1 cons boa over [ "A" throw ] when car>> ]
|
||||
|
|
|
|||
|
|
@ -4,8 +4,8 @@ USING: namespaces assocs accessors kernel combinators
|
|||
classes.algebra sequences sequences.deep slots.private
|
||||
classes.tuple.private math math.private arrays
|
||||
stack-checker.branches
|
||||
compiler.intrinsics
|
||||
compiler.tree
|
||||
compiler.tree.intrinsics
|
||||
compiler.tree.combinators
|
||||
compiler.tree.propagation.info
|
||||
compiler.tree.escape-analysis.simple
|
||||
|
|
|
|||
|
|
@ -4,11 +4,15 @@ USING: accessors alien alien.accessors alien.c-types arrays
|
|||
cpu.ppc.assembler cpu.ppc.architecture cpu.ppc.allot
|
||||
cpu.architecture kernel kernel.private math math.private
|
||||
namespaces sequences words generic quotations byte-arrays
|
||||
hashtables hashtables.private compiler.generator
|
||||
compiler.generator.registers compiler.generator.fixup
|
||||
hashtables hashtables.private
|
||||
sequences.private sbufs vectors system layouts
|
||||
math.floats.private classes slots.private combinators
|
||||
compiler.constants ;
|
||||
math.floats.private classes slots.private
|
||||
combinators
|
||||
compiler.constants
|
||||
compiler.intrinsics
|
||||
compiler.generator
|
||||
compiler.generator.fixup
|
||||
compiler.generator.registers ;
|
||||
IN: cpu.ppc.intrinsics
|
||||
|
||||
: %slot-literal-known-tag ( -- out value offset )
|
||||
|
|
@ -437,44 +441,44 @@ IN: cpu.ppc.intrinsics
|
|||
{ +clobber+ { "n" } }
|
||||
} define-intrinsic
|
||||
|
||||
! \ (tuple) [
|
||||
! tuple "layout" get size>> 2 + cells %allot
|
||||
! ! Store layout
|
||||
! "layout" get 12 load-indirect
|
||||
! 12 11 cell STW
|
||||
! ! Store tagged ptr in reg
|
||||
! "tuple" get tuple %store-tagged
|
||||
! ] H{
|
||||
! { +input+ { { [ ] "layout" } } }
|
||||
! { +scratch+ { { f "tuple" } } }
|
||||
! { +output+ { "tuple" } }
|
||||
! } define-intrinsic
|
||||
!
|
||||
! \ (array) [
|
||||
! array "n" get 2 + cells %allot
|
||||
! ! Store length
|
||||
! "n" operand 12 LI
|
||||
! 12 11 cell STW
|
||||
! ! Store tagged ptr in reg
|
||||
! "array" get object %store-tagged
|
||||
! ] H{
|
||||
! { +input+ { { [ ] "n" } } }
|
||||
! { +scratch+ { { f "array" } } }
|
||||
! { +output+ { "array" } }
|
||||
! } define-intrinsic
|
||||
!
|
||||
! \ (byte-array) [
|
||||
! byte-array "n" get 2 cells + %allot
|
||||
! ! Store length
|
||||
! "n" operand 12 LI
|
||||
! 12 11 cell STW
|
||||
! ! Store tagged ptr in reg
|
||||
! "array" get object %store-tagged
|
||||
! ] H{
|
||||
! { +input+ { { [ ] "n" } } }
|
||||
! { +scratch+ { { f "array" } } }
|
||||
! { +output+ { "array" } }
|
||||
! } define-intrinsic
|
||||
\ (tuple) [
|
||||
tuple "layout" get size>> 2 + cells %allot
|
||||
! Store layout
|
||||
"layout" get 12 load-indirect
|
||||
12 11 cell STW
|
||||
! Store tagged ptr in reg
|
||||
"tuple" get tuple %store-tagged
|
||||
] H{
|
||||
{ +input+ { { [ ] "layout" } } }
|
||||
{ +scratch+ { { f "tuple" } } }
|
||||
{ +output+ { "tuple" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ (array) [
|
||||
array "n" get 2 + cells %allot
|
||||
! Store length
|
||||
"n" operand 12 LI
|
||||
12 11 cell STW
|
||||
! Store tagged ptr in reg
|
||||
"array" get object %store-tagged
|
||||
] H{
|
||||
{ +input+ { { [ ] "n" } } }
|
||||
{ +scratch+ { { f "array" } } }
|
||||
{ +output+ { "array" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ (byte-array) [
|
||||
byte-array "n" get 2 cells + %allot
|
||||
! Store length
|
||||
"n" operand 12 LI
|
||||
12 11 cell STW
|
||||
! Store tagged ptr in reg
|
||||
"array" get object %store-tagged
|
||||
] H{
|
||||
{ +input+ { { [ ] "n" } } }
|
||||
{ +scratch+ { { f "array" } } }
|
||||
{ +output+ { "array" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ <ratio> [
|
||||
ratio 3 cells %allot
|
||||
|
|
@ -523,7 +527,7 @@ IN: cpu.ppc.intrinsics
|
|||
{ unboxed-c-ptr "alien" c-ptr }
|
||||
{ f "offset" fixnum }
|
||||
} }
|
||||
{ +scratch+ { { f "value" } } }
|
||||
{ +scratch+ { { f "value" } { f "scratch" } } }
|
||||
{ +output+ { "value" } }
|
||||
{ +clobber+ { "offset" } }
|
||||
} ;
|
||||
|
|
@ -580,7 +584,7 @@ define-alien-integer-intrinsics
|
|||
{ unboxed-c-ptr "alien" c-ptr }
|
||||
{ f "offset" fixnum }
|
||||
} }
|
||||
{ +scratch+ { { unboxed-alien "value" } } }
|
||||
{ +scratch+ { { unboxed-alien "value" } { f "scratch" } } }
|
||||
{ +output+ { "value" } }
|
||||
{ +clobber+ { "offset" } }
|
||||
} define-intrinsic
|
||||
|
|
@ -593,6 +597,7 @@ define-alien-integer-intrinsics
|
|||
{ unboxed-c-ptr "alien" c-ptr }
|
||||
{ f "offset" fixnum }
|
||||
} }
|
||||
{ +scratch+ { { f "scratch" } } }
|
||||
{ +clobber+ { "offset" } }
|
||||
} define-intrinsic
|
||||
|
||||
|
|
@ -602,7 +607,7 @@ define-alien-integer-intrinsics
|
|||
{ unboxed-c-ptr "alien" c-ptr }
|
||||
{ f "offset" fixnum }
|
||||
} }
|
||||
{ +scratch+ { { float "value" } } }
|
||||
{ +scratch+ { { float "value" } { f "scratch" } } }
|
||||
{ +output+ { "value" } }
|
||||
{ +clobber+ { "offset" } }
|
||||
} ;
|
||||
|
|
@ -614,6 +619,7 @@ define-alien-integer-intrinsics
|
|||
{ unboxed-c-ptr "alien" c-ptr }
|
||||
{ f "offset" fixnum }
|
||||
} }
|
||||
{ +scratch+ { { f "scratch" } } }
|
||||
{ +clobber+ { "offset" } }
|
||||
} ;
|
||||
|
||||
|
|
|
|||
|
|
@ -4,10 +4,14 @@ USING: accessors alien alien.accessors arrays cpu.x86.assembler
|
|||
cpu.x86.allot cpu.x86.architecture cpu.architecture kernel
|
||||
kernel.private math math.private namespaces quotations sequences
|
||||
words generic byte-arrays hashtables hashtables.private
|
||||
compiler.generator compiler.generator.registers
|
||||
compiler.generator.fixup sequences.private sbufs sbufs.private
|
||||
sequences.private sbufs sbufs.private
|
||||
vectors vectors.private layouts system strings.private
|
||||
slots.private compiler.constants ;
|
||||
slots.private
|
||||
compiler.constants
|
||||
compiler.intrinsics
|
||||
compiler.generator
|
||||
compiler.generator.fixup
|
||||
compiler.generator.registers ;
|
||||
IN: cpu.x86.intrinsics
|
||||
|
||||
! Type checks
|
||||
|
|
@ -289,45 +293,45 @@ IN: cpu.x86.intrinsics
|
|||
{ +clobber+ { "n" } }
|
||||
} define-intrinsic
|
||||
|
||||
! \ (tuple) [
|
||||
! tuple "layout" get size>> 2 + cells [
|
||||
! ! Store layout
|
||||
! "layout" get "scratch" get load-literal
|
||||
! 1 object@ "scratch" operand MOV
|
||||
! ! Store tagged ptr in reg
|
||||
! "tuple" get tuple %store-tagged
|
||||
! ] %allot
|
||||
! ] H{
|
||||
! { +input+ { { [ ] "layout" } } }
|
||||
! { +scratch+ { { f "tuple" } { f "scratch" } } }
|
||||
! { +output+ { "tuple" } }
|
||||
! } define-intrinsic
|
||||
!
|
||||
! \ (array) [
|
||||
! array "n" get 2 + cells [
|
||||
! ! Store length
|
||||
! 1 object@ "n" operand MOV
|
||||
! ! Store tagged ptr in reg
|
||||
! "array" get object %store-tagged
|
||||
! ] %allot
|
||||
! ] H{
|
||||
! { +input+ { { [ ] "n" } } }
|
||||
! { +scratch+ { { f "array" } } }
|
||||
! { +output+ { "array" } }
|
||||
! } define-intrinsic
|
||||
!
|
||||
! \ (byte-array) [
|
||||
! byte-array "n" get 2 cells + [
|
||||
! ! Store length
|
||||
! 1 object@ "n" operand MOV
|
||||
! ! Store tagged ptr in reg
|
||||
! "array" get object %store-tagged
|
||||
! ] %allot
|
||||
! ] H{
|
||||
! { +input+ { { [ ] "n" } } }
|
||||
! { +scratch+ { { f "array" } } }
|
||||
! { +output+ { "array" } }
|
||||
! } define-intrinsic
|
||||
\ (tuple) [
|
||||
tuple "layout" get size>> 2 + cells [
|
||||
! Store layout
|
||||
"layout" get "scratch" get load-literal
|
||||
1 object@ "scratch" operand MOV
|
||||
! Store tagged ptr in reg
|
||||
"tuple" get tuple %store-tagged
|
||||
] %allot
|
||||
] H{
|
||||
{ +input+ { { [ ] "layout" } } }
|
||||
{ +scratch+ { { f "tuple" } { f "scratch" } } }
|
||||
{ +output+ { "tuple" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ (array) [
|
||||
array "n" get 2 + cells [
|
||||
! Store length
|
||||
1 object@ "n" operand MOV
|
||||
! Store tagged ptr in reg
|
||||
"array" get object %store-tagged
|
||||
] %allot
|
||||
] H{
|
||||
{ +input+ { { [ ] "n" } } }
|
||||
{ +scratch+ { { f "array" } } }
|
||||
{ +output+ { "array" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ (byte-array) [
|
||||
byte-array "n" get 2 cells + [
|
||||
! Store length
|
||||
1 object@ "n" operand MOV
|
||||
! Store tagged ptr in reg
|
||||
"array" get object %store-tagged
|
||||
] %allot
|
||||
] H{
|
||||
{ +input+ { { [ ] "n" } } }
|
||||
{ +scratch+ { { f "array" } } }
|
||||
{ +output+ { "array" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ <ratio> [
|
||||
ratio 3 cells [
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ concurrency.promises io.encodings.ascii io threads calendar ;
|
|||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
T{ inet4 "1.2.3.4" 1234 } T{ inet4 "1.2.3.5" 1235 }
|
||||
T{ inet4 f "1.2.3.4" 1234 } T{ inet4 f "1.2.3.5" 1235 }
|
||||
[ log-connection ] 2keep
|
||||
[ remote-address get = ] [ local-address get = ] bi*
|
||||
and
|
||||
|
|
|
|||
|
|
@ -6,9 +6,9 @@ TUPLE: foo bar baz ;
|
|||
|
||||
C: <foo> foo
|
||||
|
||||
[ 3 ] [ 1 2 <foo> <mirror> assoc-size ] unit-test
|
||||
[ 2 ] [ 1 2 <foo> <mirror> assoc-size ] unit-test
|
||||
|
||||
[ { "delegate" "bar" "baz" } ] [ 1 2 <foo> <mirror> keys ] unit-test
|
||||
[ { "bar" "baz" } ] [ 1 2 <foo> <mirror> keys ] unit-test
|
||||
|
||||
[ 1 t ] [ "bar" 1 2 <foo> <mirror> at* ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -163,10 +163,12 @@ M: byte-vector >pprint-sequence ;
|
|||
M: curry >pprint-sequence ;
|
||||
M: compose >pprint-sequence ;
|
||||
M: hashtable >pprint-sequence >alist ;
|
||||
M: tuple >pprint-sequence tuple>array ;
|
||||
M: wrapper >pprint-sequence wrapped>> 1array ;
|
||||
M: callstack >pprint-sequence callstack>array ;
|
||||
|
||||
M: tuple >pprint-sequence
|
||||
[ class f 2array ] [ tuple-slots ] bi append ;
|
||||
|
||||
GENERIC: pprint-narrow? ( obj -- ? )
|
||||
|
||||
M: object pprint-narrow? drop f ;
|
||||
|
|
|
|||
|
|
@ -108,7 +108,7 @@ M: object infer-call*
|
|||
|
||||
: infer-<tuple-boa> ( -- )
|
||||
\ <tuple-boa>
|
||||
peek-d literal value>> size>> { tuple } <effect>
|
||||
peek-d literal value>> size>> 1+ { tuple } <effect>
|
||||
apply-word/effect ;
|
||||
|
||||
: infer-(throw) ( -- )
|
||||
|
|
|
|||
|
|
@ -105,8 +105,11 @@ IN: stack-checker.transforms
|
|||
\ new [
|
||||
dup tuple-class? [
|
||||
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
|
||||
] 1 define-transform
|
||||
|
||||
|
|
|
|||
|
|
@ -7,14 +7,14 @@ TUPLE: foo bar ;
|
|||
C: <foo> foo
|
||||
[ 2 ] [ 2 foo <tuple-array> dup mat set length ] unit-test
|
||||
[ T{ foo } ] [ mat get first ] unit-test
|
||||
[ T{ foo 2 1 } ] [ T{ foo 2 1 } 0 mat get [ set-nth ] keep first ] unit-test
|
||||
[ T{ foo f 2 } ] [ T{ foo f 2 } 0 mat get [ set-nth ] keep first ] unit-test
|
||||
[ t ] [ { T{ foo f 1 } T{ foo f 2 } } >tuple-array dup mat set tuple-array? ] unit-test
|
||||
[ T{ foo f 3 } t ]
|
||||
[ mat get [ bar>> 2 + <foo> ] map [ first ] keep tuple-array? ] unit-test
|
||||
|
||||
[ 2 ] [ 2 foo <tuple-array> dup mat set length ] unit-test
|
||||
[ T{ foo } ] [ mat get first ] unit-test
|
||||
[ T{ foo 2 1 } ] [ T{ foo 2 1 } 0 mat get [ set-nth ] keep first ] unit-test
|
||||
[ T{ foo f 1 } ] [ T{ foo f 1 } 0 mat get [ set-nth ] keep first ] unit-test
|
||||
|
||||
TUPLE: baz { bing integer } bong ;
|
||||
[ 0 ] [ 1 baz <tuple-array> first bing>> ] unit-test
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ IN: ui.gadgets.panes.tests
|
|||
[ ] [ #children "num-children" set ] unit-test
|
||||
|
||||
[ ] [
|
||||
"pane" get <pane-stream> [ 10000 [ . ] each ] with-output-stream*
|
||||
"pane" get <pane-stream> [ 100 [ . ] each ] with-output-stream*
|
||||
] unit-test
|
||||
|
||||
[ t ] [ #children "num-children" get = ] unit-test
|
||||
|
|
|
|||
|
|
@ -16,7 +16,9 @@ window-loc ;
|
|||
: find-world ( gadget -- world/f ) [ world? ] find-parent ;
|
||||
|
||||
: show-status ( string/f gadget -- )
|
||||
find-world dup [ status>> set-model ] [ 2drop ] if ;
|
||||
find-world dup [
|
||||
status>> dup [ set-model ] [ 2drop ] if
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: hide-status ( gadget -- ) f swap show-status ;
|
||||
|
||||
|
|
|
|||
|
|
@ -281,18 +281,12 @@ bi
|
|||
"tuple" "kernel" create
|
||||
[ { } define-builtin ]
|
||||
[ define-tuple-layout ]
|
||||
[
|
||||
{ "delegate" } make-slots
|
||||
[ drop ] [ finalize-tuple-slots ] 2bi
|
||||
[ "slots" set-word-prop ]
|
||||
[ define-accessors ]
|
||||
2bi
|
||||
] tri
|
||||
bi
|
||||
|
||||
! Create special tombstone values
|
||||
"tombstone" "hashtables.private" create
|
||||
tuple
|
||||
{ } define-tuple-class
|
||||
{ "state" } define-tuple-class
|
||||
|
||||
"((empty))" "hashtables.private" create
|
||||
"tombstone" "hashtables.private" lookup f
|
||||
|
|
|
|||
|
|
@ -58,3 +58,10 @@ ERROR: invalid-slot-name name ;
|
|||
} case
|
||||
dup check-duplicate-slots
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -46,13 +46,13 @@ C: <point> point
|
|||
|
||||
[ ] [ "p" get 300 ">>z" "accessors" lookup execute drop ] unit-test
|
||||
|
||||
[ 4 ] [ "p" get tuple-size ] unit-test
|
||||
[ 3 ] [ "p" get tuple-size ] unit-test
|
||||
|
||||
[ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
|
||||
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: point z y ;" eval ] unit-test
|
||||
|
||||
[ 3 ] [ "p" get tuple-size ] unit-test
|
||||
[ 2 ] [ "p" get tuple-size ] unit-test
|
||||
|
||||
[ "p" get x>> ] must-fail
|
||||
[ 200 ] [ "p" get y>> ] unit-test
|
||||
|
|
@ -425,7 +425,7 @@ C: <constructor-update-2> constructor-update-2
|
|||
|
||||
{ 5 1 } [ <constructor-update-2> ] must-infer-as
|
||||
|
||||
[ { f 1 2 3 4 5 } ] [ 1 2 3 4 5 <constructor-update-2> tuple-slots ] unit-test
|
||||
[ { 1 2 3 4 5 } ] [ 1 2 3 4 5 <constructor-update-2> tuple-slots ] unit-test
|
||||
|
||||
! Redefinition problem
|
||||
TUPLE: redefinition-problem ;
|
||||
|
|
@ -478,7 +478,7 @@ USE: vocabs
|
|||
] unit-test
|
||||
|
||||
[ "USE: words T{ word }" eval ]
|
||||
[ error>> T{ no-method f word slots>tuple } = ]
|
||||
[ error>> T{ no-method f word new } = ]
|
||||
must-fail-with
|
||||
|
||||
! Accessors not being forgotten...
|
||||
|
|
@ -592,10 +592,10 @@ GENERIC: break-me ( obj -- )
|
|||
TUPLE: declared-types { n fixnum } { m string } ;
|
||||
|
||||
[ T{ declared-types f 0 "hi" } ]
|
||||
[ { declared-types f 0 "hi" } >tuple ]
|
||||
[ { declared-types 0 "hi" } >tuple ]
|
||||
unit-test
|
||||
|
||||
[ { declared-types f "hi" 0 } >tuple ]
|
||||
[ { declared-types "hi" 0 } >tuple ]
|
||||
[ T{ bad-slot-value f "hi" fixnum } = ]
|
||||
must-fail-with
|
||||
|
||||
|
|
@ -708,4 +708,4 @@ TUPLE: bogus-hashcode-2 x ;
|
|||
|
||||
M: bogus-hashcode-1 hashcode* 2drop 0 >bignum ;
|
||||
|
||||
[ ] [ T{ bogus-hashcode-2 T{ bogus-hashcode-1 } } hashcode drop ] unit-test
|
||||
[ ] [ T{ bogus-hashcode-2 f T{ bogus-hashcode-1 } } hashcode drop ] unit-test
|
||||
|
|
|
|||
|
|
@ -21,8 +21,7 @@ ERROR: not-a-tuple object ;
|
|||
superclasses [ "slots" word-prop ] map concat ;
|
||||
|
||||
PREDICATE: immutable-tuple-class < tuple-class ( class -- ? )
|
||||
#! Delegation
|
||||
all-slots rest-slice [ read-only>> ] all? ;
|
||||
all-slots [ read-only>> ] all? ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
@ -126,14 +125,14 @@ ERROR: bad-superclass class ;
|
|||
} cond ;
|
||||
|
||||
: 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 -- )
|
||||
dup boa-check-quot "boa-check" set-word-prop ;
|
||||
|
||||
: tuple-prototype ( class -- prototype )
|
||||
[ initial-values ] keep
|
||||
over [ ] all? [ 2drop f ] [ slots>tuple ] if ;
|
||||
over [ ] contains? [ slots>tuple ] [ 2drop f ] if ;
|
||||
|
||||
: define-tuple-prototype ( class -- )
|
||||
dup tuple-prototype "prototype" set-word-prop ;
|
||||
|
|
|
|||
|
|
@ -199,10 +199,3 @@ ERROR: assert got expect ;
|
|||
: do-primitive ( number -- ) "Improper primitive call" throw ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
! Deprecated
|
||||
GENERIC: delegate ( obj -- delegate )
|
||||
|
||||
M: tuple delegate 2 slot ;
|
||||
|
||||
M: object delegate drop f ;
|
||||
|
|
|
|||
|
|
@ -7,9 +7,9 @@ IN: quotations
|
|||
|
||||
<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>
|
||||
|
||||
|
|
|
|||
|
|
@ -131,7 +131,7 @@ HELP: define-typecheck
|
|||
"GENERIC: generic"
|
||||
"M: class generic quot ;"
|
||||
}
|
||||
"It checks if the top of the stack is an instance of " { $snippet "class" } ", and if so, executes the quotation. Delegation is respected."
|
||||
"It checks if the top of the stack is an instance of " { $snippet "class" } ", and if so, executes the quotation."
|
||||
}
|
||||
{ $notes "This word is used internally to wrap unsafe low-level code in a type-checking stub." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -83,7 +83,7 @@ IN: bootstrap.syntax
|
|||
"B{" [ \ } [ >byte-array ] parse-literal ] define-syntax
|
||||
"BV{" [ \ } [ >byte-vector ] 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
|
||||
|
||||
"POSTPONE:" [ scan-word parsed ] define-syntax
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ C: <tree-node> tree-node
|
|||
[ >r 2 * r> bottom-up-tree ] 2tri
|
||||
] [
|
||||
drop f f
|
||||
] if <tree-node> ;
|
||||
] if <tree-node> ; inline recursive
|
||||
|
||||
GENERIC: item-check ( node -- n )
|
||||
|
||||
|
|
@ -28,7 +28,7 @@ M: f item-check drop 0 ;
|
|||
: stretch-tree ( max-depth -- )
|
||||
1 + 0 over bottom-up-tree item-check
|
||||
[ "stretch tree of depth " write pprint ]
|
||||
[ "\t check: " write . ] bi* ;
|
||||
[ "\t check: " write . ] bi* ; inline
|
||||
|
||||
:: long-lived-tree ( max-depth -- )
|
||||
0 max-depth bottom-up-tree
|
||||
|
|
@ -46,10 +46,10 @@ M: f item-check drop 0 ;
|
|||
] each
|
||||
|
||||
"long lived tree of depth " write max-depth pprint
|
||||
"\t check: " write item-check . ;
|
||||
"\t check: " write item-check . ; inline
|
||||
|
||||
: binary-trees ( n -- )
|
||||
min-depth 2 + max [ stretch-tree ] [ long-lived-tree ] bi ;
|
||||
min-depth 2 + max [ stretch-tree ] [ long-lived-tree ] bi ; inline
|
||||
|
||||
: binary-trees-main ( -- )
|
||||
16 binary-trees ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,7 @@
|
|||
USING: ui.gadgets.panes prettyprint io sequences ;
|
||||
IN: benchmark.ui-panes
|
||||
|
||||
: ui-pane-benchmark ( -- )
|
||||
<pane> <pane-stream> [ 10000 [ . ] each ] with-output-stream* ;
|
||||
|
||||
MAIN: ui-pane-benchmark
|
||||
|
|
@ -5,8 +5,9 @@ USING: kernel alien.c-types combinators namespaces arrays
|
|||
opengl.gl opengl.glu opengl ui ui.gadgets.slate
|
||||
vars colors self self.slots
|
||||
random-weighted colors.hsv cfdg.gl accessors
|
||||
ui.gadgets.handler ui.gestures assocs ui.gadgets macros ;
|
||||
|
||||
ui.gadgets.handler ui.gestures assocs ui.gadgets macros
|
||||
qualified ;
|
||||
QUALIFIED: syntax
|
||||
IN: cfdg
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
@ -158,7 +159,7 @@ MACRO: rule ( seq -- quot ) [rule] ;
|
|||
|
||||
VAR: background
|
||||
|
||||
: set-initial-background ( -- ) T{ hsva f 0 0 1 1 } clone >self ;
|
||||
: set-initial-background ( -- ) T{ hsva syntax:f 0 0 1 1 } clone >self ;
|
||||
|
||||
: set-background ( -- )
|
||||
set-initial-background
|
||||
|
|
@ -173,7 +174,7 @@ VAR: viewport ! { left width bottom height }
|
|||
|
||||
VAR: start-shape
|
||||
|
||||
: set-initial-color ( -- ) T{ hsva f 0 0 0 1 } clone >self ;
|
||||
: set-initial-color ( -- ) T{ hsva syntax:f 0 0 0 1 } clone >self ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -244,8 +245,8 @@ SYMBOL: the-slate
|
|||
C[ dlist get [ dlist get 1 glDeleteLists ] when ] >>ungraft
|
||||
<handler>
|
||||
H{ } clone
|
||||
T{ key-down f f "ENTER" } C[ drop rebuild ] swap pick set-at
|
||||
T{ button-down } C[ drop rebuild ] swap pick set-at
|
||||
T{ key-down syntax:f syntax:f "ENTER" } C[ drop rebuild ] swap pick set-at
|
||||
T{ button-down } C[ drop rebuild ] swap pick set-at
|
||||
>>table ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
|
|||
|
|
@ -199,7 +199,7 @@ STRING: button-tag-markup
|
|||
attrs>> swap update ;
|
||||
|
||||
CHLOE: button
|
||||
button-tag-markup string>xml delegate
|
||||
button-tag-markup string>xml body>>
|
||||
{
|
||||
[ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ]
|
||||
[ [ attrs>> non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ]
|
||||
|
|
|
|||
|
|
@ -4,5 +4,5 @@ IN: tuple-syntax.tests
|
|||
TUPLE: foo bar baz ;
|
||||
|
||||
[ T{ foo } ] [ TUPLE{ foo } ] unit-test
|
||||
[ T{ foo 1 { 2 3 } { 4 { 5 } } } ]
|
||||
[ TUPLE{ foo bar: { 2 3 } delegate: 1 baz: { 4 { 5 } } } ] unit-test
|
||||
[ T{ foo f { 2 3 } { 4 { 5 } } } ]
|
||||
[ TUPLE{ foo bar: { 2 3 } baz: { 4 { 5 } } } ] unit-test
|
||||
|
|
|
|||
|
|
@ -345,11 +345,8 @@ DEFINE_PRIMITIVE(tuple_boa)
|
|||
F_TUPLE *tuple = allot_tuple(layout);
|
||||
UNREGISTER_UNTAGGED(layout);
|
||||
|
||||
/* set delegate slot */
|
||||
put(AREF(tuple,0),F);
|
||||
|
||||
F_FIXNUM i;
|
||||
for(i = size - 1; i >= 1; i--)
|
||||
for(i = size - 1; i >= 0; i--)
|
||||
put(AREF(tuple,i),dpop());
|
||||
|
||||
dpush(tag_tuple(tuple));
|
||||
|
|
|
|||
Loading…
Reference in New Issue