diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 97a95f98b8..9c99ed5cdb 100755 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -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 ' diff --git a/basis/compiler/tree/intrinsics/intrinsics.factor b/basis/compiler/intrinsics/intrinsics.factor similarity index 95% rename from basis/compiler/tree/intrinsics/intrinsics.factor rename to basis/compiler/intrinsics/intrinsics.factor index 5bcc58626b..b995e6d737 100644 --- a/basis/compiler/tree/intrinsics/intrinsics.factor +++ b/basis/compiler/intrinsics/intrinsics.factor @@ -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 ; diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor index 8056e75b3e..cc5f0619cd 100644 --- a/basis/compiler/tree/cleanup/cleanup.factor +++ b/basis/compiler/tree/cleanup/cleanup.factor @@ -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 ; diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor index 0b7db5b36a..f51046c6cb 100644 --- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor +++ b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor @@ -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 diff --git a/basis/compiler/tree/escape-analysis/simple/simple.factor b/basis/compiler/tree/escape-analysis/simple/simple.factor index d69f6cab9e..0324b31199 100644 --- a/basis/compiler/tree/escape-analysis/simple/simple.factor +++ b/basis/compiler/tree/escape-analysis/simple/simple.factor @@ -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 [ [ 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 diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor index f08116b936..5aaeed360a 100644 --- a/basis/compiler/tree/finalization/finalization.factor +++ b/basis/compiler/tree/finalization/finalization.factor @@ -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>> \ eq? [ + last-literal tuple-layout? + ] [ drop f ] if ; + +MEMO: (tuple-boa-expansion) ( n -- quot ) + [ + [ 2 + ] map + [ '[ [ , 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: -expansion ( n -- quot ) + [ + [ swap (array) ] % + [ \ 2dup , , [ swap set-array-nth ] % ] each + \ nip , + ] [ ] make splice-quot ; + +: expand-? ( #call -- ? ) + dup word>> \ eq? [ + first-literal dup integer? + [ 0 32 between? ] [ drop f ] if + ] [ drop f ] if ; + +: expand- ( #call -- node ) + first-literal -expansion ; + +: bytes>cells ( m -- n ) cell align cell /i ; + +MEMO: -expansion ( n -- quot ) + [ + [ (byte-array) ] % + bytes>cells [ cell * ] map + [ [ 0 over ] % , [ set-alien-unsigned-cell ] % ] each + ] [ ] make splice-quot ; + +: expand-? ( #call -- ? ) + dup word>> \ eq? [ + first-literal dup integer? + [ 0 128 between? ] [ drop f ] if + ] [ drop f ] if ; + +: expand- ( #call -- nodes ) + first-literal -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-? ] [ expand- ] } + { [ dup expand-? ] [ expand- ] } + [ ] + } cond ; M: node finalize* ; diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index d0f418f3c9..8f2220aaaf 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -60,15 +60,13 @@ slots ; : ( -- 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: : 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: 2array >>slots ] } { [ dup tuple? ] [ - [ - tuple-slots rest-slice - [ ] map - ] [ class ] bi read-only-slots >>slots + [ tuple-slots [ ] map ] [ class ] bi + read-only-slots >>slots ] } [ drop ] } cond diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 4d3d2c781c..d31de354d1 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -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) } [ [ literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if [ clear ] dip diff --git a/basis/compiler/tree/propagation/slots/slots.factor b/basis/compiler/tree/propagation/slots/slots.factor index a4bd48ecc0..08a8520d0a 100644 --- a/basis/compiler/tree/propagation/slots/slots.factor +++ b/basis/compiler/tree/propagation/slots/slots.factor @@ -32,19 +32,18 @@ UNION: fixed-length-sequence array byte-array string ; { } memq? ; : fold- ( values class -- info ) - [ , f , [ literal>> ] map % ] { } make >tuple + [ [ literal>> ] map ] dip prefix >tuple ; : (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- + over rest-slice [ dup [ literal?>> ] when ] all? [ + [ rest-slice ] dip fold- ] [ ] if ; : propagate- ( #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 ] } { [ 2dup length-accessor? ] [ nip length>> ] } diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor index 334fcb11f0..858e40347f 100644 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor @@ -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 ] [ dup 1 slot drop 2 slot drop ] [ 1 cons boa over [ "A" throw ] when car>> ] diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor index 97b4e2aee2..6fc0e76310 100644 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor @@ -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 diff --git a/basis/cpu/ppc/intrinsics/intrinsics.factor b/basis/cpu/ppc/intrinsics/intrinsics.factor index 191baf1e0a..634040b0d0 100755 --- a/basis/cpu/ppc/intrinsics/intrinsics.factor +++ b/basis/cpu/ppc/intrinsics/intrinsics.factor @@ -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 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" } } } ; diff --git a/basis/cpu/x86/intrinsics/intrinsics.factor b/basis/cpu/x86/intrinsics/intrinsics.factor index 536b914f39..a0cfd1b01e 100755 --- a/basis/cpu/x86/intrinsics/intrinsics.factor +++ b/basis/cpu/x86/intrinsics/intrinsics.factor @@ -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 3 cells [ diff --git a/basis/io/servers/connection/connection-tests.factor b/basis/io/servers/connection/connection-tests.factor index 84e0d684ac..aa8df0b16c 100755 --- a/basis/io/servers/connection/connection-tests.factor +++ b/basis/io/servers/connection/connection-tests.factor @@ -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 diff --git a/basis/mirrors/mirrors-tests.factor b/basis/mirrors/mirrors-tests.factor index 9c8065e062..aad033600a 100755 --- a/basis/mirrors/mirrors-tests.factor +++ b/basis/mirrors/mirrors-tests.factor @@ -6,9 +6,9 @@ TUPLE: foo bar baz ; C: foo -[ 3 ] [ 1 2 assoc-size ] unit-test +[ 2 ] [ 1 2 assoc-size ] unit-test -[ { "delegate" "bar" "baz" } ] [ 1 2 keys ] unit-test +[ { "bar" "baz" } ] [ 1 2 keys ] unit-test [ 1 t ] [ "bar" 1 2 at* ] unit-test diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index 8e5e932666..87f6d3122e 100755 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -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 ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 5cbd5f40af..1c25df4112 100755 --- 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>> { tuple } + peek-d literal value>> size>> 1+ { tuple } apply-word/effect ; : infer-(throw) ( -- ) diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index 1bdfdb6f42..2773b8b4e4 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -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 diff --git a/basis/tuple-arrays/tuple-arrays-tests.factor b/basis/tuple-arrays/tuple-arrays-tests.factor index b4b7a76497..7aa49b880f 100755 --- a/basis/tuple-arrays/tuple-arrays-tests.factor +++ b/basis/tuple-arrays/tuple-arrays-tests.factor @@ -7,14 +7,14 @@ TUPLE: foo bar ; C: foo [ 2 ] [ 2 foo 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 + ] map [ first ] keep tuple-array? ] unit-test [ 2 ] [ 2 foo 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 first bing>> ] unit-test diff --git a/basis/ui/gadgets/panes/panes-tests.factor b/basis/ui/gadgets/panes/panes-tests.factor index 64a72fe523..109c0a1461 100755 --- a/basis/ui/gadgets/panes/panes-tests.factor +++ b/basis/ui/gadgets/panes/panes-tests.factor @@ -12,7 +12,7 @@ IN: ui.gadgets.panes.tests [ ] [ #children "num-children" set ] unit-test [ ] [ - "pane" get [ 10000 [ . ] each ] with-output-stream* + "pane" get [ 100 [ . ] each ] with-output-stream* ] unit-test [ t ] [ #children "num-children" get = ] unit-test diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 23237af668..bf4c275dc2 100755 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -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 ; diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 8d9f812cee..ad56dbd296 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -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 diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor index 47363378fa..e85910d18d 100644 --- a/core/classes/tuple/parser/parser.factor +++ b/core/classes/tuple/parser/parser.factor @@ -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 ; diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 3f8e3078b6..5c91bdf8dd 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -46,13 +46,13 @@ C: 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 { 5 1 } [ ] must-infer-as -[ { f 1 2 3 4 5 } ] [ 1 2 3 4 5 tuple-slots ] unit-test +[ { 1 2 3 4 5 } ] [ 1 2 3 4 5 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 diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 80ccc8fd9f..89e4e80460 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -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? ; > 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 ; diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 6c9b64b192..55ed67e0fa 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -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 ; diff --git a/core/quotations/quotations.factor b/core/quotations/quotations.factor index 617dac3323..31e5e4753d 100755 --- a/core/quotations/quotations.factor +++ b/core/quotations/quotations.factor @@ -7,9 +7,9 @@ IN: quotations diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor index 5b454c2e76..d2d7dc1102 100755 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -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." } ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index e156832923..1617617b44 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -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 ] parse-literal ] define-syntax "POSTPONE:" [ scan-word parsed ] define-syntax diff --git a/extra/benchmark/binary-trees/binary-trees.factor b/extra/benchmark/binary-trees/binary-trees.factor index bd3d460961..f562072f28 100644 --- a/extra/benchmark/binary-trees/binary-trees.factor +++ b/extra/benchmark/binary-trees/binary-trees.factor @@ -14,7 +14,7 @@ C: tree-node [ >r 2 * r> bottom-up-tree ] 2tri ] [ drop f f - ] if ; + ] if ; 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 ; diff --git a/extra/benchmark/ui-panes/ui-panes.factor b/extra/benchmark/ui-panes/ui-panes.factor new file mode 100644 index 0000000000..6fdbdaecf6 --- /dev/null +++ b/extra/benchmark/ui-panes/ui-panes.factor @@ -0,0 +1,7 @@ +USING: ui.gadgets.panes prettyprint io sequences ; +IN: benchmark.ui-panes + +: ui-pane-benchmark ( -- ) + [ 10000 [ . ] each ] with-output-stream* ; + +MAIN: ui-pane-benchmark diff --git a/extra/cfdg/cfdg.factor b/extra/cfdg/cfdg.factor index 114ebf5445..434ecd59f5 100644 --- a/extra/cfdg/cfdg.factor +++ b/extra/cfdg/cfdg.factor @@ -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 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 ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 46aba06c9c..fadd398882 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -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 ] diff --git a/extra/tuple-syntax/tuple-syntax-tests.factor b/extra/tuple-syntax/tuple-syntax-tests.factor index 2eb9d8bb12..452672ea2a 100755 --- a/extra/tuple-syntax/tuple-syntax-tests.factor +++ b/extra/tuple-syntax/tuple-syntax-tests.factor @@ -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 diff --git a/vm/types.c b/vm/types.c index 59581ecee5..3097ee73f8 100755 --- a/vm/types.c +++ b/vm/types.c @@ -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));