From a4d9cdfeb3bce0a554e5a99a3266eb6167f4c311 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 02:44:56 -0600 Subject: [PATCH] Refactor all usages of >r/r> in core to use dip, 2dip, 3dip Non-optimizing compiler now special-cases dip, 2dip, 3dip following a literal quotation: this allows us to break the dip/slip meta-circle without explicit calls to >r/r> --- basis/bootstrap/image/image.factor | 30 ++++- basis/cpu/x86/32/bootstrap.factor | 1 + basis/cpu/x86/64/unix/bootstrap.factor | 1 + basis/cpu/x86/64/winnt/bootstrap.factor | 1 + basis/cpu/x86/bootstrap.factor | 88 +++++++++++-- .../known-words/known-words.factor | 19 ++- core/arrays/arrays.factor | 4 +- core/assocs/assocs.factor | 10 +- core/bootstrap/primitives.factor | 11 +- core/checksums/checksums.factor | 11 +- core/checksums/crc32/crc32.factor | 4 +- core/classes/algebra/algebra-tests.factor | 8 +- core/classes/algebra/algebra.factor | 10 +- core/classes/tuple/tuple-tests.factor | 2 +- core/classes/tuple/tuple.factor | 10 +- core/combinators/combinators-docs.factor | 2 +- core/combinators/combinators.factor | 12 +- core/compiler/errors/errors.factor | 2 +- core/continuations/continuations.factor | 11 +- core/generic/math/math.factor | 15 +-- core/generic/standard/engines/engines.factor | 4 +- .../engines/predicate/predicate.factor | 2 +- core/generic/standard/engines/tag/tag.factor | 6 +- core/generic/standard/standard.factor | 6 +- core/growable/growable.factor | 4 +- core/hashtables/hashtables-tests.factor | 2 +- core/hashtables/hashtables.factor | 17 +-- core/io/encodings/encodings.factor | 2 +- core/io/files/files.factor | 16 +-- core/io/io.factor | 6 +- core/io/streams/byte-array/byte-array.factor | 6 +- core/io/streams/nested/nested.factor | 2 +- core/io/streams/string/string.factor | 4 +- core/kernel/kernel-docs.factor | 76 ++++-------- core/kernel/kernel-tests.factor | 6 +- core/kernel/kernel.factor | 48 ++++---- core/lexer/lexer.factor | 2 +- core/math/integers/integers.factor | 10 +- core/math/math.factor | 10 +- core/math/parser/parser.factor | 6 +- core/namespaces/namespaces.factor | 4 +- core/parser/parser.factor | 6 +- core/quotations/quotations.factor | 5 +- core/sequences/sequences.factor | 116 +++++++++--------- core/slots/slots.factor | 14 +-- core/sorting/sorting.factor | 22 ++-- core/splitting/splitting.factor | 4 +- core/strings/parser/parser.factor | 8 +- core/strings/strings.factor | 4 +- core/syntax/syntax.factor | 9 +- core/vectors/vectors-tests.factor | 4 +- core/words/words.factor | 6 +- vm/quotations.c | 70 +++++++++++ vm/run.h | 6 + 54 files changed, 464 insertions(+), 301 deletions(-) diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index c0fafdc0f5..d5f36db776 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -130,6 +130,12 @@ SYMBOL: jit-if-word SYMBOL: jit-if-jump SYMBOL: jit-dispatch-word SYMBOL: jit-dispatch +SYMBOL: jit-dip-word +SYMBOL: jit-dip +SYMBOL: jit-2dip-word +SYMBOL: jit-2dip +SYMBOL: jit-3dip-word +SYMBOL: jit-3dip SYMBOL: jit-epilog SYMBOL: jit-return SYMBOL: jit-profiling @@ -139,8 +145,8 @@ SYMBOL: jit-save-stack ! Default definition for undefined words SYMBOL: undefined-quot -: userenv-offset ( symbol -- n ) - { +: userenvs ( -- assoc ) + H{ { bootstrap-boot-quot 20 } { bootstrap-global 21 } { jit-code-format 22 } @@ -160,8 +166,17 @@ SYMBOL: undefined-quot { jit-push-immediate 36 } { jit-declare-word 42 } { jit-save-stack 43 } + { jit-dip-word 44 } + { jit-dip 45 } + { jit-2dip-word 46 } + { jit-2dip 47 } + { jit-3dip-word 48 } + { jit-3dip 49 } { undefined-quot 60 } - } at header-size + ; + } ; inline + +: userenv-offset ( symbol -- n ) + userenvs at header-size + ; : emit ( cell -- ) image get push ; @@ -443,6 +458,9 @@ M: quotation ' \ dispatch jit-dispatch-word set \ do-primitive jit-primitive-word set \ declare jit-declare-word set + \ dip jit-dip-word set + \ 2dip jit-2dip-word set + \ 3dip jit-3dip-word set [ undefined ] undefined-quot set { jit-code-format @@ -457,6 +475,12 @@ M: quotation ' jit-if-jump jit-dispatch-word jit-dispatch + jit-dip-word + jit-dip + jit-2dip-word + jit-2dip + jit-3dip-word + jit-3dip jit-epilog jit-return jit-profiling diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index ba963ab477..04bdcca68b 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -12,6 +12,7 @@ IN: bootstrap.x86 : mod-arg ( -- reg ) EDX ; : arg0 ( -- reg ) EAX ; : arg1 ( -- reg ) EDX ; +: arg2 ( -- reg ) ECX ; : temp-reg ( -- reg ) EBX ; : stack-reg ( -- reg ) ESP ; : ds-reg ( -- reg ) ESI ; diff --git a/basis/cpu/x86/64/unix/bootstrap.factor b/basis/cpu/x86/64/unix/bootstrap.factor index 29d48bd794..f0ca56da14 100644 --- a/basis/cpu/x86/64/unix/bootstrap.factor +++ b/basis/cpu/x86/64/unix/bootstrap.factor @@ -7,6 +7,7 @@ IN: bootstrap.x86 : stack-frame-size ( -- n ) 4 bootstrap-cells ; : arg0 ( -- reg ) RDI ; : arg1 ( -- reg ) RSI ; +: arg2 ( -- reg ) RDX ; << "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >> call diff --git a/basis/cpu/x86/64/winnt/bootstrap.factor b/basis/cpu/x86/64/winnt/bootstrap.factor index a62b946e83..459945d82e 100644 --- a/basis/cpu/x86/64/winnt/bootstrap.factor +++ b/basis/cpu/x86/64/winnt/bootstrap.factor @@ -7,6 +7,7 @@ IN: bootstrap.x86 : stack-frame-size ( -- n ) 8 bootstrap-cells ; : arg0 ( -- reg ) RCX ; : arg1 ( -- reg ) RDX ; +: arg2 ( -- reg ) R8 ; << "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >> call diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 256a778e8a..af7c9e2f0f 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -73,6 +73,80 @@ big-endian off arg0 quot-xt-offset [+] JMP ! execute branch ] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define +! The jit->r words cannot clobber arg0 + +: jit->r ( -- ) + rs-reg bootstrap-cell ADD + temp-reg ds-reg [] MOV + ds-reg bootstrap-cell SUB + rs-reg [] temp-reg MOV ; + +: jit-2>r ( -- ) + rs-reg 2 bootstrap-cells ADD + temp-reg ds-reg [] MOV + arg1 ds-reg -1 bootstrap-cells [+] MOV + ds-reg 2 bootstrap-cells SUB + rs-reg [] temp-reg MOV + rs-reg -1 bootstrap-cells [+] arg1 MOV ; + +: jit-3>r ( -- ) + rs-reg 3 bootstrap-cells ADD + temp-reg ds-reg [] MOV + arg1 ds-reg -1 bootstrap-cells [+] MOV + arg2 ds-reg -2 bootstrap-cells [+] MOV + ds-reg 3 bootstrap-cells SUB + rs-reg [] temp-reg MOV + rs-reg -1 bootstrap-cells [+] arg1 MOV + rs-reg -2 bootstrap-cells [+] arg2 MOV ; + +: jit-r> ( -- ) + ds-reg bootstrap-cell ADD + temp-reg rs-reg [] MOV + rs-reg bootstrap-cell SUB + ds-reg [] temp-reg MOV ; + +: jit-2r> ( -- ) + ds-reg 2 bootstrap-cells ADD + temp-reg rs-reg [] MOV + arg1 rs-reg -1 bootstrap-cells [+] MOV + rs-reg 2 bootstrap-cells SUB + ds-reg [] temp-reg MOV + ds-reg -1 bootstrap-cells [+] arg1 MOV ; + +: jit-3r> ( -- ) + ds-reg 3 bootstrap-cells ADD + temp-reg rs-reg [] MOV + arg1 rs-reg -1 bootstrap-cells [+] MOV + arg2 rs-reg -2 bootstrap-cells [+] MOV + rs-reg 3 bootstrap-cells SUB + ds-reg [] temp-reg MOV + ds-reg -1 bootstrap-cells [+] arg1 MOV + ds-reg -2 bootstrap-cells [+] arg2 MOV ; + +[ + arg0 0 MOV ! load quotation addr + arg0 arg0 [] MOV ! load quotation + jit->r + arg0 quot-xt-offset [+] CALL ! call quotation + jit-r> +] rc-absolute-cell rt-literal 1 rex-length + jit-dip jit-define + +[ + arg0 0 MOV ! load quotation addr + arg0 arg0 [] MOV ! load quotation + jit-2>r + arg0 quot-xt-offset [+] CALL ! call quotation + jit-2r> +] rc-absolute-cell rt-literal 1 rex-length + jit-2dip jit-define + +[ + arg0 0 MOV ! load quotation addr + arg0 arg0 [] MOV ! load quotation + jit-3>r + arg0 quot-xt-offset [+] CALL ! call quotation + jit-3r> +] rc-absolute-cell rt-literal 1 rex-length + jit-3dip jit-define + [ stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame ] f f f jit-epilog jit-define @@ -223,19 +297,9 @@ big-endian off ds-reg [] arg1 MOV ] f f f \ -rot define-sub-primitive -[ - rs-reg bootstrap-cell ADD - arg0 ds-reg [] MOV - ds-reg bootstrap-cell SUB - rs-reg [] arg0 MOV -] f f f \ >r define-sub-primitive +[ jit->r ] f f f \ >r define-sub-primitive -[ - ds-reg bootstrap-cell ADD - arg0 rs-reg [] MOV - rs-reg bootstrap-cell SUB - ds-reg [] arg0 MOV -] f f f \ r> define-sub-primitive +[ jit-r> ] f f f \ r> define-sub-primitive ! Comparisons : jit-compare ( insn -- ) diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index fdc4b4b35c..320ac4f3bf 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -87,6 +87,15 @@ M: composed infer-call* M: object infer-call* \ literal-expected inference-warning ; +: infer-slip ( -- ) + 1 infer->r pop-d infer-call 1 infer-r> ; + +: infer-2slip ( -- ) + 2 infer->r pop-d infer-call 2 infer-r> ; + +: infer-3slip ( -- ) + 3 infer->r pop-d infer-call 3 infer-r> ; + : infer-curry ( -- ) 2 consume-d dup first2 make-known @@ -150,6 +159,9 @@ M: object infer-call* { \ declare [ infer-declare ] } { \ call [ pop-d infer-call ] } { \ (call) [ pop-d infer-call ] } + { \ slip [ infer-slip ] } + { \ 2slip [ infer-2slip ] } + { \ 3slip [ infer-3slip ] } { \ curry [ infer-curry ] } { \ compose [ infer-compose ] } { \ execute [ infer-execute ] } @@ -175,9 +187,10 @@ M: object infer-call* (( value -- )) apply-word/effect ; { - >r r> declare call (call) curry compose execute (execute) if -dispatch (throw) load-locals get-local drop-locals -do-primitive alien-invoke alien-indirect alien-callback + >r r> declare call (call) slip 2slip 3slip curry compose + execute (execute) if dispatch (throw) + load-locals get-local drop-locals do-primitive alien-invoke + alien-indirect alien-callback } [ t "special" set-word-prop ] each { call execute dispatch load-locals get-local drop-locals } diff --git a/core/arrays/arrays.factor b/core/arrays/arrays.factor index b023398762..74bc57e9db 100644 --- a/core/arrays/arrays.factor +++ b/core/arrays/arrays.factor @@ -6,8 +6,8 @@ IN: arrays M: array clone (clone) ; M: array length length>> ; -M: array nth-unsafe >r >fixnum r> array-nth ; -M: array set-nth-unsafe >r >fixnum r> set-array-nth ; +M: array nth-unsafe [ >fixnum ] dip array-nth ; +M: array set-nth-unsafe [ >fixnum ] dip set-array-nth ; M: array resize resize-array ; : >array ( seq -- array ) { } clone-like ; diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index b345f44c5c..953cc38c56 100644 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -86,7 +86,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) 3drop f ] [ 3dup nth-unsafe at* - [ >r 3drop r> ] [ drop >r 1- r> (assoc-stack) ] if + [ [ 3drop ] dip ] [ drop [ 1- ] dip (assoc-stack) ] if ] if ; inline recursive : assoc-stack ( key seq -- value ) @@ -100,7 +100,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) : assoc-hashcode ( n assoc -- code ) [ - >r over r> hashcode* 2/ >r dupd hashcode* r> bitxor + [ over ] dip hashcode* 2/ [ dupd hashcode* ] dip bitxor ] { } assoc>map hashcode* ; : assoc-intersect ( assoc1 assoc2 -- intersection ) @@ -145,7 +145,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) [ 0 or + ] change-at ; : map>assoc ( seq quot exemplar -- assoc ) - >r [ 2array ] compose { } map-as r> assoc-like ; inline + [ [ 2array ] compose { } map-as ] dip assoc-like ; inline : extract-keys ( seq assoc -- subassoc ) [ [ dupd at ] curry ] keep map>assoc ; @@ -189,10 +189,10 @@ M: sequence delete-at M: sequence assoc-size length ; M: sequence assoc-clone-like - >r >alist r> clone-like ; + [ >alist ] dip clone-like ; M: sequence assoc-like - >r >alist r> like ; + [ >alist ] dip like ; M: sequence >alist ; diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 65731dd1ad..66c815be51 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -129,8 +129,7 @@ bootstrapping? on [ "slots" set-word-prop ] [ define-accessors ] 2bi ; : define-builtin ( symbol slotspec -- ) - >r [ define-builtin-predicate ] keep - r> define-builtin-slots ; + [ [ define-builtin-predicate ] keep ] dip define-builtin-slots ; "fixnum" "math" create register-builtin "bignum" "math" create register-builtin @@ -327,9 +326,7 @@ tuple [ ] [ [ - \ >r , - callable instance-check-quot % - \ r> , + callable instance-check-quot [ dip ] curry % callable instance-check-quot % tuple-layout , \ , @@ -389,7 +386,7 @@ tuple ! Primitive words : make-primitive ( word vocab n -- ) - >r create dup reset-word r> + [ create dup reset-word ] dip [ do-primitive ] curry [ ] like define ; { @@ -533,7 +530,7 @@ tuple { "unimplemented" "kernel.private" } { "gc-reset" "memory" } } -[ >r first2 r> make-primitive ] each-index +[ [ first2 ] dip make-primitive ] each-index ! Bump build number "build" "kernel" create build 1+ 1quotation define diff --git a/core/checksums/checksums.factor b/core/checksums/checksums.factor index 08a13297d1..4b0d9e5072 100644 --- a/core/checksums/checksums.factor +++ b/core/checksums/checksums.factor @@ -12,14 +12,17 @@ GENERIC: checksum-stream ( stream checksum -- value ) GENERIC: checksum-lines ( lines checksum -- value ) -M: checksum checksum-bytes >r binary r> checksum-stream ; +M: checksum checksum-bytes + [ binary ] dip checksum-stream ; -M: checksum checksum-stream >r contents r> checksum-bytes ; +M: checksum checksum-stream + [ contents ] dip checksum-bytes ; -M: checksum checksum-lines >r B{ CHAR: \n } join r> checksum-bytes ; +M: checksum checksum-lines + [ B{ CHAR: \n } join ] dip checksum-bytes ; : checksum-file ( path checksum -- value ) - >r binary r> checksum-stream ; + [ binary ] dip checksum-stream ; : hex-string ( seq -- str ) [ >hex 2 CHAR: 0 pad-left ] { } map-as concat ; diff --git a/core/checksums/crc32/crc32.factor b/core/checksums/crc32/crc32.factor index e1f0b9417b..7cff22de19 100644 --- a/core/checksums/crc32/crc32.factor +++ b/core/checksums/crc32/crc32.factor @@ -11,7 +11,7 @@ IN: checksums.crc32 256 [ 8 [ - dup even? >r 2/ r> [ crc32-polynomial bitxor ] unless + [ 2/ ] [ even? ] bi [ crc32-polynomial bitxor ] unless ] times >bignum ] map 0 crc32-table copy @@ -24,7 +24,7 @@ SINGLETON: crc32 INSTANCE: crc32 checksum -: init-crc32 drop >r HEX: ffffffff dup r> ; inline +: init-crc32 drop [ HEX: ffffffff dup ] dip ; inline : finish-crc32 bitxor 4 >be ; inline diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index 4558ce4737..a3610ff7c5 100644 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -13,9 +13,9 @@ IN: classes.algebra.tests \ flatten-class must-infer \ flatten-builtin-class must-infer -: class-and* ( cls1 cls2 cls3 -- ? ) >r class-and r> class= ; +: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ; -: class-or* ( cls1 cls2 cls3 -- ? ) >r class-or r> class= ; +: class-or* ( cls1 cls2 cls3 -- ? ) [ class-or ] dip class= ; [ t ] [ object object object class-and* ] unit-test [ t ] [ fixnum object fixnum class-and* ] unit-test @@ -240,9 +240,9 @@ UNION: z1 b1 c1 ; 20 [ random-boolean-op ] [ ] replicate-as dup . [ infer in>> [ random-boolean ] replicate dup . ] keep - [ >r [ ] each r> call ] 2keep + [ [ [ ] each ] dip call ] 2keep - >r [ boolean>class ] each r> [ boolean-op>class-op ] map call object class= + [ [ boolean>class ] each ] dip [ boolean-op>class-op ] map call object class= = ] unit-test diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index b7e6800950..1b86ce0b0a 100644 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -18,7 +18,7 @@ TUPLE: anonymous-complement class ; C: anonymous-complement : 2cache ( key1 key2 assoc quot -- value ) - >r >r 2array r> [ first2 ] r> compose cache ; inline + [ 2array ] 2dip [ first2 ] prepose cache ; inline GENERIC: valid-class? ( obj -- ? ) @@ -66,13 +66,13 @@ DEFER: (class-or) swap superclass dup [ swap class<= ] [ 2drop f ] if ; : left-anonymous-union<= ( first second -- ? ) - >r members>> r> [ class<= ] curry all? ; + [ members>> ] dip [ class<= ] curry all? ; : right-anonymous-union<= ( first second -- ? ) members>> [ class<= ] with contains? ; : left-anonymous-intersection<= ( first second -- ? ) - >r participants>> r> [ class<= ] curry contains? ; + [ participants>> ] dip [ class<= ] curry contains? ; : right-anonymous-intersection<= ( first second -- ? ) participants>> [ class<= ] with all? ; @@ -95,7 +95,7 @@ DEFER: (class-or) } cond ; : left-anonymous-complement<= ( first second -- ? ) - >r normalize-complement r> class<= ; + [ normalize-complement ] dip class<= ; PREDICATE: nontrivial-anonymous-complement < anonymous-complement class>> { @@ -212,7 +212,7 @@ M: anonymous-complement (classes-intersect?) : sort-classes ( seq -- newseq ) [ [ name>> ] compare ] sort >vector [ dup empty? not ] - [ dup largest-class >r over delete-nth r> ] + [ dup largest-class [ over delete-nth ] dip ] [ ] produce nip ; : min-class ( class seq -- class/f ) diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 8261e713a5..8d2610ccd7 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -485,7 +485,7 @@ must-fail-with [ t ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test : accessor-exists? ( class name -- ? ) - >r "forget-accessors-test" "classes.tuple.tests" lookup r> + [ "forget-accessors-test" "classes.tuple.tests" lookup ] dip ">>" append "accessors" lookup method >boolean ; [ t ] [ "x" accessor-exists? ] unit-test diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 70b189852f..b6b277a32f 100644 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -58,7 +58,7 @@ PRIVATE> : tuple>array ( tuple -- array ) prepare-tuple>array - >r copy-tuple-slots r> + [ copy-tuple-slots ] dip first prefix ; : tuple-slots ( tuple -- seq ) @@ -178,9 +178,9 @@ ERROR: bad-superclass class ; : update-slot ( old-values n class initial -- value ) pick [ - >r >r swap nth dup r> instance? r> swap + [ [ swap nth dup ] dip instance? ] dip swap [ drop ] [ nip ] if - ] [ >r 3drop r> ] if ; + ] [ [ 3drop ] dip ] if ; : apply-slot-permutation ( old-values triples -- new-values ) [ first3 update-slot ] with map ; @@ -233,7 +233,7 @@ M: tuple-class update-class class-usages [ tuple-class? ] filter ; : each-subclass ( class quot -- ) - >r subclasses r> each ; inline + [ subclasses ] dip each ; inline : redefine-tuple-class ( class superclass slots -- ) [ @@ -320,7 +320,7 @@ M: tuple equal? over tuple? [ tuple= ] [ 2drop f ] if ; M: tuple hashcode* [ [ class hashcode ] [ tuple-size ] [ ] tri - >r rot r> [ + [ rot ] dip [ swapd array-nth hashcode* sequence-hashcode-step ] 2curry each ] recursive-hashcode ; diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index 0caabf2fad..3afc0a3c3d 100644 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -74,7 +74,7 @@ HELP: spread { $code "! Equivalent" "{ [ p ] [ q ] [ r ] [ s ] } spread" - ">r >r >r p r> q r> r r> s" + "[ [ [ p ] dip q ] dip r ] dip s" } } ; diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 82744276fd..893078fb39 100644 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -80,7 +80,7 @@ ERROR: no-case ; drop [ swap adjoin ] curry each ] [ [ - >r 2dup r> hashcode pick length rem rot nth adjoin + [ 2dup ] dip hashcode pick length rem rot nth adjoin ] each 2drop ] if ; @@ -88,13 +88,13 @@ ERROR: no-case ; next-power-of-2 swap [ nip clone ] curry map ; : distribute-buckets ( alist initial quot -- buckets ) - swapd [ >r dup first r> call 2array ] curry map + swapd [ [ dup first ] dip call 2array ] curry map [ length dup ] keep [ first2 (distribute-buckets) ] with each ; inline : hash-case-table ( default assoc -- array ) V{ } [ 1array ] distribute-buckets - [ [ >r literalize r> ] assoc-map linear-case-quot ] with map ; + [ [ [ literalize ] dip ] assoc-map linear-case-quot ] with map ; : hash-dispatch-quot ( table -- quot ) [ length 1- [ fixnum-bitand ] curry ] keep @@ -130,20 +130,20 @@ ERROR: no-case ; { [ dup [ length 4 <= ] [ [ word? ] contains? ] bi or ] [ drop linear-case-quot ] } { [ dup contiguous-range? ] [ drop dispatch-case-quot ] } { [ dup [ wrapper? ] contains? not ] [ drop hash-case-quot ] } - { [ dup [ wrapper? ] all? ] [ drop [ >r wrapped>> r> ] assoc-map hash-case-quot ] } + { [ dup [ wrapper? ] all? ] [ drop [ [ wrapped>> ] dip ] assoc-map hash-case-quot ] } [ drop linear-case-quot ] } cond ; ! assert-depth : trim-datastacks ( seq1 seq2 -- seq1' seq2' ) - 2dup [ length ] bi@ min tuck tail >r tail r> ; + 2dup [ length ] bi@ min tuck [ tail ] 2bi@ ; ERROR: relative-underflow stack ; ERROR: relative-overflow stack ; : assert-depth ( quot -- ) - >r datastack r> dip >r datastack r> + [ datastack ] dip dip [ datastack ] dip 2dup [ length ] compare { { +lt+ [ trim-datastacks nip relative-underflow ] } { +eq+ [ 2drop ] } diff --git a/core/compiler/errors/errors.factor b/core/compiler/errors/errors.factor index c2452f719d..1ea497c3fc 100644 --- a/core/compiler/errors/errors.factor +++ b/core/compiler/errors/errors.factor @@ -20,7 +20,7 @@ SYMBOL: with-compiler-errors? : errors-of-type ( type -- assoc ) compiler-errors get-global - swap [ >r nip compiler-error-type r> eq? ] curry + swap [ [ nip compiler-error-type ] dip eq? ] curry assoc-filter ; : compiler-errors. ( type -- ) diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 6dde851963..af8cda37c6 100644 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -65,7 +65,7 @@ C: continuation #! ( value f r:capture r:restore ) #! Execution begins right after the call to 'continuation'. #! The 'restore' branch is taken. - >r >r dummy-1 continuation r> r> [ dummy-2 ] prepose ?if ; inline + [ dummy-1 continuation ] 2dip [ dummy-2 ] prepose ?if ; inline : callcc0 ( quot -- ) [ drop ] ifcc ; inline @@ -78,7 +78,7 @@ C: continuation set-catchstack set-namestack set-retainstack - >r set-datastack r> + [ set-datastack ] dip set-callstack ; : (continue-with) ( obj continuation -- ) @@ -87,7 +87,7 @@ C: continuation set-catchstack set-namestack set-retainstack - >r set-datastack drop 4 getenv f 4 setenv f r> + [ set-datastack drop 4 getenv f 4 setenv f ] dip set-callstack ; PRIVATE> @@ -135,14 +135,13 @@ SYMBOL: thread-error-hook c> continue-with ; : recover ( try recovery -- ) - >r [ swap >c call c> drop ] curry r> ifcc ; inline + [ [ swap >c call c> drop ] curry ] dip ifcc ; inline : ignore-errors ( quot -- ) [ drop ] recover ; inline : cleanup ( try cleanup-always cleanup-error -- ) - over >r compose [ dip rethrow ] curry - recover r> call ; inline + [ compose [ dip rethrow ] curry recover ] [ drop ] 2bi call ; inline ERROR: attempt-all-error ; diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index ebe1c08cb3..0c7bb2d8e8 100644 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -36,9 +36,10 @@ PREDICATE: math-class < class : math-upgrade ( class1 class2 -- quot ) [ math-class-max ] 2keep - >r over r> (math-upgrade) >r (math-upgrade) - dup empty? [ [ dip ] curry [ ] like ] unless - r> append ; + [ over ] dip (math-upgrade) [ + (math-upgrade) + dup empty? [ [ dip ] curry [ ] like ] unless + ] dip append ; ERROR: no-math-method left right generic ; @@ -55,9 +56,9 @@ ERROR: no-math-method left right generic ; : math-method ( word class1 class2 -- quot ) 2dup and [ - 2dup math-upgrade >r - math-class-max over order min-class applicable-method - r> prepend + 2dup math-upgrade + [ math-class-max over order min-class applicable-method ] dip + prepend ] [ 2drop object-method ] if ; @@ -85,7 +86,7 @@ M: math-combination perform-combination dup \ over [ dup math-class? [ - \ dup [ >r 2dup r> math-method ] math-vtable + \ dup [ [ 2dup ] dip math-method ] math-vtable ] [ over object-method ] if nip diff --git a/core/generic/standard/engines/engines.factor b/core/generic/standard/engines/engines.factor index 6a5e8d1bb0..b6cb9fc9f7 100644 --- a/core/generic/standard/engines/engines.factor +++ b/core/generic/standard/engines/engines.factor @@ -18,7 +18,7 @@ GENERIC: engine>quot ( engine -- quot ) [ over assumed [ engine>quot ] with-variable ] assoc-map ; : if-small? ( assoc true false -- ) - >r >r dup assoc-size 4 <= r> r> if ; inline + [ dup assoc-size 4 <= ] 2dip if ; inline : linear-dispatch-quot ( alist -- quot ) default get [ drop ] prepend swap @@ -45,7 +45,7 @@ GENERIC: engine>quot ( engine -- quot ) { 0 [ [ dup ] ] } { 1 [ [ over ] ] } { 2 [ [ pick ] ] } - [ 1- (picker) [ >r ] swap [ r> swap ] 3append ] + [ 1- (picker) [ dip swap ] curry ] } case ; : picker ( -- quot ) \ (dispatch#) get (picker) ; diff --git a/core/generic/standard/engines/predicate/predicate.factor b/core/generic/standard/engines/predicate/predicate.factor index 8846c9eee7..152b112c2a 100644 --- a/core/generic/standard/engines/predicate/predicate.factor +++ b/core/generic/standard/engines/predicate/predicate.factor @@ -10,7 +10,7 @@ TUPLE: predicate-dispatch-engine methods ; C: predicate-dispatch-engine : class-predicates ( assoc -- assoc ) - [ >r "predicate" word-prop picker prepend r> ] assoc-map ; + [ [ "predicate" word-prop picker prepend ] dip ] assoc-map ; : keep-going? ( assoc -- ? ) assumed get swap second first class<= ; diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor index d1bc6d7417..dbdc6e0742 100644 --- a/core/generic/standard/engines/tag/tag.factor +++ b/core/generic/standard/engines/tag/tag.factor @@ -26,7 +26,7 @@ C: lo-tag-dispatch-engine M: lo-tag-dispatch-engine engine>quot methods>> engines>quots* - [ >r lo-tag-number r> ] assoc-map + [ [ lo-tag-number ] dip ] assoc-map [ picker % [ tag ] % [ sort-tags linear-dispatch-quot @@ -53,13 +53,13 @@ C: hi-tag-dispatch-engine M: hi-tag-dispatch-engine engine>quot methods>> engines>quots* - [ >r hi-tag-number r> ] assoc-map + [ [ hi-tag-number ] dip ] assoc-map [ picker % hi-tag-quot % [ sort-tags linear-dispatch-quot ] [ num-tags get , \ fixnum-fast , - [ >r num-tags get - r> ] assoc-map + [ [ num-tags get - ] dip ] assoc-map num-hi-tags direct-dispatch-quot ] if-small? % ] [ ] make ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 284a58836f..4f26c40e78 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -33,8 +33,8 @@ ERROR: no-method object generic ; ] change-at ; : flatten-method ( class method assoc -- ) - >r >r dup flatten-class keys swap r> r> [ - >r spin r> push-method + [ dup flatten-class keys swap ] 2dip [ + [ spin ] dip push-method ] 3curry each ; : flatten-methods ( assoc -- assoc' ) @@ -113,7 +113,7 @@ PREDICATE: simple-generic < standard-generic T{ standard-combination f 0 } define-generic ; : with-standard ( combination quot -- quot' ) - >r #>> (dispatch#) r> with-variable ; inline + [ #>> (dispatch#) ] dip with-variable ; inline M: standard-generic extra-values drop 0 ; diff --git a/core/growable/growable.factor b/core/growable/growable.factor index 336f1da91a..3c487af0a5 100644 --- a/core/growable/growable.factor +++ b/core/growable/growable.factor @@ -43,10 +43,10 @@ M: growable set-length ( n seq -- ) growable-check 2dup length >= [ 2dup capacity >= [ over new-size over expand ] when - >r >fixnum r> + [ >fixnum ] dip over 1 fixnum+fast over (>>length) ] [ - >r >fixnum r> + [ >fixnum ] dip ] if ; inline M: growable set-nth ensure set-nth-unsafe ; diff --git a/core/hashtables/hashtables-tests.factor b/core/hashtables/hashtables-tests.factor index a59c649598..0e6deb7746 100644 --- a/core/hashtables/hashtables-tests.factor +++ b/core/hashtables/hashtables-tests.factor @@ -134,7 +134,7 @@ H{ } "x" set [ H{ { -1 4 } { -3 16 } { -5 36 } } ] [ H{ { 1 2 } { 3 4 } { 5 6 } } - [ >r neg r> sq ] assoc-map + [ [ neg ] dip sq ] assoc-map ] unit-test ! Bug discovered by littledan diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index 0fde459a25..474cf4c9d6 100644 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -15,7 +15,7 @@ TUPLE: hashtable length>> 1 fixnum-fast fixnum-bitand ; inline : hash@ ( key array -- i ) - >r hashcode >fixnum dup fixnum+fast r> wrap ; inline + [ hashcode >fixnum dup fixnum+fast ] dip wrap ; inline : probe ( array i -- array i ) 2 fixnum+fast over wrap ; inline @@ -105,7 +105,7 @@ M: hashtable clear-assoc ( hash -- ) M: hashtable delete-at ( key hash -- ) tuck key@ [ - >r >r ((tombstone)) dup r> r> set-nth-pair + [ ((tombstone)) dup ] 2dip set-nth-pair hash-deleted+ ] [ 3drop @@ -115,9 +115,9 @@ M: hashtable assoc-size ( hash -- n ) [ count>> ] [ deleted>> ] bi - ; : rehash ( hash -- ) - dup >alist >r + dup >alist [ dup clear-assoc - r> (rehash) ; + ] dip (rehash) ; M: hashtable set-at ( value key hash -- ) dup ?grow-hash @@ -133,7 +133,7 @@ M: hashtable set-at ( value key hash -- ) : push-unsafe ( elt seq -- ) [ length ] keep [ underlying>> set-array-nth ] - [ >r 1+ r> (>>length) ] + [ [ 1+ ] dip (>>length) ] 2bi ; inline PRIVATE> @@ -141,9 +141,10 @@ PRIVATE> M: hashtable >alist [ array>> [ length 2/ ] keep ] [ assoc-size ] bi [ [ - >r - >r 1 fixnum-shift-fast r> - [ array-nth ] [ >r 1 fixnum+fast r> array-nth ] 2bi r> + [ + [ 1 fixnum-shift-fast ] dip + [ array-nth ] [ [ 1 fixnum+fast ] dip array-nth ] 2bi + ] dip pick tombstone? [ 3drop ] [ [ 2array ] dip push-unsafe ] if ] 2curry each ] keep { } like ; diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 48a428d36e..d165ad3138 100644 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -95,7 +95,7 @@ M: decoder stream-read-partial stream-read ; : ((read-until)) ( buf quot: ( -- char stop? ) -- string/f sep/f ) dup call - [ >r drop "" like r> ] + [ [ drop "" like ] dip ] [ pick push ((read-until)) ] if ; inline recursive : (read-until) ( quot -- string/f sep/f ) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 17f06a2a50..7c7a2ece31 100644 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -26,13 +26,13 @@ HOOK: (file-appender) io-backend ( path -- stream ) lines ; : with-file-reader ( path encoding quot -- ) - >r r> with-input-stream ; inline + [ ] dip with-input-stream ; inline : file-contents ( path encoding -- str ) contents ; : with-file-writer ( path encoding quot -- ) - >r r> with-output-stream ; inline + [ ] dip with-output-stream ; inline : set-file-lines ( seq path encoding -- ) [ [ print ] each ] with-file-writer ; @@ -41,7 +41,7 @@ HOOK: (file-appender) io-backend ( path -- stream ) [ write ] with-file-writer ; : with-file-appender ( path encoding quot -- ) - >r r> with-output-stream ; inline + [ ] dip with-output-stream ; inline ! Pathnames : path-separator? ( ch -- ? ) os windows? "/\\" "/" ? member? ; @@ -127,13 +127,13 @@ PRIVATE> { [ dup head.? ] [ rest trim-left-separators append-path ] } { [ dup head..? ] [ 2 tail trim-left-separators - >r parent-directory r> append-path + [ parent-directory ] dip append-path ] } { [ over absolute-path? over first path-separator? and ] [ - >r 2 head r> append + [ 2 head ] dip append ] } [ - >r trim-right-separators "/" r> + [ trim-right-separators "/" ] dip trim-left-separators 3append ] } cond ; @@ -166,7 +166,7 @@ HOOK: make-link io-backend ( target symlink -- ) HOOK: read-link io-backend ( symlink -- path ) : copy-link ( target symlink -- ) - >r read-link r> make-link ; + [ read-link ] dip make-link ; SYMBOL: +regular-file+ SYMBOL: +directory+ @@ -228,7 +228,7 @@ M: object normalize-path ( path -- path' ) (normalize-path) current-directory set ; : with-directory ( path quot -- ) - >r (normalize-path) current-directory r> with-variable ; inline + [ (normalize-path) current-directory ] dip with-variable ; inline ! Creating directories HOOK: make-directory io-backend ( path -- ) diff --git a/core/io/io.factor b/core/io/io.factor index c50fc6f46c..d7d4edf49f 100644 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -69,7 +69,7 @@ SYMBOL: error-stream [ ] cleanup ; inline : tabular-output ( style quot -- ) - swap >r { } make r> output-stream get stream-write-table ; inline + swap [ { } make ] dip output-stream get stream-write-table ; inline : with-row ( quot -- ) { } make , ; inline @@ -89,8 +89,8 @@ SYMBOL: error-stream ] if ; inline : with-nesting ( style quot -- ) - >r output-stream get make-block-stream - r> with-output-stream ; inline + [ output-stream get make-block-stream ] dip + with-output-stream ; inline : print ( string -- ) output-stream get stream-print ; diff --git a/core/io/streams/byte-array/byte-array.factor b/core/io/streams/byte-array/byte-array.factor index 28d789d66f..9d89c3d814 100644 --- a/core/io/streams/byte-array/byte-array.factor +++ b/core/io/streams/byte-array/byte-array.factor @@ -6,11 +6,11 @@ IN: io.streams.byte-array 512 swap ; : with-byte-writer ( encoding quot -- byte-array ) - >r r> [ output-stream get ] compose with-output-stream* + [ ] dip [ output-stream get ] compose with-output-stream* dup encoder? [ stream>> ] when >byte-array ; inline : ( byte-array encoding -- stream ) - >r >byte-vector dup reverse-here r> ; + [ >byte-vector dup reverse-here ] dip ; : with-byte-reader ( byte-array encoding quot -- ) - >r r> with-input-stream* ; inline + [ ] dip with-input-stream* ; inline diff --git a/core/io/streams/nested/nested.factor b/core/io/streams/nested/nested.factor index bb6a7a9111..a155f842af 100644 --- a/core/io/streams/nested/nested.factor +++ b/core/io/streams/nested/nested.factor @@ -56,7 +56,7 @@ M: style-stream stream-write [ style>> ] [ stream>> ] bi stream-format ; M: style-stream stream-write1 - >r 1string r> stream-write ; + [ 1string ] dip stream-write ; M: style-stream make-span-stream do-nested-style make-span-stream ; diff --git a/core/io/streams/string/string.factor b/core/io/streams/string/string.factor index 10d8f7d947..57c0cb37e8 100644 --- a/core/io/streams/string/string.factor +++ b/core/io/streams/string/string.factor @@ -24,7 +24,7 @@ M: null-encoding decode-char drop stream-read1 ; ] unless ; : map-last ( seq quot -- seq ) - >r dup length [ zero? ] r> compose 2map ; inline + [ dup length ] dip [ 0 = ] prepose 2map ; inline PRIVATE> @@ -75,7 +75,7 @@ M: growable stream-read-partial >sbuf dup reverse-here null-encoding ; : with-string-reader ( str quot -- ) - >r r> with-input-stream ; inline + [ ] dip with-input-stream ; inline INSTANCE: growable plain-writer diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 40094d5589..31798c9295 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -29,12 +29,6 @@ HELP: spin $shuffle ; HELP: roll $shuffle ; HELP: -roll $shuffle ; -HELP: >r ( x -- ) -{ $values { "x" object } } { $description "Moves the top of the data stack to the retain stack." } ; - -HELP: r> ( -- x ) -{ $values { "x" object } } { $description "Moves the top of the retain stack to the data stack." } ; - HELP: datastack ( -- ds ) { $values { "ds" array } } { $description "Outputs an array containing a copy of the data stack contents right before the call to this word, with the top of the stack at the end of the array." } ; @@ -212,7 +206,10 @@ HELP: 3slip HELP: keep { $values { "quot" { $quotation "( x -- )" } } { "x" object } } -{ $description "Call a quotation with a value on the stack, restoring the value when the quotation returns." } ; +{ $description "Call a quotation with a value on the stack, restoring the value when the quotation returns." } +{ $examples + { $example "USING: arrays kernel prettyprint ;" "2 \"greetings\" [ ] keep 2array ." "{ { \"greetings\" \"greetings\" } \"greetings\" }" } +} ; HELP: 2keep { $values { "quot" { $quotation "( x y -- )" } } { "x" object } { "y" object } } @@ -347,7 +344,7 @@ HELP: bi* "The following two lines are equivalent:" { $code "[ p ] [ q ] bi*" - ">r p r> q" + "[ p ] dip q" } } ; @@ -358,7 +355,7 @@ HELP: 2bi* "The following two lines are equivalent:" { $code "[ p ] [ q ] 2bi*" - ">r >r p r> r> q" + "[ p ] 2dip q" } } ; @@ -369,7 +366,7 @@ HELP: tri* "The following two lines are equivalent:" { $code "[ p ] [ q ] [ r ] tri*" - ">r >r p r> q r> r" + "[ [ p ] dip q ] dip r" } } ; @@ -380,7 +377,7 @@ HELP: bi@ "The following two lines are equivalent:" { $code "[ p ] bi@" - ">r p r> p" + "[ p ] dip p" } "The following two lines are also equivalent:" { $code @@ -396,7 +393,7 @@ HELP: 2bi@ "The following two lines are equivalent:" { $code "[ p ] 2bi@" - ">r >r p r> r> p" + "[ p ] 2dip p" } "The following two lines are also equivalent:" { $code @@ -412,7 +409,7 @@ HELP: tri@ "The following two lines are equivalent:" { $code "[ p ] tri@" - ">r >r p r> p r> p" + "[ [ p ] dip p ] dip p" } "The following two lines are also equivalent:" { $code @@ -565,11 +562,7 @@ HELP: compose { $values { "quot1" callable } { "quot2" callable } { "compose" compose } } { $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } " followed by " { $snippet "quot2" } "." } { $notes - "The two quotations must leave the retain stack in the same state on exit as it was on entry, so the following code is not allowed:" - { $code - "[ 3 >r ] [ r> . ] compose" - } - "Except for this restriction, the following two lines are equivalent:" + "The following two lines are equivalent:" { $code "compose call" "append call" @@ -589,15 +582,7 @@ HELP: 3compose { $values { "quot1" callable } { "quot2" callable } { "quot3" callable } { "compose" compose } } { $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } ", " { $snippet "quot2" } " and then " { $snippet "quot3" } "." } { $notes - "The three quotations must leave the retain stack in the same state on exit as it was on entry, so for example, the following code is not allowed:" - { $code - "[ >r ] swap [ r> ] 3compose" - } - "The correct way to achieve the effect of the above is the following:" - { $code - "[ dip ] curry" - } - "Excepting the retain stack restriction, the following two lines are equivalent:" + "The following two lines are equivalent:" { $code "3compose call" "3append call" @@ -608,16 +593,15 @@ HELP: 3compose HELP: dip { $values { "x" object } { "quot" quotation } } { $description "Calls " { $snippet "quot" } " with " { $snippet "obj" } " hidden on the retain stack." } -{ $notes "The following are equivalent:" - { $code ">r foo bar r>" } - { $code "[ foo bar ] dip" } +{ $examples + { $example "USING: arrays kernel math prettyprint ;" "10 20 30 [ / ] dip 2array ." "{ 1/2 30 }" } } ; HELP: 2dip { $values { "x" object } { "y" object } { "quot" quotation } } { $description "Calls " { $snippet "quot" } " with " { $snippet "obj1" } " and " { $snippet "obj2" } " hidden on the retain stack." } { $notes "The following are equivalent:" - { $code ">r >r foo bar r> r>" } + { $code "[ [ foo bar ] dip ] dip" } { $code "[ foo bar ] 2dip" } } ; @@ -625,7 +609,7 @@ HELP: 3dip { $values { "x" object } { "y" object } { "z" object } { "quot" quotation } } { $description "Calls " { $snippet "quot" } " with " { $snippet "obj1" } ", " { $snippet "obj2" } " and " { $snippet "obj3" } " hidden on the retain stack." } { $notes "The following are equivalent:" - { $code ">r >r >r foo bar r> r> r>" } + { $code "[ [ [ foo bar ] dip ] dip ] dip" } { $code "[ foo bar ] 3dip" } } ; @@ -692,15 +676,7 @@ $nl { $subsection -rot } { $subsection spin } { $subsection roll } -{ $subsection -roll } -"Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using the following two words:" -{ $subsection >r } -{ $subsection r> } -"The top of the data stack is ``hidden'' between " { $link >r } " and " { $link r> } ":" -{ $example "1 2 3 >r .s r>" "1\n2" } -"Usages of " { $link >r } " and " { $link r> } " must be balanced within a single quotation; quotations are not permitted to pop retain stack elements they did not push, or leave elements on the retain stack after returning." -$nl -"The " { $link "inference" } " tool checks retain stack usage. The " { $link "slip-keep-combinators" } " combinators abstract out common retain stack usage patterns." ; +{ $subsection -roll } ; ARTICLE: "cleave-shuffle-equivalence" "Expressing shuffle words with cleave combinators" "Cleave combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to cleave combinators are discussed in the documentation for " { $link bi } ", " { $link 2bi } ", " { $link 3bi } ", " { $link tri } ", " { $link 2tri } " and " { $link 3tri } "." @@ -793,14 +769,10 @@ $nl { $subsection tri* } "Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:" { $code - "! First alternative; uses retain stack explicitly" - ">r >r 1 +" - "r> 1 -" - "r> 2 *" + "! First alternative; uses dip" + "[ [ 1 + ] dip 1 - dip ] 2 *" "! Second alternative: uses tri*" - "[ 1 + ]" - "[ 1 - ]" - "[ 2 * ] tri*" + "[ 1 + ] [ 1 - ] [ 2 * ] tri*" } $nl @@ -819,7 +791,9 @@ $nl { $subsection both? } { $subsection either? } ; -ARTICLE: "slip-keep-combinators" "The dip, slip and keep combinators" +ARTICLE: "slip-keep-combinators" "Retain stack combinators" +"Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using a set of combinators." +$nl "The dip combinators invoke the quotation at the top of the stack, hiding the values underneath:" { $subsection dip } { $subsection 2dip } @@ -851,7 +825,7 @@ ARTICLE: "implementing-combinators" "Implementing combinators" "These words are used to implement combinators. Note that combinator definitions must be followed by the " { $link POSTPONE: inline } " declaration in order to compile in the optimizing compiler; for example:" { $code ": keep ( x quot -- x )" - " over >r call r> ; inline" + " over [ call ] dip ; inline" } "Word inlining is documented in " { $link "declarations" } "." ; @@ -935,10 +909,10 @@ ARTICLE: "dataflow" "Data and control flow" { $subsection "booleans" } { $subsection "shuffle-words" } "A central concept in Factor is that of a " { $emphasis "combinator" } ", which is a word taking code as input." +{ $subsection "slip-keep-combinators" } { $subsection "cleave-combinators" } { $subsection "spread-combinators" } { $subsection "apply-combinators" } -{ $subsection "slip-keep-combinators" } { $subsection "conditionals" } { $subsection "compositional-combinators" } { $subsection "combinators" } diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index 8a51d45447..6619d331f1 100644 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -106,11 +106,11 @@ IN: kernel.tests ! Regression : (loop) ( a b c d -- ) - >r pick r> swap >r pick r> swap - < [ >r >r >r 1+ r> r> r> (loop) ] [ 2drop 2drop ] if ; inline + [ pick ] dip swap [ pick ] dip swap + < [ [ 1+ ] 3dip (loop) ] [ 2drop 2drop ] if ; inline : loop ( obj obj -- ) - H{ } values swap >r dup length swap r> 0 -roll (loop) ; + H{ } values swap [ dup length swap ] dip 0 -roll (loop) ; [ loop ] must-fail diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 18bead109d..75d4f24bfd 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -3,12 +3,16 @@ USING: kernel.private slots.private classes.tuple.private ; IN: kernel +DEFER: dip +DEFER: 2dip +DEFER: 3dip + ! Stack stuff : spin ( x y z -- z y x ) swap rot ; inline -: roll ( x y z t -- y z t x ) >r rot r> swap ; inline +: roll ( x y z t -- y z t x ) [ rot ] dip swap ; inline -: -roll ( x y z t -- t x y z ) swap >r -rot r> ; inline +: -roll ( x y z t -- t x y z ) swap [ -rot ] dip ; inline : 2over ( x y z -- x y z x y ) pick pick ; inline @@ -49,56 +53,56 @@ DEFER: if pick [ roll 2drop call ] [ 2nip call ] if ; inline ! Slippers -: slip ( quot x -- x ) >r call r> ; inline +: slip ( quot x -- x ) [ call ] dip ; -: 2slip ( quot x y -- x y ) >r >r call r> r> ; inline +: 2slip ( quot x y -- x y ) [ call ] 2dip ; -: 3slip ( quot x y z -- x y z ) >r >r >r call r> r> r> ; inline +: 3slip ( quot x y z -- x y z ) [ call ] 3dip ; : dip ( x quot -- x ) swap slip ; inline -: 2dip ( x y quot -- x y ) swap >r dip r> ; inline +: 2dip ( x y quot -- x y ) -rot 2slip ; inline -: 3dip ( x y z quot -- x y z ) swap >r 2dip r> ; inline +: 3dip ( x y z quot -- x y z ) -roll 3slip ; inline ! Keepers -: keep ( x quot -- x ) dupd dip ; inline +: keep ( x quot -- x ) over slip ; inline -: 2keep ( x y quot -- x y ) >r 2dup r> 2dip ; inline +: 2keep ( x y quot -- x y ) [ 2dup ] dip 2dip ; inline -: 3keep ( x y z quot -- x y z ) >r 3dup r> 3dip ; inline +: 3keep ( x y z quot -- x y z ) [ 3dup ] dip 3dip ; inline ! Cleavers : bi ( x p q -- ) - >r keep r> call ; inline + [ keep ] dip call ; inline : tri ( x p q r -- ) - >r >r keep r> keep r> call ; inline + [ [ keep ] dip keep ] dip call ; inline ! Double cleavers : 2bi ( x y p q -- ) - >r 2keep r> call ; inline + [ 2keep ] dip call ; inline : 2tri ( x y p q r -- ) - >r >r 2keep r> 2keep r> call ; inline + [ [ 2keep ] dip 2keep ] dip call ; inline ! Triple cleavers : 3bi ( x y z p q -- ) - >r 3keep r> call ; inline + [ 3keep ] dip call ; inline : 3tri ( x y z p q r -- ) - >r >r 3keep r> 3keep r> call ; inline + [ [ 3keep ] dip 3keep ] dip call ; inline ! Spreaders : bi* ( x y p q -- ) - >r dip r> call ; inline + [ dip ] dip call ; inline : tri* ( x y z p q r -- ) - >r >r 2dip r> dip r> call ; inline + [ [ 2dip ] dip dip ] dip call ; inline ! Double spreaders : 2bi* ( w x y z p q -- ) - >r 2dip r> call ; inline + [ 2dip ] dip call ; inline ! Appliers : bi@ ( x y quot -- ) @@ -115,8 +119,8 @@ DEFER: if dup slip swap [ loop ] [ drop ] if ; inline recursive : while ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- ) - >r >r dup slip r> r> roll - [ >r tuck 2slip r> while ] + [ dup slip ] 2dip roll + [ [ tuck 2slip ] dip while ] [ 2nip call ] if ; inline recursive ! Object protocol @@ -182,7 +186,7 @@ GENERIC: boa ( ... class -- tuple ) : either? ( x y quot -- ? ) bi@ or ; inline : most ( x y quot -- z ) - >r 2dup r> call [ drop ] [ nip ] if ; inline + [ 2dup ] dip call [ drop ] [ nip ] if ; inline ! Error handling -- defined early so that other files can ! throw errors before continuations are loaded diff --git a/core/lexer/lexer.factor b/core/lexer/lexer.factor index 0d6f566d36..c36e6da190 100644 --- a/core/lexer/lexer.factor +++ b/core/lexer/lexer.factor @@ -23,7 +23,7 @@ TUPLE: lexer text line line-text line-length column ; lexer new-lexer ; : skip ( i seq ? -- n ) - >r tuck r> + [ tuck ] dip [ swap CHAR: \s eq? xor ] curry find-from drop [ ] [ length ] ?if ; diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index 74a93d39bd..fcb1b65d80 100644 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -25,7 +25,7 @@ M: fixnum + fixnum+ ; M: fixnum - fixnum- ; M: fixnum * fixnum* ; M: fixnum /i fixnum/i ; -M: fixnum /f >r >float r> >float float/f ; +M: fixnum /f [ >float ] dip >float float/f ; M: fixnum mod fixnum-mod ; @@ -41,7 +41,7 @@ M: fixnum bitnot fixnum-bitnot ; M: fixnum bit? neg shift 1 bitand 0 > ; : (fixnum-log2) ( accum n -- accum ) - dup 1 number= [ drop ] [ >r 1+ r> 2/ (fixnum-log2) ] if ; + dup 1 number= [ drop ] [ [ 1+ ] [ 2/ ] bi* (fixnum-log2) ] if ; inline recursive M: fixnum (log2) 0 swap (fixnum-log2) ; @@ -94,7 +94,7 @@ M: bignum (log2) bignum-log2 ; : pre-scale ( num den -- scale shifted-num scaled-den ) 2dup [ log2 ] bi@ - - tuck [ neg 54 + shift ] [ >r scale-denonimator r> + ] 2bi* + tuck [ neg 54 + shift ] [ [ scale-denonimator ] dip + ] 2bi* -rot ; inline ! Second step: loop @@ -103,7 +103,7 @@ M: bignum (log2) bignum-log2 ; : /f-loop ( scale mantissa den -- scale' fraction-and-guard rem ) [ 2dup /i log2 53 > ] - [ >r shift-mantissa r> ] + [ [ shift-mantissa ] dip ] [ ] while /mod ; inline ! Third step: post-scaling @@ -111,7 +111,7 @@ M: bignum (log2) bignum-log2 ; 52 2^ 1- bitand 1022 52 shift bitor bits>double ; inline : scale-float ( scale mantissa -- float' ) - >r dup 0 < [ neg 2^ recip ] [ 2^ ] if r> * ; inline + [ dup 0 < [ neg 2^ recip ] [ 2^ ] if ] dip * ; inline : post-scale ( scale mantissa -- n ) 2/ dup log2 52 > [ shift-mantissa ] when diff --git a/core/math/math.factor b/core/math/math.factor index 6efdd53825..5c53d99cff 100644 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -107,7 +107,7 @@ M: float fp-infinity? ( float -- ? ) 2dup >= [ drop ] [ - >r 1 shift r> (next-power-of-2) + [ 1 shift ] dip (next-power-of-2) ] if ; : next-power-of-2 ( m -- n ) 2 swap (next-power-of-2) ; foldable @@ -122,13 +122,13 @@ M: float fp-infinity? ( float -- ? ) : iterate-prep 0 -rot ; inline -: if-iterate? >r >r 2over < r> r> if ; inline +: if-iterate? [ 2over < ] 2dip if ; inline : iterate-step ( i n quot -- i n quot ) #! Apply quot to i, keep i and quot, hide n. - swap >r 2dup 2slip r> swap ; inline + swap [ 2dup 2slip ] dip swap ; inline -: iterate-next >r >r 1+ r> r> ; inline +: iterate-next [ 1+ ] 2dip ; inline PRIVATE> @@ -167,6 +167,6 @@ PRIVATE> 2dup 2slip rot [ drop ] [ - >r 1- r> find-last-integer + [ 1- ] dip find-last-integer ] if ] if ; inline recursive diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 0134693761..8fc6e6dd9e 100644 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -51,12 +51,12 @@ SYMBOL: negative? : (base>) ( str -- n ) radix get base> ; : whole-part ( str -- m n ) - sign split1 >r (base>) r> + sign split1 [ (base>) ] dip dup [ (base>) ] [ drop 0 swap ] if ; : string>ratio ( str -- a/b ) "-" ?head dup negative? set swap - "/" split1 (base>) >r whole-part r> + "/" split1 (base>) [ whole-part ] dip 3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if ; : valid-digits? ( seq -- ? ) @@ -137,7 +137,7 @@ M: ratio >base { { [ CHAR: e over member? ] - [ "e" split1 >r fix-float "e" r> 3append ] + [ "e" split1 [ fix-float "e" ] dip 3append ] } { [ CHAR: . over member? ] [ ] diff --git a/core/namespaces/namespaces.factor b/core/namespaces/namespaces.factor index 20400f4e54..427c294759 100644 --- a/core/namespaces/namespaces.factor +++ b/core/namespaces/namespaces.factor @@ -23,7 +23,7 @@ PRIVATE> : off ( variable -- ) f swap set ; inline : get-global ( variable -- value ) global at ; : set-global ( value variable -- ) global set-at ; -: change ( variable quot -- ) >r dup get r> rot slip set ; inline +: change ( variable quot -- ) [ [ get ] keep ] dip dip set ; inline : +@ ( n variable -- ) [ 0 or + ] change ; : inc ( variable -- ) 1 swap +@ ; inline : dec ( variable -- ) -1 swap +@ ; inline @@ -37,4 +37,4 @@ PRIVATE> H{ } clone >n call ndrop ; inline : with-variable ( value key quot -- ) - >r associate >n r> call ndrop ; inline + [ associate >n ] dip call ndrop ; inline diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 1728b471e2..42e4e77055 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -10,7 +10,7 @@ IN: parser : location ( -- loc ) file get lexer get line>> 2dup and - [ >r path>> r> 2array ] [ 2drop f ] if ; + [ [ path>> ] dip 2array ] [ 2drop f ] if ; : save-location ( definition -- ) location remember-definition ; @@ -140,7 +140,7 @@ ERROR: staging-violation word ; } cond ; : (parse-until) ( accum end -- accum ) - dup >r parse-step [ r> (parse-until) ] [ r> drop ] if ; + [ parse-step ] keep swap [ (parse-until) ] [ drop ] if ; : parse-until ( end -- vec ) 100 swap (parse-until) ; @@ -156,7 +156,7 @@ ERROR: staging-violation word ; lexer-factory get call (parse-lines) ; : parse-literal ( accum end quot -- accum ) - >r parse-until r> call parsed ; inline + [ parse-until ] dip call parsed ; inline : parse-definition ( -- quot ) \ ; parse-until >quotation ; diff --git a/core/quotations/quotations.factor b/core/quotations/quotations.factor index 31e5e4753d..2df11d4858 100644 --- a/core/quotations/quotations.factor +++ b/core/quotations/quotations.factor @@ -49,7 +49,10 @@ M: wrapper literalize ; M: curry length quot>> length 1+ ; M: curry nth - over zero? [ nip obj>> literalize ] [ >r 1- r> quot>> nth ] if ; + over 0 = + [ nip obj>> literalize ] + [ [ 1- ] dip quot>> nth ] + if ; INSTANCE: curry immutable-sequence diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index cd413adb90..832de612dd 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -16,7 +16,7 @@ GENERIC: like ( seq exemplar -- newseq ) flushable GENERIC: clone-like ( seq exemplar -- newseq ) flushable : new-like ( len exemplar quot -- seq ) - over >r >r new-sequence r> call r> like ; inline + over [ [ new-sequence ] dip call ] dip like ; inline M: sequence like drop ; @@ -111,14 +111,14 @@ INSTANCE: integer immutable-sequence [ first3-unsafe 3 ] [ nth-unsafe ] bi ; inline : exchange-unsafe ( m n seq -- ) - [ tuck nth-unsafe >r nth-unsafe r> ] 3keep tuck - >r >r set-nth-unsafe r> r> set-nth-unsafe ; inline + [ tuck [ nth-unsafe ] 2bi@ ] + [ tuck [ set-nth-unsafe ] 2bi@ ] 3bi ; inline : (head) ( seq n -- from to seq ) 0 spin ; inline : (tail) ( seq n -- from to seq ) over length rot ; inline -: from-end >r dup length r> - ; inline +: from-end [ dup length ] dip - ; inline : (2sequence) tuck 1 swap set-nth-unsafe @@ -188,7 +188,7 @@ TUPLE: slice { seq read-only } ; : collapse-slice ( m n slice -- m' n' seq ) - [ from>> ] [ seq>> ] bi >r tuck + >r + r> r> ; inline + [ from>> ] [ seq>> ] bi [ tuck [ + ] 2bi@ ] dip ; inline ERROR: slice-error from to seq reason ; @@ -253,12 +253,12 @@ INSTANCE: repetition immutable-sequence : prepare-subseq ( from to seq -- dst i src j n ) #! The check-length call forces partial dispatch - [ >r swap - r> new-sequence dup 0 ] 3keep + [ [ swap - ] dip new-sequence dup 0 ] 3keep -rot drop roll length check-length ; inline : check-copy ( src n dst -- ) over 0 < [ bounds-error ] when - >r swap length + r> lengthen ; inline + [ swap length + ] dip lengthen ; inline PRIVATE> @@ -279,11 +279,11 @@ PRIVATE> : copy ( src i dst -- ) #! The check-length call forces partial dispatch - pick length check-length >r 3dup check-copy spin 0 r> + pick length check-length [ 3dup check-copy spin 0 ] dip (copy) drop ; inline M: sequence clone-like - >r dup length r> new-sequence [ 0 swap copy ] keep ; + [ dup length ] dip new-sequence [ 0 swap copy ] keep ; M: immutable-sequence clone-like like ; @@ -315,7 +315,7 @@ PRIVATE> : 3append ( seq1 seq2 seq3 -- newseq ) pick 3append-as ; : change-nth ( i seq quot -- ) - [ >r nth r> call ] 3keep drop set-nth ; inline + [ [ nth ] dip call ] 3keep drop set-nth ; inline : min-length ( seq1 seq2 -- n ) [ length ] bi@ min ; inline @@ -324,32 +324,32 @@ PRIVATE> r dup length swap [ nth-unsafe ] curry r> compose ; inline + [ dup length swap [ nth-unsafe ] curry ] dip compose ; inline : (collect) ( quot into -- quot' ) - [ >r keep r> set-nth-unsafe ] 2curry ; inline + [ [ keep ] dip set-nth-unsafe ] 2curry ; inline : collect ( n quot into -- ) (collect) each-integer ; inline : map-into ( seq quot into -- ) - >r (each) r> collect ; inline + [ (each) ] dip collect ; inline : 2nth-unsafe ( n seq1 seq2 -- elt1 elt2 ) - >r over r> nth-unsafe >r nth-unsafe r> ; inline + [ over ] dip nth-unsafe [ nth-unsafe ] dip ; inline : (2each) ( seq1 seq2 quot -- n quot' ) - >r [ min-length ] 2keep r> - [ >r 2nth-unsafe r> call ] 3curry ; inline + [ [ min-length ] 2keep ] dip + [ [ 2nth-unsafe ] dip call ] 3curry ; inline : 2map-into ( seq1 seq2 quot into -- newseq ) - >r (2each) r> collect ; inline + [ (2each) ] dip collect ; inline : finish-find ( i seq -- i elt ) over [ dupd nth-unsafe ] [ drop f ] if ; inline : (find) ( seq quot quot' -- i elt ) - pick >r >r (each) r> call r> finish-find ; inline + pick [ [ (each) ] dip call ] dip finish-find ; inline : (find-from) ( n seq quot quot' -- i elt ) [ 2dup bounds-check? ] 2dip @@ -373,7 +373,7 @@ PRIVATE> swapd each ; inline : map-as ( seq quot exemplar -- newseq ) - >r over length r> [ [ map-into ] keep ] new-like ; inline + [ over length ] dip [ [ map-into ] keep ] new-like ; inline : map ( seq quot -- newseq ) over map-as ; inline @@ -382,7 +382,7 @@ PRIVATE> [ drop ] prepose map ; inline : replicate-as ( seq quot exemplar -- newseq ) - >r [ drop ] prepose r> map-as ; inline + [ [ drop ] prepose ] dip map-as ; inline : change-each ( seq quot -- ) over map-into ; inline @@ -394,13 +394,13 @@ PRIVATE> (2each) each-integer ; inline : 2reverse-each ( seq1 seq2 quot -- ) - >r [ ] bi@ r> 2each ; inline + [ [ ] bi@ ] dip 2each ; inline : 2reduce ( seq1 seq2 identity quot -- result ) - >r -rot r> 2each ; inline + [ -rot ] dip 2each ; inline : 2map-as ( seq1 seq2 quot exemplar -- newseq ) - >r 2over min-length r> + [ 2over min-length ] dip [ [ 2map-into ] keep ] new-like ; inline : 2map ( seq1 seq2 quot -- newseq ) @@ -422,49 +422,49 @@ PRIVATE> [ nip find-last-integer ] (find-from) ; inline : find-last ( seq quot -- i elt ) - [ >r 1- r> find-last-integer ] (find) ; inline + [ [ 1- ] dip find-last-integer ] (find) ; inline : all? ( seq quot -- ? ) (each) all-integers? ; inline : push-if ( elt quot accum -- ) - >r keep r> rot [ push ] [ 2drop ] if ; inline + [ keep ] dip rot [ push ] [ 2drop ] if ; inline : pusher ( quot -- quot accum ) V{ } clone [ [ push-if ] 2curry ] keep ; inline : filter ( seq quot -- subseq ) - over >r pusher >r each r> r> like ; inline + over [ pusher [ each ] dip ] dip like ; inline : push-either ( elt quot accum1 accum2 -- ) - >r >r keep swap r> r> ? push ; inline + [ keep swap ] 2dip ? push ; inline : 2pusher ( quot -- quot accum1 accum2 ) V{ } clone V{ } clone [ [ push-either ] 3curry ] 2keep ; inline : partition ( seq quot -- trueseq falseseq ) - over >r 2pusher >r >r each r> r> r> tuck [ like ] 2bi@ ; inline + over [ 2pusher [ each ] 2dip ] dip tuck [ like ] 2bi@ ; inline : monotonic? ( seq quot -- ? ) - >r dup length 1- swap r> (monotonic) all? ; inline + [ dup length 1- swap ] dip (monotonic) all? ; inline : interleave ( seq between quot -- ) - [ (interleave) ] 2curry >r dup length swap r> 2each ; inline + [ (interleave) ] 2curry [ dup length swap ] dip 2each ; inline : accumulator ( quot -- quot' vec ) V{ } clone [ [ push ] curry compose ] keep ; inline : produce-as ( pred quot tail exemplar -- seq ) - >r swap accumulator >r swap while r> r> like ; inline + [ swap accumulator [ swap while ] dip ] dip like ; inline : produce ( pred quot tail -- seq ) { } produce-as ; inline : follow ( obj quot -- seq ) - >r [ dup ] r> [ keep ] curry [ ] produce nip ; inline + [ dup ] swap [ keep ] curry [ ] produce nip ; inline : prepare-index ( seq quot -- seq n quot ) - >r dup length r> ; inline + [ dup length ] dip ; inline : each-index ( seq quot -- ) prepare-index 2each ; inline @@ -518,9 +518,9 @@ PRIVATE> : cache-nth ( i seq quot -- elt ) 2over ?nth dup [ - >r 3drop r> + [ 3drop ] dip ] [ - drop swap >r over >r call dup r> r> set-nth + drop swap [ over [ call dup ] dip ] dip set-nth ] if ; inline : mismatch ( seq1 seq2 -- i ) @@ -575,14 +575,14 @@ PRIVATE> [ eq? not ] with filter-here ; : prefix ( seq elt -- newseq ) - over >r over length 1+ r> [ + over [ over length 1+ ] dip [ [ 0 swap set-nth-unsafe ] keep [ 1 swap copy ] keep ] new-like ; : suffix ( seq elt -- newseq ) - over >r over length 1+ r> [ - [ >r over length r> set-nth-unsafe ] keep + over [ over length 1+ ] dip [ + [ [ over length ] dip set-nth-unsafe ] keep [ 0 swap copy ] keep ] new-like ; @@ -596,7 +596,7 @@ PRIVATE> 2over = [ 2drop 2drop ] [ - [ >r 2over + pick r> move >r 1+ r> ] keep + [ [ 2over + pick ] dip move [ 1+ ] dip ] keep move-backward ] if ; @@ -604,15 +604,15 @@ PRIVATE> 2over = [ 2drop 2drop ] [ - [ >r pick >r dup dup r> + swap r> move 1- ] keep + [ [ pick [ dup dup ] dip + swap ] dip move 1- ] keep move-forward ] if ; : (open-slice) ( shift from to seq ? -- ) [ - >r [ 1- ] bi@ r> move-forward + [ [ 1- ] bi@ ] dip move-forward ] [ - >r >r over - r> r> move-backward + [ over - ] 2dip move-backward ] if ; PRIVATE> @@ -621,19 +621,19 @@ PRIVATE> pick 0 = [ 3drop ] [ - pick over length + over >r >r - pick 0 > >r [ length ] keep r> (open-slice) - r> r> set-length + pick over length + over + [ pick 0 > [ [ length ] keep ] dip (open-slice) ] 2dip + set-length ] if ; : delete-slice ( from to seq -- ) - check-slice >r over >r - r> r> open-slice ; + check-slice [ over [ - ] dip ] dip open-slice ; : delete-nth ( n seq -- ) - >r dup 1+ r> delete-slice ; + [ dup 1+ ] dip delete-slice ; : replace-slice ( new from to seq -- ) - [ >r >r dup pick length + r> - over r> open-slice ] keep + [ [ [ dup pick length + ] dip - over ] dip open-slice ] keep copy ; : remove-nth ( n seq -- seq' ) @@ -652,7 +652,7 @@ PRIVATE> : reverse-here ( seq -- ) dup length dup 2/ [ - >r 2dup r> + [ 2dup ] dip tuck - 1- rot exchange-unsafe ] each 2drop ; @@ -679,7 +679,7 @@ PRIVATE> r dup sum-lengths swap length 1 [-] r> length * + ; + [ dup sum-lengths swap length 1 [-] ] dip length * + ; PRIVATE> @@ -735,12 +735,12 @@ PRIVATE> >fixnum { [ drop nip ] [ 2drop first ] - [ >r drop first2 r> call ] - [ >r drop first3 r> bi@ ] + [ [ drop first2 ] dip call ] + [ [ drop first3 ] dip bi@ ] } dispatch ] [ drop - >r >r halves r> r> + [ halves ] 2dip [ [ binary-reduce ] 2curry bi@ ] keep call ] if ; inline recursive @@ -755,7 +755,7 @@ PRIVATE> : (start) ( subseq seq n -- subseq seq ? ) pick length [ - >r 3dup r> [ + swap nth-unsafe ] keep rot nth-unsafe = + [ 3dup ] dip [ + swap nth-unsafe ] keep rot nth-unsafe = ] all? nip ; inline PRIVATE> @@ -763,7 +763,7 @@ PRIVATE> : start* ( subseq seq n -- i ) pick length pick length swap - 1+ [ (start) ] find-from - swap >r 3drop r> ; + swap [ 3drop ] dip ; : start ( subseq seq -- i ) 0 start* ; inline @@ -771,7 +771,7 @@ PRIVATE> : drop-prefix ( seq1 seq2 -- slice1 slice2 ) 2dup mismatch [ 2dup min-length ] unless* - tuck tail-slice >r tail-slice r> ; + tuck [ tail-slice ] 2bi@ ; : unclip ( seq -- rest first ) [ rest ] [ first ] bi ; @@ -801,14 +801,14 @@ PRIVATE> inline : trim-left-slice ( seq quot -- slice ) - over >r [ not ] compose find drop r> swap + over [ [ not ] compose find drop ] dip swap [ tail-slice ] [ dup length tail-slice ] if* ; inline : trim-left ( seq quot -- newseq ) over [ trim-left-slice ] dip like ; inline : trim-right-slice ( seq quot -- slice ) - over >r [ not ] compose find-last drop r> swap + over [ [ not ] compose find-last drop ] dip swap [ 1+ head-slice ] [ 0 head-slice ] if* ; inline : trim-right ( seq quot -- newseq ) diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 72c79928cb..35aa49d053 100644 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -3,7 +3,7 @@ USING: arrays byte-arrays kernel kernel.private math namespaces make sequences strings words effects generic generic.standard classes classes.algebra slots.private combinators accessors -words sequences.private assocs alien ; +words sequences.private assocs alien quotations ; IN: slots TUPLE: slot-spec name offset class initial read-only ; @@ -23,7 +23,7 @@ PREDICATE: writer < word "writer" word-prop ; 3bi ; : create-accessor ( name effect -- word ) - >r "accessors" create dup r> + [ "accessors" create dup ] dip "declared-effect" set-word-prop ; : reader-quot ( slot-spec -- quot ) @@ -59,7 +59,7 @@ ERROR: bad-slot-value value class ; offset>> , \ set-slot , ; : writer-quot/coerce ( slot-spec -- ) - [ \ >r , class>> "coercer" word-prop % \ r> , ] + [ class>> "coercer" word-prop [ dip ] curry % ] [ offset>> , \ set-slot , ] bi ; @@ -75,7 +75,7 @@ ERROR: bad-slot-value value class ; bi ; : writer-quot/fixnum ( slot-spec -- ) - [ >r >fixnum r> ] % writer-quot/check ; + [ [ >fixnum ] dip ] % writer-quot/check ; : writer-quot ( slot-spec -- quot ) [ @@ -108,9 +108,9 @@ ERROR: bad-slot-value value class ; : define-changer ( name -- ) dup changer-word dup deferred? [ [ - [ over >r >r ] % - over reader-word , - [ r> call r> swap ] % + \ over , + over reader-word 1quotation + [ dip call ] curry [ dip swap ] curry % swap setter-word , ] [ ] make define-inline ] [ 2drop ] if ; diff --git a/core/sorting/sorting.factor b/core/sorting/sorting.factor index b57e661624..47399b6176 100644 --- a/core/sorting/sorting.factor +++ b/core/sorting/sorting.factor @@ -25,20 +25,20 @@ TUPLE: merge : dump ( from to seq accum -- ) #! Optimize common case where to - from = 1, 2, or 3. - >r >r 2dup swap - r> r> pick 1 = - [ >r >r 2drop r> nth-unsafe r> push ] [ + [ 2dup swap - ] 2dip pick 1 = + [ [ [ 2drop ] dip nth-unsafe ] dip push ] [ pick 2 = [ - >r >r 2drop dup 1+ - r> [ nth-unsafe ] curry bi@ - r> [ push ] curry bi@ + [ + [ 2drop dup 1+ ] dip + [ nth-unsafe ] curry bi@ + ] dip [ push ] curry bi@ ] [ pick 3 = [ - >r >r 2drop dup 1+ dup 1+ - r> [ nth-unsafe ] curry tri@ - r> [ push ] curry tri@ - ] [ - >r nip subseq r> push-all - ] if + [ + [ 2drop dup 1+ dup 1+ ] dip + [ nth-unsafe ] curry tri@ + ] dip [ push ] curry tri@ + ] [ [ nip subseq ] dip push-all ] if ] if ] if ; inline diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor index f2d7593295..29fee2e5c3 100644 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -18,14 +18,14 @@ IN: splitting : split1 ( seq subseq -- before after ) dup pick start dup [ - [ >r over r> head -rot length ] keep + tail + [ [ over ] dip head -rot length ] keep + tail ] [ 2drop f ] if ; : split1-slice ( seq subseq -- before-slice after-slice ) dup pick start dup [ - [ >r over r> head-slice -rot length ] keep + tail-slice + [ [ over ] dip head-slice -rot length ] keep + tail-slice ] [ 2drop f ] if ; diff --git a/core/strings/parser/parser.factor b/core/strings/parser/parser.factor index 2695860a59..cfe5d1a90a 100644 --- a/core/strings/parser/parser.factor +++ b/core/strings/parser/parser.factor @@ -29,10 +29,10 @@ name>char-hook global [ : unicode-escape ( str -- ch str' ) "{" ?head-slice [ CHAR: } over index cut-slice - >r >string name>char-hook get call r> + [ >string name>char-hook get call ] dip rest-slice ] [ - 6 cut-slice >r hex> r> + 6 cut-slice [ hex> ] dip ] if ; : next-escape ( str -- ch str' ) @@ -44,11 +44,11 @@ name>char-hook global [ : (parse-string) ( str -- m ) dup [ "\"\\" member? ] find dup [ - >r cut-slice >r % r> rest-slice r> + [ cut-slice [ % ] dip rest-slice ] dip dup CHAR: " = [ drop from>> ] [ - drop next-escape >r , r> (parse-string) + drop next-escape [ , ] dip (parse-string) ] if ] [ "Unterminated string" throw diff --git a/core/strings/strings.factor b/core/strings/strings.factor index 944286cce5..39628ede98 100644 --- a/core/strings/strings.factor +++ b/core/strings/strings.factor @@ -34,11 +34,11 @@ M: string length length>> ; M: string nth-unsafe - >r >fixnum r> string-nth ; + [ >fixnum ] dip string-nth ; M: string set-nth-unsafe dup reset-string-hashcode - >r >fixnum >r >fixnum r> r> set-string-nth ; + [ [ >fixnum ] dip >fixnum ] dip set-string-nth ; M: string clone (clone) [ clone ] change-aux ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index bbbfff0219..7d3553faee 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -23,7 +23,7 @@ IN: bootstrap.syntax "syntax" lookup t "delimiter" set-word-prop ; : define-syntax ( name quot -- ) - >r "syntax" lookup dup r> define t "parsing" set-word-prop ; + [ "syntax" lookup dup ] dip define t "parsing" set-word-prop ; [ { "]" "}" ";" ">>" } [ define-delimiter ] each @@ -145,9 +145,10 @@ IN: bootstrap.syntax ] define-syntax "INSTANCE:" [ - location >r - scan-word scan-word 2dup add-mixin-instance - r> remember-definition + location [ + scan-word scan-word 2dup add-mixin-instance + + ] dip remember-definition ] define-syntax "PREDICATE:" [ diff --git a/core/vectors/vectors-tests.factor b/core/vectors/vectors-tests.factor index 4f9bba3483..f2e29d79e8 100644 --- a/core/vectors/vectors-tests.factor +++ b/core/vectors/vectors-tests.factor @@ -71,7 +71,7 @@ IN: vectors.tests [ t ] [ V{ 1 2 3 4 } dup underlying>> length - >r clone underlying>> length r> + [ clone underlying>> length ] dip = ] unit-test @@ -91,7 +91,7 @@ IN: vectors.tests [ 4 ] [ 5 V{ 1 2 3 4 5 } index ] unit-test [ t ] [ - 100 >array dup >vector >array >r reverse r> = + 100 >array dup >vector >array [ reverse ] dip = ] unit-test [ fixnum ] [ 1 >bignum V{ } new-sequence length class ] unit-test diff --git a/core/words/words.factor b/core/words/words.factor index 5ac78f1d6a..929161c5d6 100644 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -87,11 +87,11 @@ M: word (quot-uses) over crossref? [ conjoin ] [ 2drop ] if ; M: array (quot-uses) seq-uses ; -M: hashtable (quot-uses) >r >alist r> seq-uses ; +M: hashtable (quot-uses) [ >alist ] dip seq-uses ; M: callable (quot-uses) seq-uses ; -M: wrapper (quot-uses) >r wrapped>> r> (quot-uses) ; +M: wrapper (quot-uses) [ wrapped>> ] dip (quot-uses) ; : quot-uses ( quot -- assoc ) global [ H{ } clone [ (quot-uses) ] keep ] bind ; @@ -239,7 +239,7 @@ ERROR: bad-create name vocab ; dup [ 2nip ] [ drop dup reveal ] if ; : constructor-word ( name vocab -- word ) - >r "<" swap ">" 3append r> create ; + [ "<" swap ">" 3append ] dip create ; PREDICATE: parsing-word < word "parsing" word-prop ; diff --git a/vm/quotations.c b/vm/quotations.c index bf917aeec0..179224f798 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -54,6 +54,27 @@ bool jit_fast_dispatch_p(F_ARRAY *array, CELL i) && array_nth(array,i + 1) == userenv[JIT_DISPATCH_WORD]; } +bool jit_fast_dip_p(F_ARRAY *array, CELL i) +{ + return (i + 2) <= array_capacity(array) + && type_of(array_nth(array,i)) == QUOTATION_TYPE + && array_nth(array,i + 1) == userenv[JIT_DIP_WORD]; +} + +bool jit_fast_2dip_p(F_ARRAY *array, CELL i) +{ + return (i + 2) <= array_capacity(array) + && type_of(array_nth(array,i)) == QUOTATION_TYPE + && array_nth(array,i + 1) == userenv[JIT_2DIP_WORD]; +} + +bool jit_fast_3dip_p(F_ARRAY *array, CELL i) +{ + return (i + 2) <= array_capacity(array) + && type_of(array_nth(array,i)) == QUOTATION_TYPE + && array_nth(array,i + 1) == userenv[JIT_3DIP_WORD]; +} + bool jit_ignore_declare_p(F_ARRAY *array, CELL i) { return (i + 1) < array_capacity(array) @@ -115,6 +136,13 @@ bool jit_stack_frame_p(F_ARRAY *array) if(word->subprimitive == F && obj != userenv[JIT_DECLARE_WORD]) return true; } + else if(type_of(obj) == QUOTATION_TYPE) + { + if(jit_fast_dip_p(array,i) + || jit_fast_2dip_p(array,i) + || jit_fast_3dip_p(array,i)) + return true; + } } return false; @@ -232,6 +260,30 @@ void jit_compile(CELL quot, bool relocate) tail_call = true; break; } + else if(jit_fast_dip_p(untag_object(array),i)) + { + GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i)); + EMIT(userenv[JIT_DIP],literals_count - 1); + + i++; + break; + } + else if(jit_fast_2dip_p(untag_object(array),i)) + { + GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i)); + EMIT(userenv[JIT_2DIP],literals_count - 1); + + i++; + break; + } + else if(jit_fast_3dip_p(untag_object(array),i)) + { + GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i)); + EMIT(userenv[JIT_3DIP],literals_count - 1); + + i++; + break; + } case ARRAY_TYPE: if(jit_fast_dispatch_p(untag_object(array),i)) { @@ -366,6 +418,24 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) tail_call = true; break; } + else if(jit_fast_dip_p(untag_object(array),i)) + { + i++; + COUNT(userenv[JIT_DIP],i) + break; + } + else if(jit_fast_2dip_p(untag_object(array),i)) + { + i++; + COUNT(userenv[JIT_2DIP],i) + break; + } + else if(jit_fast_3dip_p(untag_object(array),i)) + { + i++; + COUNT(userenv[JIT_3DIP],i) + break; + } case ARRAY_TYPE: if(jit_fast_dispatch_p(untag_object(array),i)) { diff --git a/vm/run.h b/vm/run.h index be133b7eca..732ed9ca25 100755 --- a/vm/run.h +++ b/vm/run.h @@ -50,6 +50,12 @@ typedef enum { JIT_PUSH_IMMEDIATE, JIT_DECLARE_WORD = 42, JIT_SAVE_STACK, + JIT_DIP_WORD, + JIT_DIP, + JIT_2DIP_WORD, + JIT_2DIP, + JIT_3DIP_WORD, + JIT_3DIP, STACK_TRACES_ENV = 59, -- 2.34.1