From 8819f233129a07ea30e3dd8907fe6681982f5459 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 19 Nov 2008 01:50:05 -0600 Subject: [PATCH 01/30] Replace millis primitive with micros primitive Add millis as a library word sleep now takes either a duration or a microsecond count; code using durations doens't need to be updated, code using millisecond counts updated to use durations for the most part --- basis/bootstrap/stage2.factor | 10 +++++----- basis/calendar/calendar-docs.factor | 6 +++--- basis/calendar/calendar-tests.factor | 8 ++++---- basis/calendar/calendar.factor | 10 ++++++++-- basis/calendar/model/model.factor | 2 +- basis/compiler/tests/alien.factor | 2 +- .../combinators/combinators-tests.factor | 2 +- basis/concurrency/flags/flags-tests.factor | 8 ++++---- basis/concurrency/futures/futures-docs.factor | 6 +++--- basis/concurrency/locks/locks-tests.factor | 4 ++-- basis/concurrency/promises/promises-docs.factor | 2 +- basis/core-foundation/run-loop/run-loop.factor | 4 ++-- basis/io/launcher/launcher.factor | 5 +++-- basis/io/unix/files/files.factor | 2 +- basis/io/unix/kqueue/kqueue.factor | 2 +- basis/io/unix/select/select.factor | 4 ++-- basis/io/windows/nt/pipes/pipes.factor | 2 +- basis/smtp/smtp.factor | 2 +- basis/stack-checker/known-words/known-words.factor | 4 ++-- basis/stack-checker/stack-checker.factor | 5 ++++- basis/threads/threads-docs.factor | 2 +- basis/threads/threads.factor | 6 +++--- basis/tools/deploy/test/1/1.factor | 2 +- basis/tools/profiler/profiler-tests.factor | 2 +- basis/tools/threads/threads.factor | 4 ++-- basis/tools/time/time-docs.factor | 6 +++--- basis/tools/time/time.factor | 12 ++++++------ basis/ui/gestures/gestures-docs.factor | 2 +- basis/ui/gestures/gestures.factor | 6 +++--- basis/ui/tools/interactor/interactor-tests.factor | 8 ++++---- basis/ui/tools/listener/listener-tests.factor | 5 +++-- basis/ui/tools/search/search-tests.factor | 6 +++--- basis/ui/ui.factor | 6 +++--- basis/unix/time/time.factor | 8 ++++---- core/alien/alien-docs.factor | 4 ++-- core/bootstrap/primitives.factor | 2 +- core/io/backend/backend-docs.factor | 4 ++-- core/io/streams/c/c.factor | 2 +- core/system/system-docs.factor | 11 ++++++++--- core/system/system.factor | 2 ++ extra/crypto/timing/timing.factor | 4 ++-- extra/jamshred/jamshred.factor | 2 +- extra/mason/test/test.factor | 13 ++++++++----- extra/nehe/4/4.factor | 5 +++-- extra/nehe/5/5.factor | 5 +++-- extra/openal/example/example.factor | 6 +++--- vm/data_gc.c | 12 ++++++------ vm/data_gc.h | 4 ++-- vm/factor.c | 6 +++--- vm/os-unix.c | 8 ++++---- vm/os-unix.h | 4 ++-- vm/os-windows-ce.c | 4 ++-- vm/os-windows-ce.h | 2 +- vm/os-windows-nt.c | 4 ++-- vm/os-windows.c | 4 ++-- vm/os-windows.h | 4 ++-- vm/primitives.c | 2 +- vm/run.c | 6 +++--- vm/run.h | 2 +- 59 files changed, 155 insertions(+), 132 deletions(-) diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index d25394e978..78d555fe92 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -32,8 +32,8 @@ SYMBOL: bootstrap-time : count-words ( pred -- ) all-words swap count number>string write ; -: print-time ( time -- ) - 1000 /i +: print-time ( us -- ) + 1000000 /i 60 /mod swap number>string write " minutes and " write number>string write " seconds." print ; @@ -52,7 +52,7 @@ SYMBOL: bootstrap-time [ ! We time bootstrap - millis + micros default-image-name "output-image" set-global @@ -77,7 +77,7 @@ SYMBOL: bootstrap-time [ load-components - millis over - core-bootstrap-time set-global + micros over - core-bootstrap-time set-global run-bootstrap-init ] with-compiler-errors @@ -100,7 +100,7 @@ SYMBOL: bootstrap-time ] [ print-error 1 exit ] recover ] set-boot-quot - millis swap - bootstrap-time set-global + micros swap - bootstrap-time set-global print-report "output-image" get save-image-and-exit diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index 64c74a494a..433459cb24 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -365,12 +365,12 @@ HELP: unix-1970 { $values { "timestamp" timestamp } } { $description "Outputs the beginning of UNIX time, or midnight, January 1, 1970." } ; -HELP: millis>timestamp +HELP: micros>timestamp { $values { "x" number } { "timestamp" timestamp } } -{ $description "Converts a number of milliseconds into a timestamp value in GMT time." } +{ $description "Converts a number of microseconds into a timestamp value in GMT time." } { $examples { $example "USING: accessors calendar prettyprint ;" - "1000 millis>timestamp year>> ." + "1000 micros>timestamp year>> ." "1970" } } ; diff --git a/basis/calendar/calendar-tests.factor b/basis/calendar/calendar-tests.factor index 995bd23c09..00d5730745 100644 --- a/basis/calendar/calendar-tests.factor +++ b/basis/calendar/calendar-tests.factor @@ -143,10 +143,10 @@ IN: calendar.tests [ +gt+ ] [ 2005 1 1 12 30 0 instant 2004 1 1 13 30 0 instant <=> ] unit-test -[ t ] [ now timestamp>millis millis - 1000 < ] unit-test -[ t ] [ 0 millis>timestamp unix-1970 = ] unit-test -[ t ] [ 123456789000 [ millis>timestamp timestamp>millis ] keep = ] unit-test -[ t ] [ 123456789123456 [ millis>timestamp timestamp>millis ] keep = ] unit-test +[ t ] [ now timestamp>micros micros - 1000000 < ] unit-test +[ t ] [ 0 micros>timestamp unix-1970 = ] unit-test +[ t ] [ 123456789000000 [ micros>timestamp timestamp>micros ] keep = ] unit-test +[ t ] [ 123456789123456000 [ micros>timestamp timestamp>micros ] keep = ] unit-test : checktime+ now dup clone [ rot time+ drop ] keep = ; diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index c002760748..a78cf60eb0 100644 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -325,9 +325,15 @@ M: duration time- : timestamp>millis ( timestamp -- n ) unix-1970 (time-) 1000 * >integer ; +: micros>timestamp ( x -- timestamp ) + >r unix-1970 r> microseconds time+ ; + +: timestamp>micros ( timestamp -- n ) + unix-1970 (time-) 1000000 * >integer ; + : gmt ( -- timestamp ) #! GMT time, right now - unix-1970 millis milliseconds time+ ; + unix-1970 micros microseconds time+ ; : now ( -- timestamp ) gmt >local-time ; : hence ( duration -- timestamp ) now swap time+ ; @@ -404,7 +410,7 @@ PRIVATE> : since-1970 ( duration -- timestamp ) unix-1970 time+ >local-time ; -M: timestamp sleep-until timestamp>millis sleep-until ; +M: timestamp sleep-until timestamp>micros sleep-until ; M: duration sleep hence sleep-until ; diff --git a/basis/calendar/model/model.factor b/basis/calendar/model/model.factor index 60a61c2026..8665cc22ce 100644 --- a/basis/calendar/model/model.factor +++ b/basis/calendar/model/model.factor @@ -7,7 +7,7 @@ SYMBOL: time : (time-thread) ( -- ) now time get set-model - 1000 sleep (time-thread) ; + 1 seconds sleep (time-thread) ; : time-thread ( -- ) [ diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index 3ca6fc87f3..abcdb46ea2 100644 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -361,7 +361,7 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ; [ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test : callback-7 ( -- callback ) - "void" { } "cdecl" [ 1000 sleep ] alien-callback ; + "void" { } "cdecl" [ 1000000 sleep ] alien-callback ; [ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test diff --git a/basis/concurrency/combinators/combinators-tests.factor b/basis/concurrency/combinators/combinators-tests.factor index 562111242d..440a6766c5 100644 --- a/basis/concurrency/combinators/combinators-tests.factor +++ b/basis/concurrency/combinators/combinators-tests.factor @@ -10,7 +10,7 @@ concurrency.mailboxes threads sequences accessors arrays ; [ { 1 4 9 } ] [ { 1 2 3 } [ sq ] parallel-map ] unit-test -[ { 1 4 9 } ] [ { 1 2 3 } [ 1000 random sleep sq ] parallel-map ] unit-test +[ { 1 4 9 } ] [ { 1 2 3 } [ 1000000 random sleep sq ] parallel-map ] unit-test [ { 1 2 3 } [ dup 2 mod 0 = [ "Even" throw ] when ] parallel-map ] [ error>> "Even" = ] must-fail-with diff --git a/basis/concurrency/flags/flags-tests.factor b/basis/concurrency/flags/flags-tests.factor index 9d3f6de98c..0f78183aba 100644 --- a/basis/concurrency/flags/flags-tests.factor +++ b/basis/concurrency/flags/flags-tests.factor @@ -1,6 +1,6 @@ IN: concurrency.flags.tests USING: tools.test concurrency.flags concurrency.combinators -kernel threads locals accessors ; +kernel threads locals accessors calendar ; :: flag-test-1 ( -- ) [let | f [ ] | @@ -13,7 +13,7 @@ kernel threads locals accessors ; :: flag-test-2 ( -- ) [let | f [ ] | - [ 1000 sleep f raise-flag ] "Flag test" spawn drop + [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop f lower-flag f value>> ] ; @@ -39,7 +39,7 @@ kernel threads locals accessors ; :: flag-test-5 ( -- ) [let | f [ ] | - [ 1000 sleep f raise-flag ] "Flag test" spawn drop + [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop f wait-for-flag f value>> ] ; @@ -48,6 +48,6 @@ kernel threads locals accessors ; [ ] [ { 1 2 } - [ [ 1000 sleep raise-flag ] curry "Flag test" spawn drop ] + [ [ 1 seconds sleep raise-flag ] curry "Flag test" spawn drop ] [ [ wait-for-flag drop ] curry parallel-each ] bi ] unit-test diff --git a/basis/concurrency/futures/futures-docs.factor b/basis/concurrency/futures/futures-docs.factor index 22549c1720..3d2ac552de 100644 --- a/basis/concurrency/futures/futures-docs.factor +++ b/basis/concurrency/futures/futures-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: concurrency.promises concurrency.messaging kernel arrays -continuations help.markup help.syntax quotations ; +continuations help.markup help.syntax quotations calendar ; IN: concurrency.futures HELP: future @@ -11,8 +11,8 @@ $nl "The quotation begins with an empty data stack, an empty catch stack, and a name stack containing the global namespace only. This means that the only way to pass data to the quotation is to partially apply the data, for example using " { $link curry } " or " { $link compose } "." } ; HELP: ?future-timeout -{ $values { "future" future } { "timeout" "a timeout in milliseconds or " { $link f } } { "value" object } } -{ $description "Waits for a deferred computation to complete, blocking indefinitely if " { $snippet "timeout" } " is " { $link f } ", otherwise waiting up to " { $snippet "timeout" } " milliseconds." } +{ $values { "future" future } { "timeout" { $maybe duration } } { "value" object } } +{ $description "Waits for a deferred computation to complete, blocking indefinitely if " { $snippet "timeout" } " is " { $link f } ", otherwise waiting up to the " { $snippet "timeout" } " before throwing an error." } { $errors "Throws an error if the timeout expires before the computation completes. Also throws an error if the future quotation threw an error." } ; HELP: ?future diff --git a/basis/concurrency/locks/locks-tests.factor b/basis/concurrency/locks/locks-tests.factor index 67f9bbb15a..7696e6c1eb 100644 --- a/basis/concurrency/locks/locks-tests.factor +++ b/basis/concurrency/locks/locks-tests.factor @@ -100,7 +100,7 @@ threads sequences calendar accessors ; c await l [ 4 v push - 1000 sleep + 1 seconds sleep 5 v push ] with-write-lock c'' count-down @@ -139,7 +139,7 @@ threads sequences calendar accessors ; l [ 1 v push c count-down - 1000 sleep + 1 seconds sleep 2 v push ] with-write-lock c' count-down diff --git a/basis/concurrency/promises/promises-docs.factor b/basis/concurrency/promises/promises-docs.factor index be7a8cf65b..8e160842a9 100644 --- a/basis/concurrency/promises/promises-docs.factor +++ b/basis/concurrency/promises/promises-docs.factor @@ -13,7 +13,7 @@ HELP: promise-fulfilled? HELP: ?promise-timeout { $values { "promise" promise } { "timeout" { $maybe duration } } { "result" object } } -{ $description "Waits for another thread to fulfill a promise, returning immediately if the promise has already been fulfilled. A timeout of " { $link f } " indicates that the thread may block indefinitely, otherwise it will wait up to " { $snippet "timeout" } " milliseconds." } +{ $description "Waits for another thread to fulfill a promise, returning immediately if the promise has already been fulfilled. A timeout of " { $link f } " indicates that the thread may block indefinitely, otherwise it will wait up to the " { $snippet "timeout" } " before throwing an error." } { $errors "Throws an error if the timeout expires before the promise has been fulfilled." } ; HELP: ?promise diff --git a/basis/core-foundation/run-loop/run-loop.factor b/basis/core-foundation/run-loop/run-loop.factor index e30cc2eb60..9a5666b5d3 100644 --- a/basis/core-foundation/run-loop/run-loop.factor +++ b/basis/core-foundation/run-loop/run-loop.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: alien.syntax kernel threads init namespaces alien -core-foundation ; +core-foundation calendar ; IN: core-foundation.run-loop : kCFRunLoopRunFinished 1 ; inline @@ -30,7 +30,7 @@ FUNCTION: SInt32 CFRunLoopRunInMode ( : run-loop-thread ( -- ) CFRunLoopDefaultMode 0 f CFRunLoopRunInMode - kCFRunLoopRunHandledSource = [ 1000 sleep ] unless + kCFRunLoopRunHandledSource = [ 1 seconds sleep ] unless run-loop-thread ; : start-run-loop-thread ( -- ) diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor index 3e1ef6ce05..bdccfc3f57 100644 --- a/basis/io/launcher/launcher.factor +++ b/basis/io/launcher/launcher.factor @@ -4,7 +4,8 @@ USING: system kernel namespaces strings hashtables sequences assocs combinators vocabs.loader init threads continuations math accessors concurrency.flags destructors environment io io.backend io.timeouts io.pipes io.pipes.private io.encodings -io.streams.duplex io.ports debugger prettyprint summary ; +io.streams.duplex io.ports debugger prettyprint summary +calendar ; IN: io.launcher TUPLE: process < identity-tuple @@ -65,7 +66,7 @@ SYMBOL: wait-flag : wait-loop ( -- ) processes get assoc-empty? [ wait-flag get-global lower-flag ] - [ wait-for-processes [ 100 sleep ] when ] if ; + [ wait-for-processes [ 100 milliseconds sleep ] when ] if ; : start-wait-thread ( -- ) wait-flag set-global diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor index 3f254e7713..fb8615c47b 100644 --- a/basis/io/unix/files/files.factor +++ b/basis/io/unix/files/files.factor @@ -290,7 +290,7 @@ M: string other-execute? ( path -- ? ) OTHER-EXECUTE file-mode? ; dup length [ over [ pick set-timeval-nth ] [ 2drop ] if ] 2each ; : timestamp>timeval ( timestamp -- timeval ) - unix-1970 time- duration>milliseconds make-timeval ; + unix-1970 time- duration>microseconds make-timeval ; : timestamps>byte-array ( timestamps -- byte-array ) [ dup [ timestamp>timeval ] when ] map make-timeval-array ; diff --git a/basis/io/unix/kqueue/kqueue.factor b/basis/io/unix/kqueue/kqueue.factor index b3e69a453c..ba4240de7f 100644 --- a/basis/io/unix/kqueue/kqueue.factor +++ b/basis/io/unix/kqueue/kqueue.factor @@ -94,7 +94,7 @@ M: kqueue-mx unregister-io-task ( task mx -- ) : handle-kevents ( mx n -- ) [ over events>> kevent-nth handle-kevent ] with each ; -M: kqueue-mx wait-for-events ( ms mx -- ) +M: kqueue-mx wait-for-events ( us mx -- ) swap dup [ make-timespec ] when dupd wait-kevent handle-kevents ; diff --git a/basis/io/unix/select/select.factor b/basis/io/unix/select/select.factor index f2a802a859..530dfe7ab3 100644 --- a/basis/io/unix/select/select.factor +++ b/basis/io/unix/select/select.factor @@ -48,9 +48,9 @@ TUPLE: select-mx < mx read-fdset write-fdset ; [ write-fdset/tasks [ init-fdset ] [ underlying>> ] bi ] tri f ; -M:: select-mx wait-for-events ( ms mx -- ) +M:: select-mx wait-for-events ( us mx -- ) mx - [ init-fdsets ms dup [ make-timeval ] when select multiplexer-error ] + [ init-fdsets us dup [ make-timeval ] when select multiplexer-error ] [ [ read-fdset/tasks ] keep [ input-available ] check-fdset ] [ [ write-fdset/tasks ] keep [ output-available ] check-fdset ] tri ; diff --git a/basis/io/windows/nt/pipes/pipes.factor b/basis/io/windows/nt/pipes/pipes.factor index c9bf1ebf42..d498875c87 100644 --- a/basis/io/windows/nt/pipes/pipes.factor +++ b/basis/io/windows/nt/pipes/pipes.factor @@ -35,7 +35,7 @@ IN: io.windows.nt.pipes "-" % 32 random-bits # "-" % - millis # + micros # ] "" make ; M: winnt (pipe) ( -- pipe ) diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor index c17bccf064..63603ad131 100644 --- a/basis/smtp/smtp.factor +++ b/basis/smtp/smtp.factor @@ -145,7 +145,7 @@ ERROR: invalid-header-string string ; "<" % 64 random-bits # "-" % - millis # + micros # "@" % smtp-domain get [ host-name ] unless* % ">" % diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index fdc4b4b35c..7ee46cb440 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -423,8 +423,8 @@ do-primitive alien-invoke alien-indirect alien-callback \ code-room { } { integer integer integer integer } define-primitive \ code-room make-flushable -\ millis { } { integer } define-primitive -\ millis make-flushable +\ micros { } { integer } define-primitive +\ micros make-flushable \ tag { object } { fixnum } define-primitive \ tag make-foldable diff --git a/basis/stack-checker/stack-checker.factor b/basis/stack-checker/stack-checker.factor index c990a51cc1..ff283ce9ca 100644 --- a/basis/stack-checker/stack-checker.factor +++ b/basis/stack-checker/stack-checker.factor @@ -24,4 +24,7 @@ M: callable infer ( quot -- effect ) : forget-effects ( -- ) forget-errors - all-words [ f "inferred-effect" set-word-prop ] each ; + all-words [ + dup subwords [ f "inferred-effect" set-word-prop ] each + f "inferred-effect" set-word-prop + ] each ; diff --git a/basis/threads/threads-docs.factor b/basis/threads/threads-docs.factor index 471cd2bd34..cc2216545d 100644 --- a/basis/threads/threads-docs.factor +++ b/basis/threads/threads-docs.factor @@ -100,7 +100,7 @@ HELP: sleep-queue { $var-description "A " { $link min-heap } " storing the queue of sleeping threads." } ; HELP: sleep-time -{ $values { "ms/f" "a non-negative integer or " { $link f } } } +{ $values { "us/f" "a non-negative integer or " { $link f } } } { $description "Outputs the time until the next sleeping thread is scheduled to wake up, which could be zero if there are threads in the run queue, or threads which need to wake up right now. If there are no runnable or sleeping threads, outputs " { $link f } "." } ; HELP: stop diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor index 8a4d433273..5dca7be633 100644 --- a/basis/threads/threads.factor +++ b/basis/threads/threads.factor @@ -93,7 +93,7 @@ PRIVATE> { { [ run-queue deque-empty? not ] [ 0 ] } { [ sleep-queue heap-empty? ] [ f ] } - [ sleep-queue heap-peek nip millis [-] ] + [ sleep-queue heap-peek nip micros [-] ] } cond ; DEFER: stop @@ -106,7 +106,7 @@ DEFER: stop : expire-sleep? ( heap -- ? ) dup heap-empty? - [ drop f ] [ heap-peek nip millis <= ] if ; + [ drop f ] [ heap-peek nip micros <= ] if ; : expire-sleep ( thread -- ) f >>sleep-entry resume ; @@ -184,7 +184,7 @@ M: f sleep-until GENERIC: sleep ( dt -- ) M: real sleep - millis + >integer sleep-until ; + micros + >integer sleep-until ; : interrupt ( thread -- ) dup state>> [ diff --git a/basis/tools/deploy/test/1/1.factor b/basis/tools/deploy/test/1/1.factor index 0ca85bca8c..63b382e2f6 100644 --- a/basis/tools/deploy/test/1/1.factor +++ b/basis/tools/deploy/test/1/1.factor @@ -1,6 +1,6 @@ IN: tools.deploy.test.1 USING: threads ; -: deploy-test-1 ( -- ) 1000 sleep ; +: deploy-test-1 ( -- ) 1000000 sleep ; MAIN: deploy-test-1 diff --git a/basis/tools/profiler/profiler-tests.factor b/basis/tools/profiler/profiler-tests.factor index f0c71aa311..197ace74d8 100644 --- a/basis/tools/profiler/profiler-tests.factor +++ b/basis/tools/profiler/profiler-tests.factor @@ -11,7 +11,7 @@ words ; [ ] [ [ 10 [ gc ] times ] profile ] unit-test -[ ] [ [ 1000 sleep ] profile ] unit-test +[ ] [ [ 1000000 sleep ] profile ] unit-test [ ] [ profile. ] unit-test diff --git a/basis/tools/threads/threads.factor b/basis/tools/threads/threads.factor index 1b75e46e25..fc4ba1f6b2 100644 --- a/basis/tools/threads/threads.factor +++ b/basis/tools/threads/threads.factor @@ -14,8 +14,8 @@ IN: tools.threads ] with-cell [ sleep-entry>> [ - key>> millis [-] number>string write - " ms" write + key>> micros [-] number>string write + " us" write ] when* ] with-cell ; diff --git a/basis/tools/time/time-docs.factor b/basis/tools/time/time-docs.factor index fe3d709f78..d8dba04486 100644 --- a/basis/tools/time/time-docs.factor +++ b/basis/tools/time/time-docs.factor @@ -7,7 +7,7 @@ ARTICLE: "timing" "Timing code" "A lower-level word puts timings on the stack, intead of printing:" { $subsection benchmark } "You can also read the system clock and garbage collection statistics directly:" -{ $subsection millis } +{ $subsection micros } { $subsection gc-stats } { $see-also "profiling" } ; @@ -15,7 +15,7 @@ ABOUT: "timing" HELP: benchmark { $values { "quot" "a quotation" } - { "runtime" "an integer denoting milliseconds" } } + { "runtime" "the runtime in microseconds" } } { $description "Runs a quotation, measuring the total wall clock time." } { $notes "A nicer word for interactive use is " { $link time } "." } ; @@ -23,4 +23,4 @@ HELP: time { $values { "quot" "a quotation" } } { $description "Runs a quotation and then prints the total run time and some garbage collection statistics." } ; -{ benchmark millis time } related-words +{ benchmark micros time } related-words diff --git a/basis/tools/time/time.factor b/basis/tools/time/time.factor index 6873d68316..f5187230de 100644 --- a/basis/tools/time/time.factor +++ b/basis/tools/time/time.factor @@ -5,20 +5,20 @@ namespaces system sequences splitting grouping assocs strings ; IN: tools.time : benchmark ( quot -- runtime ) - millis >r call millis r> - ; inline + micros >r call micros r> - ; inline : time. ( data -- ) unclip - "==== RUNNING TIME" print nl pprint " ms" print nl + "==== RUNNING TIME" print nl pprint " us" print nl 4 cut* "==== GARBAGE COLLECTION" print nl [ 6 group { "GC count:" - "Cumulative GC time (ms):" - "Longest GC pause (ms):" - "Average GC pause (ms):" + "Cumulative GC time (us):" + "Longest GC pause (us):" + "Average GC pause (us):" "Objects copied:" "Bytes copied:" } prefix @@ -37,4 +37,4 @@ IN: tools.time ] bi* ; : time ( quot -- ) - gc-reset millis >r call gc-stats millis r> - prefix time. ; inline + gc-reset micros >r call gc-stats micros r> - prefix time. ; inline diff --git a/basis/ui/gestures/gestures-docs.factor b/basis/ui/gestures/gestures-docs.factor index 3471bd2cdb..1db0d04f43 100644 --- a/basis/ui/gestures/gestures-docs.factor +++ b/basis/ui/gestures/gestures-docs.factor @@ -147,7 +147,7 @@ HELP: hand-last-button { $var-description "Global variable. The mouse button most recently pressed." } ; HELP: hand-last-time -{ $var-description "Global variable. The timestamp of the most recent mouse button click. This timestamp has the same format as the output value of " { $link millis } "." } ; +{ $var-description "Global variable. The timestamp of the most recent mouse button click. This timestamp has the same format as the output value of " { $link micros } "." } ; HELP: hand-buttons { $var-description "Global variable. A vector of mouse buttons currently held down." } ; diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor index 2a29d32055..e37bea538f 100644 --- a/basis/ui/gestures/gestures.factor +++ b/basis/ui/gestures/gestures.factor @@ -94,7 +94,7 @@ SYMBOL: scroll-direction { 0 0 } scroll-direction set-global SYMBOL: double-click-timeout -300 double-click-timeout set-global +300 milliseconds double-click-timeout set-global : hand-moved? ( -- ? ) hand-loc get hand-click-loc get = not ; @@ -182,7 +182,7 @@ SYMBOL: drag-timer hand-click-loc get-global swap screen-loc v- ; : multi-click-timeout? ( -- ? ) - millis hand-last-time get - double-click-timeout get <= ; + now hand-last-time get time- double-click-timeout get before=? ; : multi-click-button? ( button -- button ? ) dup hand-last-button get = ; @@ -207,7 +207,7 @@ SYMBOL: drag-timer 1 hand-click# set ] if hand-last-button set - millis hand-last-time set + now hand-last-time set ] bind ; : update-clicked ( -- ) diff --git a/basis/ui/tools/interactor/interactor-tests.factor b/basis/ui/tools/interactor/interactor-tests.factor index 37f43faa8b..628570c3e3 100644 --- a/basis/ui/tools/interactor/interactor-tests.factor +++ b/basis/ui/tools/interactor/interactor-tests.factor @@ -38,7 +38,7 @@ tools.test kernel calendar parser accessors calendar io ; [ ] [ [ "interactor" get stream-read-quot drop ] "B" spawn drop ] unit-test -[ ] [ 1000 sleep ] unit-test +[ ] [ 1 seconds sleep ] unit-test [ ] [ "interactor" get interactor-eof ] unit-test @@ -57,11 +57,11 @@ tools.test kernel calendar parser accessors calendar io ; ] in-thread ] unit-test -[ ] [ 100 sleep ] unit-test +[ ] [ 100 milliseconds sleep ] unit-test [ ] [ "interactor" get evaluate-input ] unit-test -[ ] [ 100 sleep ] unit-test +[ ] [ 100 milliseconds sleep ] unit-test [ ] [ "interactor" get interactor-eof ] unit-test @@ -80,7 +80,7 @@ tools.test kernel calendar parser accessors calendar io ; ] in-thread ] unit-test -[ ] [ 100 sleep ] unit-test +[ ] [ 100 milliseconds sleep ] unit-test [ ] [ "interactor" get evaluate-input ] unit-test diff --git a/basis/ui/tools/listener/listener-tests.factor b/basis/ui/tools/listener/listener-tests.factor index 616226a9c5..28fdef6cb7 100644 --- a/basis/ui/tools/listener/listener-tests.factor +++ b/basis/ui/tools/listener/listener-tests.factor @@ -2,7 +2,8 @@ USING: continuations documents ui.tools.interactor ui.tools.listener hashtables kernel namespaces parser sequences tools.test ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.panes vocabs words tools.test.ui slots.private -threads arrays generic threads accessors listener math ; +threads arrays generic threads accessors listener math +calendar ; IN: ui.tools.listener.tests [ f ] [ "word" source-editor command-map commands>> empty? ] unit-test @@ -47,7 +48,7 @@ IN: ui.tools.listener.tests [ ] [ "listener" get restart-listener ] unit-test - [ ] [ 1000 sleep ] unit-test + [ ] [ 1 seconds sleep ] unit-test [ ] [ "listener" get com-end ] unit-test ] with-grafted-gadget diff --git a/basis/ui/tools/search/search-tests.factor b/basis/ui/tools/search/search-tests.factor index d477274520..c8c7c6c219 100644 --- a/basis/ui/tools/search/search-tests.factor +++ b/basis/ui/tools/search/search-tests.factor @@ -1,7 +1,7 @@ USING: assocs ui.tools.search help.topics io.files io.styles kernel namespaces sequences source-files threads tools.test ui.gadgets ui.gestures vocabs accessors -vocabs.loader words tools.test.ui debugger ; +vocabs.loader words tools.test.ui debugger calendar ; IN: ui.tools.search.tests [ f ] [ @@ -14,7 +14,7 @@ IN: ui.tools.search.tests : update-live-search ( search -- seq ) dup [ - 300 sleep + 300 milliseconds sleep list>> control-value ] with-grafted-gadget ; @@ -30,7 +30,7 @@ IN: ui.tools.search.tests "" all-words t dup [ { "set-word-prop" } over field>> set-control-value - 300 sleep + 300 milliseconds sleep search-value \ set-word-prop eq? ] with-grafted-gadget ] unit-test diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index f561f3cd49..dc868154bb 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -1,10 +1,10 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs io kernel math models namespaces make prettyprint dlists deques sequences threads sequences words debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render continuations init combinators -hashtables concurrency.flags sets accessors ; +hashtables concurrency.flags sets accessors calendar ; IN: ui ! Assoc mapping aliens to gadgets @@ -142,7 +142,7 @@ SYMBOL: ui-hook [ notify-queued layout-queued redraw-worlds ] assert-depth ; : ui-wait ( -- ) - 10 sleep ; + 10 milliseconds sleep ; : ui-try ( quot -- ) [ ui-error ] recover ; diff --git a/basis/unix/time/time.factor b/basis/unix/time/time.factor index c664aa3bfb..9847b09778 100644 --- a/basis/unix/time/time.factor +++ b/basis/unix/time/time.factor @@ -11,14 +11,14 @@ C-STRUCT: timespec { "time_t" "sec" } { "long" "nsec" } ; -: make-timeval ( ms -- timeval ) - 1000 /mod 1000 * +: make-timeval ( us -- timeval ) + 1000000 /mod "timeval" [ set-timeval-usec ] keep [ set-timeval-sec ] keep ; -: make-timespec ( ms -- timespec ) - 1000 /mod 1000000 * +: make-timespec ( us -- timespec ) + 1000000 /mod 1000 * "timespec" [ set-timespec-nsec ] keep [ set-timespec-sec ] keep ; diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index ce3497439a..edac8c09cc 100644 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -281,8 +281,8 @@ $nl "Gives all Factor threads a chance to run." } } { { - { $code "void factor_sleep(long ms)" } - "Gives all Factor threads a chance to run for " { $snippet "ms" } " milliseconds." + { $code "void factor_sleep(long us)" } + "Gives all Factor threads a chance to run for " { $snippet "us" } " microseconds." } } } ; diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 24faf81662..f0aefa53cb 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -443,7 +443,7 @@ tuple { "exit" "system" } { "data-room" "memory" } { "code-room" "memory" } - { "millis" "system" } + { "micros" "system" } { "modify-code-heap" "compiler.units" } { "dlopen" "alien" } { "dlsym" "alien" } diff --git a/core/io/backend/backend-docs.factor b/core/io/backend/backend-docs.factor index 48b49ed32b..e129a9b0bc 100644 --- a/core/io/backend/backend-docs.factor +++ b/core/io/backend/backend-docs.factor @@ -2,8 +2,8 @@ USING: help.markup help.syntax io io.backend strings byte-arrays ; HELP: io-multiplex -{ $values { "ms" "a non-negative integer" } } -{ $contract "Waits up to " { $snippet "ms" } " milliseconds for pending I/O requests to complete." } ; +{ $values { "us" "a non-negative integer" } } +{ $contract "Waits up to " { $snippet "us" } " microseconds for pending I/O requests to complete." } ; HELP: init-io { $contract "Initializes the I/O system. Called on startup." } ; diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index 1e12d7e956..287ee3ad95 100644 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -67,7 +67,7 @@ M: c-io-backend init-io ; M: c-io-backend (init-stdio) init-c-stdio ; -M: c-io-backend io-multiplex 60 60 * 1000 * or (sleep) ; +M: c-io-backend io-multiplex 60 60 * 1000 * 1000 * or (sleep) ; M: c-io-backend (file-reader) "rb" fopen ; diff --git a/core/system/system-docs.factor b/core/system/system-docs.factor index acd42b094f..3adf82af7f 100644 --- a/core/system/system-docs.factor +++ b/core/system/system-docs.factor @@ -11,7 +11,7 @@ ARTICLE: "system" "System interface" { $subsection vm } { $subsection image } "Getting the current time:" -{ $subsection millis } +{ $subsection micros } "Exiting the Factor VM:" { $subsection exit } ; @@ -64,8 +64,13 @@ HELP: exit ( n -- ) { $values { "n" "an integer exit code" } } { $description "Exits the Factor process." } ; -HELP: millis ( -- n ) -{ $values { "n" integer } } +HELP: micros ( -- us ) +{ $values { "us" integer } } +{ $description "Outputs the number of microseconds ellapsed since midnight January 1, 1970." } +{ $notes "This is a low-level word. The " { $vocab-link "calendar" } " vocabulary provides features for date/time arithmetic and formatting." } ; + +HELP: millis ( -- ms ) +{ $values { "us" integer } } { $description "Outputs the number of milliseconds ellapsed since midnight January 1, 1970." } { $notes "This is a low-level word. The " { $vocab-link "calendar" } " vocabulary provides features for date/time arithmetic and formatting." } ; diff --git a/core/system/system.factor b/core/system/system.factor index 66662a23e1..2d8ed1b657 100644 --- a/core/system/system.factor +++ b/core/system/system.factor @@ -65,3 +65,5 @@ PRIVATE> ] "system" add-init-hook : embedded? ( -- ? ) 15 getenv ; + +: millis ( -- ms ) micros 1000 /i ; diff --git a/extra/crypto/timing/timing.factor b/extra/crypto/timing/timing.factor index a17d65d90b..8fdb807c6a 100644 --- a/extra/crypto/timing/timing.factor +++ b/extra/crypto/timing/timing.factor @@ -1,6 +1,6 @@ -USING: kernel math threads system ; +USING: kernel math threads system calendar ; IN: crypto.timing : with-timing ( quot n -- ) #! force the quotation to execute in, at minimum, n milliseconds - millis 2slip millis - + sleep ; inline + millis 2slip millis - + milliseconds sleep ; inline diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor index 2357742fde..d0b74417d1 100755 --- a/extra/jamshred/jamshred.factor +++ b/extra/jamshred/jamshred.factor @@ -23,7 +23,7 @@ M: jamshred-gadget draw-gadget* ( gadget -- ) ] [ [ jamshred>> jamshred-update ] [ relayout-1 ] - [ 10 sleep yield jamshred-loop ] tri + [ 10 milliseconds sleep yield jamshred-loop ] tri ] if ; : fullscreen ( gadget -- ) diff --git a/extra/mason/test/test.factor b/extra/mason/test/test.factor index 0206df7db9..3de1fa643f 100644 --- a/extra/mason/test/test.factor +++ b/extra/mason/test/test.factor @@ -40,14 +40,17 @@ M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ; : do-benchmarks ( -- ) run-benchmarks benchmarks-file to-file ; +: benchmark-ms ( quot -- ms ) + benchmark 1000 /i ; inline + : do-all ( -- ) ".." [ bootstrap-time get boot-time-file to-file - [ do-load do-compile-errors ] benchmark load-time-file to-file - [ generate-help ] benchmark html-help-time-file to-file - [ do-tests ] benchmark test-time-file to-file - [ do-help-lint ] benchmark help-lint-time-file to-file - [ do-benchmarks ] benchmark benchmark-time-file to-file + [ do-load do-compile-errors ] benchmark-ms load-time-file to-file + [ generate-help ] html-help-time-file to-file + [ do-tests ] benchmark-ms test-time-file to-file + [ do-help-lint ] benchmark-ms help-lint-time-file to-file + [ do-benchmarks ] benchmark-ms benchmark-time-file to-file ] with-directory ; MAIN: do-all \ No newline at end of file diff --git a/extra/nehe/4/4.factor b/extra/nehe/4/4.factor index 4c1545b4ae..10217c93cb 100644 --- a/extra/nehe/4/4.factor +++ b/extra/nehe/4/4.factor @@ -1,12 +1,13 @@ USING: arrays kernel math opengl opengl.gl opengl.glu -opengl.demo-support ui ui.gadgets ui.render threads accessors ; +opengl.demo-support ui ui.gadgets ui.render threads accessors +calendar ; IN: nehe.4 TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ; : width 256 ; : height 256 ; -: redraw-interval 10 ; +: redraw-interval 10 milliseconds ; : ( -- gadget ) nehe4-gadget new-gadget diff --git a/extra/nehe/5/5.factor b/extra/nehe/5/5.factor index 59170ff964..2c9b51c63f 100755 --- a/extra/nehe/5/5.factor +++ b/extra/nehe/5/5.factor @@ -1,11 +1,12 @@ USING: arrays kernel math opengl opengl.gl opengl.glu -opengl.demo-support ui ui.gadgets ui.render threads accessors ; +opengl.demo-support ui ui.gadgets ui.render threads accessors +calendar ; IN: nehe.5 TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ; : width 256 ; : height 256 ; -: redraw-interval 10 ; +: redraw-interval 10 milliseconds ; : ( -- gadget ) nehe5-gadget new-gadget diff --git a/extra/openal/example/example.factor b/extra/openal/example/example.factor index ebdb6da5ce..ae0b50afff 100644 --- a/extra/openal/example/example.factor +++ b/extra/openal/example/example.factor @@ -2,17 +2,17 @@ ! See http://factorcode.org/license.txt for BSD license. ! IN: openal.example -USING: openal kernel alien threads sequences ; +USING: openal kernel alien threads sequences calendar ; : play-hello ( -- ) init-openal 1 gen-sources first dup AL_BUFFER alutCreateBufferHelloWorld set-source-param source-play - 1000 sleep ; + 1000 milliseconds sleep ; : (play-file) ( source -- ) - 100 sleep + 100 milliseconds sleep dup source-playing? [ (play-file) ] [ drop ] if ; : play-file ( filename -- ) diff --git a/vm/data_gc.c b/vm/data_gc.c index 9f8ffb625e..23836c560c 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -793,7 +793,7 @@ void garbage_collection(CELL gen, return; } - s64 start = current_millis(); + s64 start = current_micros(); performing_gc = true; growing_data_heap = growing_data_heap_; @@ -860,7 +860,7 @@ void garbage_collection(CELL gen, while(scan < newspace->here) scan = collect_next(scan); - CELL gc_elapsed = (current_millis() - start); + CELL gc_elapsed = (current_micros() - start); end_gc(gc_elapsed); @@ -887,14 +887,14 @@ void primitive_gc_stats(void) GROWABLE_ARRAY(stats); CELL i; - CELL total_gc_time = 0; + u64 total_gc_time = 0; for(i = 0; i < MAX_GEN_COUNT; i++) { F_GC_STATS *s = &gc_stats[i]; GROWABLE_ARRAY_ADD(stats,allot_cell(s->collections)); - GROWABLE_ARRAY_ADD(stats,allot_cell(s->gc_time)); - GROWABLE_ARRAY_ADD(stats,allot_cell(s->max_gc_time)); + GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->gc_time))); + GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->max_gc_time))); GROWABLE_ARRAY_ADD(stats,allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections)); GROWABLE_ARRAY_ADD(stats,allot_cell(s->object_count)); GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->bytes_copied))); @@ -902,7 +902,7 @@ void primitive_gc_stats(void) total_gc_time += s->gc_time; } - GROWABLE_ARRAY_ADD(stats,allot_cell(total_gc_time)); + GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(total_gc_time))); GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(cards_scanned))); GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(decks_scanned))); GROWABLE_ARRAY_ADD(stats,allot_cell(code_heap_scans)); diff --git a/vm/data_gc.h b/vm/data_gc.h index 0d63cc6bfe..a407ed761c 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -161,8 +161,8 @@ void init_data_heap(CELL gens, /* statistics */ typedef struct { CELL collections; - CELL gc_time; - CELL max_gc_time; + u64 gc_time; + u64 max_gc_time; CELL object_count; u64 bytes_copied; } F_GC_STATS; diff --git a/vm/factor.c b/vm/factor.c index 8e0aadb4fd..f198370ebe 100755 --- a/vm/factor.c +++ b/vm/factor.c @@ -91,7 +91,7 @@ void init_factor(F_PARAMETERS *p) if(p->image == NULL) p->image = default_image_path(); - srand(current_millis()); + srand(current_micros()); init_ffi(); init_stacks(p->ds_size,p->rs_size); load_image(p); @@ -216,8 +216,8 @@ void factor_yield(void) callback(); } -void factor_sleep(long ms) +void factor_sleep(long us) { void (*callback)() = alien_offset(userenv[SLEEP_CALLBACK_ENV]); - callback(ms); + callback(us); } diff --git a/vm/os-unix.c b/vm/os-unix.c index c11962f6e1..952d2683cf 100755 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -16,16 +16,16 @@ void start_thread(void *(*start_routine)(void *)) static void *null_dll; -s64 current_millis(void) +s64 current_micros(void) { struct timeval t; gettimeofday(&t,NULL); - return (s64)t.tv_sec * 1000 + t.tv_usec / 1000; + return (s64)t.tv_sec * 1000000 + t.tv_usec; } -void sleep_millis(CELL msec) +void sleep_micros(CELL usec) { - usleep(msec * 1000); + usleep(usec); } void init_ffi(void) diff --git a/vm/os-unix.h b/vm/os-unix.h index 2c5cc20e8d..97b1b39129 100755 --- a/vm/os-unix.h +++ b/vm/os-unix.h @@ -50,7 +50,7 @@ void unix_init_signals(void); void signal_handler(int signal, siginfo_t* siginfo, void* uap); void dump_stack_signal(int signal, siginfo_t* siginfo, void* uap); -s64 current_millis(void); -void sleep_millis(CELL msec); +s64 current_micros(void); +void sleep_micros(CELL usec); void open_console(void); diff --git a/vm/os-windows-ce.c b/vm/os-windows-ce.c index 02b51b82ed..621198ff7d 100755 --- a/vm/os-windows-ce.c +++ b/vm/os-windows-ce.c @@ -1,13 +1,13 @@ #include "master.h" -s64 current_millis(void) +s64 current_micros(void) { SYSTEMTIME st; FILETIME ft; GetSystemTime(&st); SystemTimeToFileTime(&st, &ft); return (((s64)ft.dwLowDateTime - | (s64)ft.dwHighDateTime<<32) - EPOCH_OFFSET) / 10000; + | (s64)ft.dwHighDateTime<<32) - EPOCH_OFFSET) / 10; } char *strerror(int err) diff --git a/vm/os-windows-ce.h b/vm/os-windows-ce.h index f1d6df6f3d..a2be5fe475 100755 --- a/vm/os-windows-ce.h +++ b/vm/os-windows-ce.h @@ -22,6 +22,6 @@ char *getenv(char *name); #define snprintf _snprintf #define snwprintf _snwprintf -s64 current_millis(void); +s64 current_micros(void); void c_to_factor_toplevel(CELL quot); void open_console(void); diff --git a/vm/os-windows-nt.c b/vm/os-windows-nt.c index e22ea1446b..f982abfb1b 100755 --- a/vm/os-windows-nt.c +++ b/vm/os-windows-nt.c @@ -1,11 +1,11 @@ #include "master.h" -s64 current_millis(void) +s64 current_micros(void) { FILETIME t; GetSystemTimeAsFileTime(&t); return (((s64)t.dwLowDateTime | (s64)t.dwHighDateTime<<32) - - EPOCH_OFFSET) / 10000; + - EPOCH_OFFSET) / 10; } long exception_handler(PEXCEPTION_POINTERS pe) diff --git a/vm/os-windows.c b/vm/os-windows.c index 7d486bb86b..0aeb77741b 100755 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -166,7 +166,7 @@ long getpagesize(void) return g_pagesize; } -void sleep_millis(DWORD msec) +void sleep_micros(DWORD usec) { - Sleep(msec); + Sleep(msec / 1000); } diff --git a/vm/os-windows.h b/vm/os-windows.h index 8d0f15648a..b12d677af2 100755 --- a/vm/os-windows.h +++ b/vm/os-windows.h @@ -49,7 +49,7 @@ void ffi_dlopen(F_DLL *dll); void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol); void ffi_dlclose(F_DLL *dll); -void sleep_millis(DWORD msec); +void sleep_micros(DWORD msec); INLINE void init_signals(void) {} INLINE void early_init(void) {} @@ -57,5 +57,5 @@ const F_CHAR *vm_executable_path(void); const F_CHAR *default_image_path(void); long getpagesize (void); -s64 current_millis(void); +s64 current_micros(void); diff --git a/vm/primitives.c b/vm/primitives.c index 69e77f81ed..5adb135c82 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -68,7 +68,7 @@ void *primitives[] = { primitive_exit, primitive_data_room, primitive_code_room, - primitive_millis, + primitive_micros, primitive_modify_code_heap, primitive_dlopen, primitive_dlsym, diff --git a/vm/run.c b/vm/run.c index c7d93d29c8..b8c8d78ba1 100755 --- a/vm/run.c +++ b/vm/run.c @@ -153,14 +153,14 @@ void primitive_exit(void) exit(to_fixnum(dpop())); } -void primitive_millis(void) +void primitive_micros(void) { - box_unsigned_8(current_millis()); + box_unsigned_8(current_micros()); } void primitive_sleep(void) { - sleep_millis(to_cell(dpop())); + sleep_micros(to_cell(dpop())); } void primitive_set_slot(void) diff --git a/vm/run.h b/vm/run.h index 2dbbcc8c06..378b93e8bd 100755 --- a/vm/run.h +++ b/vm/run.h @@ -236,7 +236,7 @@ void primitive_os_envs(void); void primitive_set_os_env(void); void primitive_unset_os_env(void); void primitive_set_os_envs(void); -void primitive_millis(void); +void primitive_micros(void); void primitive_sleep(void); void primitive_set_slot(void); From a7bc139c1e500ecb31f3cf796dee422584c6e7da Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Sat, 22 Nov 2008 03:18:33 -0600 Subject: [PATCH 02/30] Don't load io.sockets during bootstrap on Windows --- basis/io/windows/windows.factor | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) mode change 100644 => 100755 basis/io/windows/windows.factor diff --git a/basis/io/windows/windows.factor b/basis/io/windows/windows.factor old mode 100644 new mode 100755 index 6f6c29fc55..ce75293b38 --- a/basis/io/windows/windows.factor +++ b/basis/io/windows/windows.factor @@ -1,11 +1,10 @@ ! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays destructors io io.backend -io.buffers io.files io.ports io.sockets io.binary -io.sockets io.timeouts windows.errors strings -kernel math namespaces sequences windows windows.kernel32 -windows.shell32 windows.types windows.winsock splitting -continuations math.bitwise system accessors ; +io.buffers io.files io.ports io.binary io.timeouts +windows.errors strings kernel math namespaces sequences windows +windows.kernel32 windows.shell32 windows.types windows.winsock +splitting continuations math.bitwise system accessors ; IN: io.windows : set-inherit ( handle ? -- ) From f0716b3a0d97ba1249689847204d32bc0e07cc5e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 22 Nov 2008 22:46:57 -0600 Subject: [PATCH 03/30] 1% image size reduction by not storing empty compiled-generic-uses and compiled-uses props --- basis/compiler/compiler.factor | 4 ++-- basis/compiler/tests/redefine13.factor | 14 ++++++++++++++ basis/compiler/tests/redefine14.factor | 8 ++++++++ core/words/words.factor | 4 ++-- 4 files changed, 26 insertions(+), 4 deletions(-) create mode 100644 basis/compiler/tests/redefine13.factor create mode 100644 basis/compiler/tests/redefine14.factor diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index a6afc4b243..e5cbd888d9 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -91,8 +91,8 @@ t compile-dependencies? set-global [ dup crossref? [ - dependencies get >alist - generic-dependencies get >alist + dependencies get + generic-dependencies get compiled-xref ] [ drop ] if ] tri ; diff --git a/basis/compiler/tests/redefine13.factor b/basis/compiler/tests/redefine13.factor new file mode 100644 index 0000000000..6f116e9f92 --- /dev/null +++ b/basis/compiler/tests/redefine13.factor @@ -0,0 +1,14 @@ +USING: math fry macros eval tools.test ; +IN: compiler.tests.redefine13 + +: breakage-word ( a b -- c ) + ; + +MACRO: breakage-macro ( a -- ) '[ _ breakage-word ] ; + +GENERIC: breakage-caller ( a -- c ) + +M: fixnum breakage-caller 2 breakage-macro ; + +: breakage ( -- obj ) 2 breakage-caller ; + +[ ] [ "IN: compiler.tests.redefine13 : breakage-word ( a b -- c ) ;" eval ] unit-test diff --git a/basis/compiler/tests/redefine14.factor b/basis/compiler/tests/redefine14.factor new file mode 100644 index 0000000000..6a04eed088 --- /dev/null +++ b/basis/compiler/tests/redefine14.factor @@ -0,0 +1,8 @@ +USING: compiler.units definitions tools.test sequences ; +IN: compiler.tests.redefine14 + +TUPLE: bad ; + +M: bad length 1 2 3 ; + +[ ] [ [ { bad length } forget ] with-compilation-unit ] unit-test diff --git a/core/words/words.factor b/core/words/words.factor index 66c60dc06e..6281e10e09 100644 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -113,7 +113,7 @@ compiled-generic-crossref global [ H{ } assoc-like ] change-at bi* 2bi ; : compiled-xref ( word dependencies generic-dependencies -- ) - [ [ drop crossref? ] assoc-filter ] bi@ + [ [ drop crossref? ] assoc-filter >alist f like ] bi@ [ over ] dip [ "compiled-uses" compiled-crossref (compiled-xref) ] [ "compiled-generic-uses" compiled-generic-crossref (compiled-xref) ] @@ -121,7 +121,7 @@ compiled-generic-crossref global [ H{ } assoc-like ] change-at : (compiled-unxref) ( word word-prop variable -- ) [ [ [ dupd word-prop ] dip get remove-vertex* ] 2curry ] - [ drop [ f swap set-word-prop ] curry ] + [ drop [ remove-word-prop ] curry ] 2bi bi ; : compiled-unxref ( word -- ) From 3a2e15327fcc8fbd8299ccd5d2a1dbd4359ef756 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 22 Nov 2008 22:47:40 -0600 Subject: [PATCH 04/30] Disable these for now --- basis/compiler/tests/redefine13.factor | 2 +- basis/compiler/tests/redefine14.factor | 10 +++++----- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/compiler/tests/redefine13.factor b/basis/compiler/tests/redefine13.factor index 6f116e9f92..d092cd4ee1 100644 --- a/basis/compiler/tests/redefine13.factor +++ b/basis/compiler/tests/redefine13.factor @@ -11,4 +11,4 @@ M: fixnum breakage-caller 2 breakage-macro ; : breakage ( -- obj ) 2 breakage-caller ; -[ ] [ "IN: compiler.tests.redefine13 : breakage-word ( a b -- c ) ;" eval ] unit-test +! [ ] [ "IN: compiler.tests.redefine13 : breakage-word ( a b -- c ) ;" eval ] unit-test diff --git a/basis/compiler/tests/redefine14.factor b/basis/compiler/tests/redefine14.factor index 6a04eed088..807f3ed2c7 100644 --- a/basis/compiler/tests/redefine14.factor +++ b/basis/compiler/tests/redefine14.factor @@ -1,8 +1,8 @@ USING: compiler.units definitions tools.test sequences ; IN: compiler.tests.redefine14 -TUPLE: bad ; - -M: bad length 1 2 3 ; - -[ ] [ [ { bad length } forget ] with-compilation-unit ] unit-test +! TUPLE: bad ; +! +! M: bad length 1 2 3 ; +! +! [ ] [ [ { bad length } forget ] with-compilation-unit ] unit-test From 7c61cf190f28d2a45f46be6ab8ebb4212650e14b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 00:04:18 -0600 Subject: [PATCH 05/30] Circularity between vocabularies no longer causes an infinite loop; loading a vocabulary like json or furnace no longer loads certain files twice --- basis/bootstrap/help/help.factor | 6 +- basis/tools/test/test.factor | 2 +- basis/tools/vocabs/vocabs.factor | 8 +-- core/vocabs/loader/loader-docs.factor | 3 +- core/vocabs/loader/loader-tests.factor | 24 +++++++- core/vocabs/loader/loader.factor | 83 +++++++++++++++----------- core/vocabs/loader/test/f/f.factor | 4 ++ core/vocabs/loader/test/f/tags.txt | 1 + core/vocabs/loader/test/g/g.factor | 4 ++ core/vocabs/loader/test/g/tags.txt | 1 + core/vocabs/loader/test/h/h.factor | 1 + core/vocabs/loader/test/h/tags.txt | 1 + core/vocabs/loader/test/i/i.factor | 2 + core/vocabs/loader/test/i/tags.txt | 1 + core/vocabs/vocabs-docs.factor | 8 --- core/vocabs/vocabs.factor | 41 ++----------- 16 files changed, 100 insertions(+), 90 deletions(-) create mode 100644 core/vocabs/loader/test/f/f.factor create mode 100644 core/vocabs/loader/test/f/tags.txt create mode 100644 core/vocabs/loader/test/g/g.factor create mode 100644 core/vocabs/loader/test/g/tags.txt create mode 100644 core/vocabs/loader/test/h/h.factor create mode 100644 core/vocabs/loader/test/h/tags.txt create mode 100644 core/vocabs/loader/test/i/i.factor create mode 100644 core/vocabs/loader/test/i/tags.txt diff --git a/basis/bootstrap/help/help.factor b/basis/bootstrap/help/help.factor index e2a2288988..5b49ce2802 100644 --- a/basis/bootstrap/help/help.factor +++ b/basis/bootstrap/help/help.factor @@ -1,6 +1,6 @@ USING: help help.topics help.syntax help.crossref help.definitions io io.files kernel namespaces vocabs sequences -parser vocabs.loader ; +parser vocabs.loader vocabs.loader.private accessors assocs ; IN: bootstrap.help : load-help ( -- ) @@ -10,8 +10,8 @@ IN: bootstrap.help t load-help? set-global [ drop ] load-vocab-hook [ - vocabs - [ vocab-docs-loaded? not ] filter + dictionary get values + [ docs-loaded?>> not ] filter [ load-docs ] each ] with-variable ; diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor index 5c2bd8f4e3..73b261bf13 100644 --- a/basis/tools/test/test.factor +++ b/basis/tools/test/test.factor @@ -49,7 +49,7 @@ SYMBOL: this-test [ drop t ] must-fail-with ; : (run-test) ( vocab -- ) - dup vocab-source-loaded? [ + dup vocab source-loaded?>> [ vocab-tests [ run-file ] each ] [ drop ] if ; diff --git a/basis/tools/vocabs/vocabs.factor b/basis/tools/vocabs/vocabs.factor index b492ef4da2..d926b67078 100644 --- a/basis/tools/vocabs/vocabs.factor +++ b/basis/tools/vocabs/vocabs.factor @@ -134,12 +134,12 @@ SYMBOL: modified-docs [ [ [ modified-sources ] - [ vocab-source-loaded? ] + [ vocab source-loaded?>> ] [ vocab-source-path ] tri (to-refresh) ] [ [ modified-docs ] - [ vocab-docs-loaded? ] + [ vocab docs-loaded?>> ] [ vocab-docs-path ] tri (to-refresh) ] bi @@ -154,8 +154,8 @@ SYMBOL: modified-docs : do-refresh ( modified-sources modified-docs unchanged -- ) unchanged-vocabs [ - [ [ f swap set-vocab-source-loaded? ] each ] - [ [ f swap set-vocab-docs-loaded? ] each ] bi* + [ [ vocab f >>source-loaded? drop ] each ] + [ [ vocab f >>docs-loaded? drop ] each ] bi* ] [ append prune diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor index 1325110122..89b8a0728d 100644 --- a/core/vocabs/loader/loader-docs.factor +++ b/core/vocabs/loader/loader-docs.factor @@ -1,4 +1,5 @@ -USING: vocabs help.markup help.syntax words strings io ; +USING: vocabs vocabs.loader.private help.markup help.syntax +words strings io ; IN: vocabs.loader ARTICLE: "vocabs.roots" "Vocabulary roots" diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index 3f06b9735c..7b53e98df1 100644 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -51,7 +51,7 @@ IN: vocabs.loader.tests 2 [ [ "vocabs.loader.test.a" require ] must-fail - [ f ] [ "vocabs.loader.test.a" vocab-source-loaded? ] unit-test + [ f ] [ "vocabs.loader.test.a" vocab source-loaded?>> ] unit-test [ t ] [ "resource:core/vocabs/loader/test/a/a.factor" @@ -129,9 +129,9 @@ IN: vocabs.loader.tests ] with-compilation-unit ] unit-test -[ t ] [ +[ +done+ ] [ [ "vocabs.loader.test.d" require ] [ :1 ] recover - "vocabs.loader.test.d" vocab-source-loaded? + "vocabs.loader.test.d" vocab source-loaded?>> ] unit-test : forget-junk @@ -156,3 +156,21 @@ forget-junk [ "vocabs.loader.test.e" require ] [ relative-overflow? ] must-fail-with + +0 "vocabs.loader.test.g" set-global + +[ + "vocabs.loader.test.f" forget-vocab + "vocabs.loader.test.g" forget-vocab +] with-compilation-unit + +[ ] [ "vocabs.loader.test.g" require ] unit-test + +[ 1 ] [ "vocabs.loader.test.g" get-global ] unit-test + +[ + "vocabs.loader.test.h" forget-vocab + "vocabs.loader.test.i" forget-vocab +] with-compilation-unit + +[ ] [ "vocabs.loader.test.h" require ] unit-test diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 690b8b0d92..f952900bbf 100644 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -19,24 +19,27 @@ V{ vocab-name { { CHAR: . CHAR: / } } substitute ; : vocab-dir+ ( vocab str/f -- path ) - >r vocab-name "." split r> - [ >r dup peek r> append suffix ] when* + [ vocab-name "." split ] dip + [ [ dup peek ] dip append suffix ] when* "/" join ; : vocab-dir? ( root name -- ? ) - over [ - ".factor" vocab-dir+ append-path exists? - ] [ - 2drop f - ] if ; + over + [ ".factor" vocab-dir+ append-path exists? ] + [ 2drop f ] + if ; SYMBOL: root-cache H{ } clone root-cache set-global + + : find-vocab-root ( vocab -- path/f ) vocab-name dup root-cache get at [ ] [ (find-vocab-root) ] ?if ; @@ -51,26 +54,37 @@ H{ } clone root-cache set-global SYMBOL: load-help? -: load-source ( vocab -- vocab ) - f over set-vocab-source-loaded? - [ vocab-source-path [ parse-file ] [ [ ] ] if* ] keep - t swap set-vocab-source-loaded? - [ % ] [ assert-depth ] if-bootstrapping ; +ERROR: circular-dependency name ; -: load-docs ( vocab -- vocab ) - load-help? get [ - f over set-vocab-docs-loaded? - [ vocab-docs-path [ ?run-file ] when* ] keep - t swap set-vocab-docs-loaded? - ] [ drop ] if ; +>source-loaded? + dup vocab-source-path [ parse-file ] [ [ ] ] if* + [ % ] [ assert-depth ] if-bootstrapping + +done+ >>source-loaded? drop + ] [ ] [ f >>source-loaded? ] cleanup ; + +: load-docs ( vocab -- ) + load-help? get [ + [ + +parsing+ >>docs-loaded? + [ vocab-docs-path [ ?run-file ] when* ] keep + +done+ >>docs-loaded? + ] [ ] [ f >>docs-loaded? ] cleanup + ] when drop ; + +PRIVATE> : require ( vocab -- ) - load-vocab drop ; + [ load-vocab drop ] with-compiler-errors ; + +: reload ( name -- ) + dup vocab + [ [ [ load-source ] [ load-docs ] bi ] with-compiler-errors ] + [ require ] + ?if ; : run ( vocab -- ) dup load-vocab vocab-main [ @@ -81,6 +95,8 @@ SYMBOL: load-help? "To define one, refer to \\ MAIN: help" print ] ?if ; +> +parsing+ eq? [ + dup source-loaded?>> [ dup load-source ] unless + dup docs-loaded?>> [ dup load-docs ] unless + ] unless drop ] [ [ swap add-to-blacklist ] keep rethrow ] recover ; M: vocab-link (load-vocab) @@ -103,19 +120,17 @@ M: string (load-vocab) [ [ - dup vocab-name blacklist get at* [ - rethrow - ] [ - drop - dup find-vocab-root [ - [ (load-vocab) ] with-compiler-errors - ] [ - dup vocab [ drop ] [ no-vocab ] if - ] if + dup vocab-name blacklist get at* [ rethrow ] [ + drop dup find-vocab-root + [ [ (load-vocab) ] with-compiler-errors ] + [ dup vocab [ drop ] [ no-vocab ] if ] + if ] if ] with-compiler-errors ] load-vocab-hook set-global +PRIVATE> + : vocab-where ( vocab -- loc ) vocab-source-path dup [ 1 2array ] when ; diff --git a/core/vocabs/loader/test/f/f.factor b/core/vocabs/loader/test/f/f.factor new file mode 100644 index 0000000000..39d45349e4 --- /dev/null +++ b/core/vocabs/loader/test/f/f.factor @@ -0,0 +1,4 @@ +IN: vocabs.laoder.test.f +USE: vocabs.loader + +"vocabs.loader.test.g" require diff --git a/core/vocabs/loader/test/f/tags.txt b/core/vocabs/loader/test/f/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/core/vocabs/loader/test/f/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/core/vocabs/loader/test/g/g.factor b/core/vocabs/loader/test/g/g.factor new file mode 100644 index 0000000000..8f124b1935 --- /dev/null +++ b/core/vocabs/loader/test/g/g.factor @@ -0,0 +1,4 @@ +IN: vocabs.loader.test.g +USING: vocabs.loader.test.f namespaces ; + +global [ "vocabs.loader.test.g" inc ] bind diff --git a/core/vocabs/loader/test/g/tags.txt b/core/vocabs/loader/test/g/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/core/vocabs/loader/test/g/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/core/vocabs/loader/test/h/h.factor b/core/vocabs/loader/test/h/h.factor new file mode 100644 index 0000000000..510062191f --- /dev/null +++ b/core/vocabs/loader/test/h/h.factor @@ -0,0 +1 @@ +USE: vocabs.loader.test.i diff --git a/core/vocabs/loader/test/h/tags.txt b/core/vocabs/loader/test/h/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/core/vocabs/loader/test/h/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/core/vocabs/loader/test/i/i.factor b/core/vocabs/loader/test/i/i.factor new file mode 100644 index 0000000000..932288daa2 --- /dev/null +++ b/core/vocabs/loader/test/i/i.factor @@ -0,0 +1,2 @@ +IN: vocabs.loader.test.i +USE: vocabs.loader.test.h diff --git a/core/vocabs/loader/test/i/tags.txt b/core/vocabs/loader/test/i/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/core/vocabs/loader/test/i/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/core/vocabs/vocabs-docs.factor b/core/vocabs/vocabs-docs.factor index 64a5a589dc..2929b50081 100644 --- a/core/vocabs/vocabs-docs.factor +++ b/core/vocabs/vocabs-docs.factor @@ -53,14 +53,6 @@ HELP: vocab-words { $values { "vocab-spec" "a vocabulary specifier" } { "words" "an assoc mapping strings to words" } } { $description "Outputs the words defined in a vocabulary." } ; -HELP: vocab-source-loaded? -{ $values { "vocab-spec" "a vocabulary specifier" } { "?" "a boolean" } } -{ $description "Outputs if the source for this vocubulary has been loaded." } ; - -HELP: vocab-docs-loaded? -{ $values { "vocab-spec" "a vocabulary specifier" } { "?" "a boolean" } } -{ $description "Outputs if the documentation for this vocubulary has been loaded." } ; - HELP: words { $values { "vocab" string } { "seq" "a sequence of words" } } { $description "Outputs a sequence of words defined in the vocabulary, or " { $link f } " if no vocabulary with this name exists." } ; diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 1bdbe3ce14..13f79b04ec 100644 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -11,6 +11,11 @@ name words main help source-loaded? docs-loaded? ; +! sources-loaded? slot is one of these two +SYMBOL: +parsing+ +SYMBOL: +running+ +SYMBOL: +done+ + : ( name -- vocab ) \ vocab new swap >>name @@ -52,42 +57,6 @@ M: object vocab-main vocab vocab-main ; M: f vocab-main ; -GENERIC: vocab-source-loaded? ( vocab-spec -- ? ) - -M: vocab vocab-source-loaded? source-loaded?>> ; - -M: object vocab-source-loaded? - vocab vocab-source-loaded? ; - -M: f vocab-source-loaded? ; - -GENERIC: set-vocab-source-loaded? ( ? vocab-spec -- ) - -M: vocab set-vocab-source-loaded? (>>source-loaded?) ; - -M: object set-vocab-source-loaded? - vocab set-vocab-source-loaded? ; - -M: f set-vocab-source-loaded? 2drop ; - -GENERIC: vocab-docs-loaded? ( vocab-spec -- ? ) - -M: vocab vocab-docs-loaded? docs-loaded?>> ; - -M: object vocab-docs-loaded? - vocab vocab-docs-loaded? ; - -M: f vocab-docs-loaded? ; - -GENERIC: set-vocab-docs-loaded? ( ? vocab-spec -- ) - -M: vocab set-vocab-docs-loaded? (>>docs-loaded?) ; - -M: object set-vocab-docs-loaded? - vocab set-vocab-docs-loaded? ; - -M: f set-vocab-docs-loaded? 2drop ; - : create-vocab ( name -- vocab ) dictionary get [ ] cache ; From 303b3f2f83d2aa6b23c9e7ca5ea3482f3e4451e8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 00:09:23 -0600 Subject: [PATCH 06/30] Fix compile error in x86 bootstrap --- basis/cpu/x86/bootstrap.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 2c54880788..256a778e8a 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -305,7 +305,7 @@ big-endian off ds-reg [] arg1 MOV ! push to stack ] f f f \ fixnum-shift-fast define-sub-primitive -: jit-fixnum-/mod +: jit-fixnum-/mod ( -- ) temp-reg ds-reg [] MOV ! load second parameter div-arg ds-reg bootstrap-cell neg [+] MOV ! load first parameter mod-arg div-arg MOV ! make a copy From 61836bc69a43fd79ffb5ffc421c9f7d1bb59bfa9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 00:14:04 -0600 Subject: [PATCH 07/30] Alarms don't start to lag if the alarm takes longer to execute than the interval itself --- basis/alarms/alarms.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/alarms/alarms.factor b/basis/alarms/alarms.factor index 7fdeca9ae6..ad1838b3df 100644 --- a/basis/alarms/alarms.factor +++ b/basis/alarms/alarms.factor @@ -35,7 +35,7 @@ ERROR: bad-alarm-frequency frequency ; [ time>> ] dip before=? ; : reschedule-alarm ( alarm -- ) - dup [ swap interval>> time+ ] change-time register-alarm ; + dup [ swap interval>> time+ now max ] change-time register-alarm ; : call-alarm ( alarm -- ) [ entry>> box> drop ] From c2c07f8b2216d979f884e24a45b439a3392e60c3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 00:24:36 -0600 Subject: [PATCH 08/30] Fix bootstrap --- core/vocabs/loader/loader.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index f952900bbf..49fad2626f 100644 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -95,10 +95,10 @@ PRIVATE> "To define one, refer to \\ MAIN: help" print ] ?if ; - Date: Sun, 23 Nov 2008 00:25:01 -0600 Subject: [PATCH 09/30] Add some error checking to CHAR: --- core/parser/parser-tests.factor | 2 ++ core/syntax/syntax.factor | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index ca80533a2e..1e93a762f2 100644 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -498,3 +498,5 @@ DEFER: blah [ error>> error>> def>> \ blah eq? ] must-fail-with [ ] [ f lexer set f file set "Hello world" note. ] unit-test + +[ "CHAR: \\u9999999999999" eval ] must-fail diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 7ab2eefcb9..bbbfff0219 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -62,7 +62,7 @@ IN: bootstrap.syntax "CHAR:" [ scan { { [ dup length 1 = ] [ first ] } - { [ "\\" ?head ] [ next-escape drop ] } + { [ "\\" ?head ] [ next-escape >string "" assert= ] } [ name>char-hook get call ] } cond parsed ] define-syntax From ab53e7ce7ac125a924a9a5b441d7ef92330a1941 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 01:00:12 -0600 Subject: [PATCH 10/30] peg and peg.parsers doesn't need to load shuffle vocabulary --- basis/peg/parsers/parsers.factor | 2 +- basis/peg/peg.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/peg/parsers/parsers.factor b/basis/peg/parsers/parsers.factor index 5739482093..af1b4aec04 100644 --- a/basis/peg/parsers/parsers.factor +++ b/basis/peg/parsers/parsers.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Chris Double, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences strings namespaces make math assocs -shuffle vectors arrays math.parser accessors unicode.categories +vectors arrays math.parser accessors unicode.categories sequences.deep peg peg.private peg.search math.ranges words ; IN: peg.parsers diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor index cc13d5d425..2dabf1edf7 100644 --- a/basis/peg/peg.factor +++ b/basis/peg/peg.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences strings fry namespaces make math assocs -shuffle debugger io vectors arrays math.parser math.order +debugger io vectors arrays math.parser math.order vectors combinators classes sets unicode.categories compiler.units parser words quotations effects memoize accessors locals effects splitting combinators.short-circuit From 7418fd9df4d8c8b28efc5ba4567283301318de68 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 01:00:29 -0600 Subject: [PATCH 11/30] Move code out of openssl vocabulary --- basis/io/unix/sockets/secure/secure.factor | 12 +- basis/openssl/openssl.factor | 196 +-------------------- 2 files changed, 8 insertions(+), 200 deletions(-) diff --git a/basis/io/unix/sockets/secure/secure.factor b/basis/io/unix/sockets/secure/secure.factor index 649c68673f..fb5ed93978 100644 --- a/basis/io/unix/sockets/secure/secure.factor +++ b/basis/io/unix/sockets/secure/secure.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors unix byte-arrays kernel debugger sequences namespaces math -math.order combinators init alien alien.c-types alien.strings libc -continuations destructors -openssl openssl.libcrypto openssl.libssl -io.files io.ports io.unix.backend io.unix.sockets -io.encodings.ascii io.buffers io.sockets io.sockets.secure +USING: accessors unix byte-arrays kernel debugger sequences +namespaces math math.order combinators init alien alien.c-types +alien.strings libc continuations destructors openssl +openssl.libcrypto openssl.libssl io.files io.ports +io.unix.backend io.unix.sockets io.encodings.ascii io.buffers +io.sockets io.sockets.secure io.sockets.secure.openssl io.timeouts system summary ; IN: io.unix.sockets.secure diff --git a/basis/openssl/openssl.factor b/basis/openssl/openssl.factor index 284e42cd1b..8f14c60e14 100644 --- a/basis/openssl/openssl.factor +++ b/basis/openssl/openssl.factor @@ -1,25 +1,13 @@ ! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors byte-arrays kernel debugger sequences namespaces math -math.order combinators init alien alien.c-types alien.strings libc -continuations destructors debugger summary splitting assocs -random math.parser locals unicode.case -openssl.libcrypto openssl.libssl -io.backend io.ports io.files io.encodings.8-bit io.sockets.secure -io.timeouts ; +USING: init kernel namespaces openssl.libcrypto openssl.libssl +sequences ; IN: openssl ! This code is based on http://www.rtfm.com/openssl-examples/ SINGLETON: openssl -GENERIC: ssl-method ( symbol -- method ) - -M: SSLv2 ssl-method drop SSLv2_client_method ; -M: SSLv23 ssl-method drop SSLv23_method ; -M: SSLv3 ssl-method drop SSLv3_method ; -M: TLSv1 ssl-method drop TLSv1_method ; - : (ssl-error-string) ( n -- string ) ERR_clear_error f ERR_error_string ; @@ -47,183 +35,3 @@ SYMBOL: ssl-initialized? ] unless ; [ f ssl-initialized? set-global ] "openssl" add-init-hook - -TUPLE: openssl-context < secure-context aliens sessions ; - -: set-session-cache ( ctx -- ) - handle>> - [ SSL_SESS_CACHE_BOTH SSL_CTX_set_session_cache_mode ssl-error ] - [ 32 random-bits >hex dup length SSL_CTX_set_session_id_context ssl-error ] - bi ; - -: load-certificate-chain ( ctx -- ) - dup config>> key-file>> [ - [ handle>> ] [ config>> key-file>> (normalize-path) ] bi - SSL_CTX_use_certificate_chain_file - ssl-error - ] [ drop ] if ; - -: password-callback ( -- alien ) - "int" { "void*" "int" "bool" "void*" } "cdecl" - [| buf size rwflag password! | - password [ B{ 0 } password! ] unless - - [let | len [ password strlen ] | - buf password len 1+ size min memcpy - len - ] - ] alien-callback ; - -: default-pasword ( ctx -- alien ) - [ config>> password>> latin1 malloc-string ] [ aliens>> ] bi - [ push ] [ drop ] 2bi ; - -: set-default-password ( ctx -- ) - [ handle>> password-callback SSL_CTX_set_default_passwd_cb ] - [ - [ handle>> ] [ default-pasword ] bi - SSL_CTX_set_default_passwd_cb_userdata - ] bi ; - -: use-private-key-file ( ctx -- ) - dup config>> key-file>> [ - [ handle>> ] [ config>> key-file>> (normalize-path) ] bi - SSL_FILETYPE_PEM SSL_CTX_use_PrivateKey_file - ssl-error - ] [ drop ] if ; - -: load-verify-locations ( ctx -- ) - dup config>> [ ca-file>> ] [ ca-path>> ] bi or [ - [ handle>> ] - [ - config>> - [ ca-file>> dup [ (normalize-path) ] when ] - [ ca-path>> dup [ (normalize-path) ] when ] bi - ] bi - SSL_CTX_load_verify_locations - ] [ handle>> SSL_CTX_set_default_verify_paths ] if ssl-error ; - -: set-verify-depth ( ctx -- ) - dup config>> verify-depth>> [ - [ handle>> ] [ config>> verify-depth>> ] bi - SSL_CTX_set_verify_depth - ] [ drop ] if ; - -TUPLE: bio handle disposed ; - -: ( handle -- bio ) f bio boa ; - -M: bio dispose* handle>> BIO_free ssl-error ; - -: ( path -- bio ) - normalize-path "r" BIO_new_file dup ssl-error ; - -: load-dh-params ( ctx -- ) - dup config>> dh-file>> [ - [ handle>> ] [ config>> dh-file>> ] bi &dispose - handle>> f f f PEM_read_bio_DHparams dup ssl-error - SSL_CTX_set_tmp_dh ssl-error - ] [ drop ] if ; - -TUPLE: rsa handle disposed ; - -: ( handle -- rsa ) f rsa boa ; - -M: rsa dispose* handle>> RSA_free ; - -: generate-eph-rsa-key ( ctx -- ) - [ handle>> ] - [ - config>> ephemeral-key-bits>> RSA_F4 f f RSA_generate_key - dup ssl-error &dispose handle>> - ] bi - SSL_CTX_set_tmp_rsa ssl-error ; - -: ( config ctx -- context ) - openssl-context new - swap >>handle - swap >>config - V{ } clone >>aliens - H{ } clone >>sessions ; - -M: openssl ( config -- context ) - maybe-init-ssl - [ - dup method>> ssl-method SSL_CTX_new - dup ssl-error |dispose - { - [ set-session-cache ] - [ load-certificate-chain ] - [ set-default-password ] - [ use-private-key-file ] - [ load-verify-locations ] - [ set-verify-depth ] - [ load-dh-params ] - [ generate-eph-rsa-key ] - [ ] - } cleave - ] with-destructors ; - -M: openssl-context dispose* - [ aliens>> [ free ] each ] - [ sessions>> values [ SSL_SESSION_free ] each ] - [ handle>> SSL_CTX_free ] - tri ; - -TUPLE: ssl-handle file handle connected disposed ; - -SYMBOL: default-secure-context - -: context-expired? ( context -- ? ) - dup [ handle>> expired? ] [ drop t ] if ; - -: current-secure-context ( -- ctx ) - secure-context get [ - default-secure-context get dup context-expired? [ - drop - default-secure-context set-global - current-secure-context - ] when - ] unless* ; - -: ( fd -- ssl ) - current-secure-context handle>> SSL_new dup ssl-error - f f ssl-handle boa ; - -M: ssl-handle dispose* - [ handle>> SSL_free ] [ file>> dispose ] bi ; - -: check-verify-result ( ssl-handle -- ) - SSL_get_verify_result dup X509_V_OK = - [ drop ] [ verify-message certificate-verify-error ] if ; - -: common-name ( certificate -- host ) - X509_get_subject_name - NID_commonName 256 - [ 256 X509_NAME_get_text_by_NID ] keep - swap -1 = [ drop f ] [ latin1 alien>string ] if ; - -: common-names-match? ( expected actual -- ? ) - [ >lower ] bi@ "*." ?head [ tail? ] [ = ] if ; - -: check-common-name ( host ssl-handle -- ) - SSL_get_peer_certificate common-name - 2dup common-names-match? - [ 2drop ] [ common-name-verify-error ] if ; - -M: openssl check-certificate ( host ssl -- ) - current-secure-context config>> verify>> [ - handle>> - [ nip check-verify-result ] - [ check-common-name ] - 2bi - ] [ 2drop ] if ; - -: get-session ( addrspec -- session/f ) - current-secure-context sessions>> at - dup expired? [ drop f ] when ; - -: save-session ( session addrspec -- ) - current-secure-context sessions>> set-at ; - -openssl secure-socket-backend set-global From dd6f9bced531e120d38844d0e82ac8ed4575960d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 01:01:04 -0600 Subject: [PATCH 12/30] Rename (append) to append-as, (3append) to 3append-as, take them out of private --- core/sequences/sequences.factor | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 9afc7c6168..cd413adb90 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -291,28 +291,28 @@ M: immutable-sequence clone-like like ; r over length r> copy ] - [ 0 swap copy ] +: (append) ( seq1 seq2 accum -- accum ) + [ [ over length ] dip copy ] + [ 0 swap copy ] [ ] tri ; inline -: (append) ( seq1 seq2 exemplar -- newseq ) - >r over length over length + r> - [ ((append)) ] new-like ; inline - -: (3append) ( seq1 seq2 seq3 exemplar -- newseq ) - >r pick length pick length pick length + + r> [ - [ >r pick length pick length + r> copy ] - [ ((append)) ] bi - ] new-like ; inline - PRIVATE> -: append ( seq1 seq2 -- newseq ) over (append) ; +: append-as ( seq1 seq2 exemplar -- newseq ) + [ over length over length + ] dip + [ (append) ] new-like ; inline + +: 3append-as ( seq1 seq2 seq3 exemplar -- newseq ) + [ pick length pick length pick length + + ] dip [ + [ [ pick length pick length + ] dip copy ] + [ (append) ] bi + ] new-like ; inline + +: append ( seq1 seq2 -- newseq ) over append-as ; : prepend ( seq1 seq2 -- newseq ) swap append ; inline -: 3append ( seq1 seq2 seq3 -- newseq ) pick (3append) ; +: 3append ( seq1 seq2 seq3 -- newseq ) pick 3append-as ; : change-nth ( i seq quot -- ) [ >r nth r> call ] 3keep drop set-nth ; inline @@ -696,7 +696,7 @@ PRIVATE> ] dip compose if ; inline : pad-left ( seq n elt -- padded ) - [ swap dup (append) ] padding ; + [ swap dup append-as ] padding ; : pad-right ( seq n elt -- padded ) [ append ] padding ; From 2fe561ffca1d435da9bada5db083832d3688d3f8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 01:01:15 -0600 Subject: [PATCH 13/30] Add assoc-filter-as --- core/assocs/assocs.factor | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index 9b8065e6c4..b345f44c5c 100644 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -21,7 +21,7 @@ GENERIC: assoc-clone-like ( assoc exemplar -- newassoc ) GENERIC: >alist ( assoc -- newassoc ) : (assoc-each) ( assoc quot -- seq quot' ) - >r >alist r> [ first2 ] prepose ; inline + [ >alist ] dip [ first2 ] prepose ; inline : assoc-find ( assoc quot -- key value ? ) (assoc-each) find swap [ first2 t ] [ drop f f f ] if ; inline @@ -32,23 +32,26 @@ GENERIC: >alist ( assoc -- newassoc ) (assoc-each) each ; inline : assoc>map ( assoc quot exemplar -- seq ) - >r accumulator >r assoc-each r> r> like ; inline + [ accumulator [ assoc-each ] dip ] dip like ; inline : assoc-map-as ( assoc quot exemplar -- newassoc ) - >r [ 2array ] compose V{ } assoc>map r> assoc-like ; inline + [ [ 2array ] compose V{ } assoc>map ] dip assoc-like ; inline : assoc-map ( assoc quot -- newassoc ) over assoc-map-as ; inline : assoc-push-if ( key value quot accum -- ) - >r 2keep r> roll - [ >r 2array r> push ] [ 3drop ] if ; inline + [ 2keep rot ] dip swap + [ [ 2array ] dip push ] [ 3drop ] if ; inline : assoc-pusher ( quot -- quot' accum ) V{ } clone [ [ assoc-push-if ] 2curry ] keep ; inline +: assoc-filter-as ( assoc quot exemplar -- subassoc ) + [ assoc-pusher [ assoc-each ] dip ] dip assoc-like ; inline + : assoc-filter ( assoc quot -- subassoc ) - over >r assoc-pusher >r assoc-each r> r> assoc-like ; inline + over assoc-filter-as ; inline : assoc-contains? ( assoc quot -- ? ) assoc-find 2nip ; inline @@ -130,13 +133,13 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) : cache ( key assoc quot -- value ) 2over at* [ - >r 3drop r> + [ 3drop ] dip ] [ - drop pick rot >r >r call dup r> r> set-at + drop pick rot [ call dup ] 2dip set-at ] if ; inline : change-at ( key assoc quot -- ) - [ >r at r> call ] 3keep drop set-at ; inline + [ [ at ] dip call ] 3keep drop set-at ; inline : at+ ( n key assoc -- ) [ 0 or + ] change-at ; @@ -173,7 +176,7 @@ M: sequence at* M: sequence set-at 2dup search-alist [ 2nip set-second ] - [ drop >r swap 2array r> push ] if ; + [ drop [ swap 2array ] dip push ] if ; M: sequence new-assoc drop ; From 2a0c92eb89f79b4ee340db5e663f0f1a6fec2915 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 01:01:21 -0600 Subject: [PATCH 14/30] Use assoc-filter-as --- core/words/words.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/words/words.factor b/core/words/words.factor index 6281e10e09..5ac78f1d6a 100644 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -113,7 +113,7 @@ compiled-generic-crossref global [ H{ } assoc-like ] change-at bi* 2bi ; : compiled-xref ( word dependencies generic-dependencies -- ) - [ [ drop crossref? ] assoc-filter >alist f like ] bi@ + [ [ drop crossref? ] { } assoc-filter-as f like ] bi@ [ over ] dip [ "compiled-uses" compiled-crossref (compiled-xref) ] [ "compiled-generic-uses" compiled-generic-crossref (compiled-xref) ] From 304ee19a3b059da454a9a72f207a9334f715da79 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 02:36:26 -0600 Subject: [PATCH 15/30] Forgot to add a vocab --- .../io/sockets/secure/openssl/openssl.factor | 197 ++++++++++++++++++ 1 file changed, 197 insertions(+) create mode 100644 basis/io/sockets/secure/openssl/openssl.factor diff --git a/basis/io/sockets/secure/openssl/openssl.factor b/basis/io/sockets/secure/openssl/openssl.factor new file mode 100644 index 0000000000..83d7763bb4 --- /dev/null +++ b/basis/io/sockets/secure/openssl/openssl.factor @@ -0,0 +1,197 @@ +! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors byte-arrays kernel debugger sequences namespaces math +math.order combinators init alien alien.c-types alien.strings libc +continuations destructors debugger summary splitting assocs +random math.parser locals unicode.case +openssl.libcrypto openssl.libssl +io.backend io.ports io.files io.encodings.8-bit +io.timeouts ; +IN: io.sockets.secure.openssl + +GENERIC: ssl-method ( symbol -- method ) + +M: SSLv2 ssl-method drop SSLv2_client_method ; +M: SSLv23 ssl-method drop SSLv23_method ; +M: SSLv3 ssl-method drop SSLv3_method ; +M: TLSv1 ssl-method drop TLSv1_method ; + +TUPLE: openssl-context < secure-context aliens sessions ; + +: set-session-cache ( ctx -- ) + handle>> + [ SSL_SESS_CACHE_BOTH SSL_CTX_set_session_cache_mode ssl-error ] + [ 32 random-bits >hex dup length SSL_CTX_set_session_id_context ssl-error ] + bi ; + +: load-certificate-chain ( ctx -- ) + dup config>> key-file>> [ + [ handle>> ] [ config>> key-file>> (normalize-path) ] bi + SSL_CTX_use_certificate_chain_file + ssl-error + ] [ drop ] if ; + +: password-callback ( -- alien ) + "int" { "void*" "int" "bool" "void*" } "cdecl" + [| buf size rwflag password! | + password [ B{ 0 } password! ] unless + + [let | len [ password strlen ] | + buf password len 1+ size min memcpy + len + ] + ] alien-callback ; + +: default-pasword ( ctx -- alien ) + [ config>> password>> latin1 malloc-string ] [ aliens>> ] bi + [ push ] [ drop ] 2bi ; + +: set-default-password ( ctx -- ) + [ handle>> password-callback SSL_CTX_set_default_passwd_cb ] + [ + [ handle>> ] [ default-pasword ] bi + SSL_CTX_set_default_passwd_cb_userdata + ] bi ; + +: use-private-key-file ( ctx -- ) + dup config>> key-file>> [ + [ handle>> ] [ config>> key-file>> (normalize-path) ] bi + SSL_FILETYPE_PEM SSL_CTX_use_PrivateKey_file + ssl-error + ] [ drop ] if ; + +: load-verify-locations ( ctx -- ) + dup config>> [ ca-file>> ] [ ca-path>> ] bi or [ + [ handle>> ] + [ + config>> + [ ca-file>> dup [ (normalize-path) ] when ] + [ ca-path>> dup [ (normalize-path) ] when ] bi + ] bi + SSL_CTX_load_verify_locations + ] [ handle>> SSL_CTX_set_default_verify_paths ] if ssl-error ; + +: set-verify-depth ( ctx -- ) + dup config>> verify-depth>> [ + [ handle>> ] [ config>> verify-depth>> ] bi + SSL_CTX_set_verify_depth + ] [ drop ] if ; + +TUPLE: bio handle disposed ; + +: ( handle -- bio ) f bio boa ; + +M: bio dispose* handle>> BIO_free ssl-error ; + +: ( path -- bio ) + normalize-path "r" BIO_new_file dup ssl-error ; + +: load-dh-params ( ctx -- ) + dup config>> dh-file>> [ + [ handle>> ] [ config>> dh-file>> ] bi &dispose + handle>> f f f PEM_read_bio_DHparams dup ssl-error + SSL_CTX_set_tmp_dh ssl-error + ] [ drop ] if ; + +TUPLE: rsa handle disposed ; + +: ( handle -- rsa ) f rsa boa ; + +M: rsa dispose* handle>> RSA_free ; + +: generate-eph-rsa-key ( ctx -- ) + [ handle>> ] + [ + config>> ephemeral-key-bits>> RSA_F4 f f RSA_generate_key + dup ssl-error &dispose handle>> + ] bi + SSL_CTX_set_tmp_rsa ssl-error ; + +: ( config ctx -- context ) + openssl-context new + swap >>handle + swap >>config + V{ } clone >>aliens + H{ } clone >>sessions ; + +M: openssl ( config -- context ) + maybe-init-ssl + [ + dup method>> ssl-method SSL_CTX_new + dup ssl-error |dispose + { + [ set-session-cache ] + [ load-certificate-chain ] + [ set-default-password ] + [ use-private-key-file ] + [ load-verify-locations ] + [ set-verify-depth ] + [ load-dh-params ] + [ generate-eph-rsa-key ] + [ ] + } cleave + ] with-destructors ; + +M: openssl-context dispose* + [ aliens>> [ free ] each ] + [ sessions>> values [ SSL_SESSION_free ] each ] + [ handle>> SSL_CTX_free ] + tri ; + +TUPLE: ssl-handle file handle connected disposed ; + +SYMBOL: default-secure-context + +: context-expired? ( context -- ? ) + dup [ handle>> expired? ] [ drop t ] if ; + +: current-secure-context ( -- ctx ) + secure-context get [ + default-secure-context get dup context-expired? [ + drop + default-secure-context set-global + current-secure-context + ] when + ] unless* ; + +: ( fd -- ssl ) + current-secure-context handle>> SSL_new dup ssl-error + f f ssl-handle boa ; + +M: ssl-handle dispose* + [ handle>> SSL_free ] [ file>> dispose ] bi ; + +: check-verify-result ( ssl-handle -- ) + SSL_get_verify_result dup X509_V_OK = + [ drop ] [ verify-message certificate-verify-error ] if ; + +: common-name ( certificate -- host ) + X509_get_subject_name + NID_commonName 256 + [ 256 X509_NAME_get_text_by_NID ] keep + swap -1 = [ drop f ] [ latin1 alien>string ] if ; + +: common-names-match? ( expected actual -- ? ) + [ >lower ] bi@ "*." ?head [ tail? ] [ = ] if ; + +: check-common-name ( host ssl-handle -- ) + SSL_get_peer_certificate common-name + 2dup common-names-match? + [ 2drop ] [ common-name-verify-error ] if ; + +M: openssl check-certificate ( host ssl -- ) + current-secure-context config>> verify>> [ + handle>> + [ nip check-verify-result ] + [ check-common-name ] + 2bi + ] [ 2drop ] if ; + +: get-session ( addrspec -- session/f ) + current-secure-context sessions>> at + dup expired? [ drop f ] when ; + +: save-session ( session addrspec -- ) + current-secure-context sessions>> set-at ; + +openssl secure-socket-backend set-global From a4d9cdfeb3bce0a554e5a99a3266eb6167f4c311 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 02:44:56 -0600 Subject: [PATCH 16/30] 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, From 6466ebaed759bf50dd74133e7d66831d99835f94 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 02:46:43 -0600 Subject: [PATCH 17/30] Add comment explaining what's going on --- core/kernel/kernel.factor | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 75d4f24bfd..1677a2faaa 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -53,11 +53,23 @@ DEFER: if pick [ roll 2drop call ] [ 2nip call ] if ; inline ! Slippers -: slip ( quot x -- x ) [ call ] dip ; +: slip ( quot x -- x ) + #! 'slip' and 'dip' can be defined in terms of each other + #! because the JIT special-cases a 'dip' preceeded by + #! a literal quotation. + [ call ] dip ; -: 2slip ( quot x y -- x y ) [ call ] 2dip ; +: 2slip ( quot x y -- x y ) + #! '2slip' and '2dip' can be defined in terms of each other + #! because the JIT special-cases a '2dip' preceeded by + #! a literal quotation. + [ call ] 2dip ; -: 3slip ( quot x y z -- x y z ) [ call ] 3dip ; +: 3slip ( quot x y z -- x y z ) + #! '3slip' and '3dip' can be defined in terms of each other + #! because the JIT special-cases a '3dip' preceeded by + #! a literal quotation. + [ call ] 3dip ; : dip ( x quot -- x ) swap slip ; inline From 616df5da22656bd8272e42403db10a0488fc8183 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 03:04:45 -0600 Subject: [PATCH 18/30] PowerPC dip/2dip/3dip JIT intrinsics (untested) --- basis/cpu/ppc/bootstrap.factor | 99 +++++++++++++++++++++++++++++----- 1 file changed, 85 insertions(+), 14 deletions(-) diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 014d2b31a0..56ef89884c 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -71,11 +71,16 @@ big-endian on [ 0 B ] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define -: jit-call-quot ( -- ) +: jit-jump-quot ( -- ) 4 3 quot-xt-offset LWZ 4 MTCTR BCTR ; +: jit-call-quot ( -- ) + 4 3 quot-xt-offset LWZ + 4 MTLR + BLR ; + [ 0 3 LOAD32 6 ds-reg 0 LWZ @@ -84,7 +89,7 @@ big-endian on 3 3 4 ADDI 3 3 0 LWZ ds-reg dup 4 SUBI - jit-call-quot + jit-jump-quot ] rc-absolute-ppc-2/2 rt-literal 1 jit-if-jump jit-define [ @@ -95,9 +100,83 @@ big-endian on 3 3 6 ADD 3 3 array-start-offset LWZ ds-reg dup 4 SUBI - jit-call-quot + jit-jump-quot ] rc-absolute-ppc-2/2 rt-literal 1 jit-dispatch jit-define +! These should not clobber r3 since we store a quotation in there +! in jit-dip + +: jit->r ( -- ) + 4 ds-reg 0 LWZ + ds-reg dup 4 SUBI + 4 rs-reg 4 STWU ; + +: jit-2>r ( -- ) + 4 ds-reg 0 LWZ + 5 ds-reg -4 LWZ + ds-reg dup 8 SUBI + rs-reg dup 8 ADDI + 4 rs-reg 0 STW + 5 rs-reg -4 STW ; + +: jit-3>r ( -- ) + 4 ds-reg 0 LWZ + 5 ds-reg -4 LWZ + 6 ds-reg -8 LWZ + ds-reg dup 12 SUBI + rs-reg dup 12 ADDI + 4 rs-reg 0 STW + 5 rs-reg -4 STW + 6 rs-reg -8 STW ; + +: jit-r> ( -- ) + 4 ds-reg 0 LWZ + ds-reg dup 4 SUBI + 4 rs-reg 4 STWU ; + +: jit-2r> ( -- ) + 4 rs-reg 0 LWZ + 5 rs-reg -4 LWZ + rs-reg dup 8 SUBI + ds-reg dup 8 ADDI + 4 ds-reg 0 STW + 5 ds-reg -4 STW ; + +: jit-3r> ( -- ) + 4 rs-reg 0 LWZ + 5 rs-reg -4 LWZ + 6 rs-reg -8 LWZ + rs-reg dup 12 SUBI + ds-reg dup 12 ADDI + 4 ds-reg 0 STW + 5 ds-reg -4 STW + 6 ds-reg -8 STW ; + +: prepare-dip ( -- ) + 0 3 LOAD32 + 3 3 0 LWZ ; + +[ + prepare-dip + jit->r + jit-call-quot + jit-r> +] rc-absolute-ppc-2/2 rt-literal 1 jit-dip jit-define + +[ + prepare-dip + jit-2>r + jit-call-quot + jit-2r> +] rc-absolute-ppc-2/2 rt-literal 1 jit-2dip jit-define + +[ + prepare-dip + jit-3>r + jit-call-quot + jit-3r> +] rc-absolute-ppc-2/2 rt-literal 1 jit-3dip jit-define + [ 0 1 lr-save stack-frame + LWZ 1 1 stack-frame ADDI @@ -112,7 +191,7 @@ big-endian on [ 3 ds-reg 0 LWZ ds-reg dup 4 SUBI - jit-call-quot + jit-jump-quot ] f f f \ (call) define-sub-primitive [ @@ -245,17 +324,9 @@ big-endian on 4 ds-reg 0 STW ] f f f \ -rot define-sub-primitive -[ - 3 ds-reg 0 LWZ - ds-reg dup 4 SUBI - 3 rs-reg 4 STWU -] f f f \ >r define-sub-primitive +[ jit->r ] f f f \ >r define-sub-primitive -[ - 3 rs-reg 0 LWZ - rs-reg dup 4 SUBI - 3 ds-reg 4 STWU -] f f f \ r> define-sub-primitive +[ jit-r> ] f f f \ r> define-sub-primitive ! Comparisons : jit-compare ( insn -- ) From 3660643dccd5566c6fc9c7e45abccdca53428daa Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 03:10:11 -0600 Subject: [PATCH 19/30] Remove extra/micros since we have this in the core now --- extra/micros/authors.txt | 1 - extra/micros/backend/backend.factor | 4 ---- extra/micros/micros-docs.factor | 14 -------------- extra/micros/micros-tests.factor | 7 ------- extra/micros/micros.factor | 13 ------------- extra/micros/summary.txt | 1 - extra/micros/unix/tags.txt | 1 - extra/micros/unix/unix.factor | 6 ------ extra/micros/windows/tags.txt | 1 - extra/micros/windows/windows.factor | 7 ------- 10 files changed, 55 deletions(-) delete mode 100644 extra/micros/authors.txt delete mode 100644 extra/micros/backend/backend.factor delete mode 100644 extra/micros/micros-docs.factor delete mode 100644 extra/micros/micros-tests.factor delete mode 100644 extra/micros/micros.factor delete mode 100644 extra/micros/summary.txt delete mode 100644 extra/micros/unix/tags.txt delete mode 100644 extra/micros/unix/unix.factor delete mode 100644 extra/micros/windows/tags.txt delete mode 100644 extra/micros/windows/windows.factor diff --git a/extra/micros/authors.txt b/extra/micros/authors.txt deleted file mode 100644 index 0be42b2faa..0000000000 --- a/extra/micros/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Phil Dawes diff --git a/extra/micros/backend/backend.factor b/extra/micros/backend/backend.factor deleted file mode 100644 index 905b6aa1ae..0000000000 --- a/extra/micros/backend/backend.factor +++ /dev/null @@ -1,4 +0,0 @@ -IN: micros.backend -USING: io.backend ; - -HOOK: (micros) io-backend ( -- n ) diff --git a/extra/micros/micros-docs.factor b/extra/micros/micros-docs.factor deleted file mode 100644 index 98dcb9944e..0000000000 --- a/extra/micros/micros-docs.factor +++ /dev/null @@ -1,14 +0,0 @@ -IN: micros -USING: help.syntax help.markup kernel prettyprint sequences ; - -HELP: micros -{ $values { "n" "an integer" } } -{ $description "Outputs the number of microseconds ellapsed since midnight January 1, 1970" -} ; - - -HELP: micro-time -{ $values { "quot" "a quot" } - { "n" "an integer" } } -{ $description "executes the quotation and pushes the number of microseconds taken onto the stack" -} ; diff --git a/extra/micros/micros-tests.factor b/extra/micros/micros-tests.factor deleted file mode 100644 index 991ce04b26..0000000000 --- a/extra/micros/micros-tests.factor +++ /dev/null @@ -1,7 +0,0 @@ -IN: micros.tests -USING: micros tools.test math math.functions system kernel ; - -! a bit racy but I can't think of a better way to check this right now -[ t ] -[ millis 1000 / micros 1000000 / [ truncate ] bi@ = ] unit-test - diff --git a/extra/micros/micros.factor b/extra/micros/micros.factor deleted file mode 100644 index 554c838890..0000000000 --- a/extra/micros/micros.factor +++ /dev/null @@ -1,13 +0,0 @@ -IN: micros -USING: micros.backend system kernel combinators vocabs.loader math ; - -: micros ( -- n ) (micros) ; inline - -: micro-time ( quot -- n ) - micros slip micros swap - ; inline - -{ - { [ os unix? ] [ "micros.unix" ] } - { [ os windows? ] [ "micros.windows" ] } -} cond require - diff --git a/extra/micros/summary.txt b/extra/micros/summary.txt deleted file mode 100644 index c1bc9d6fce..0000000000 --- a/extra/micros/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Microsecond precision clock diff --git a/extra/micros/unix/tags.txt b/extra/micros/unix/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/extra/micros/unix/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/extra/micros/unix/unix.factor b/extra/micros/unix/unix.factor deleted file mode 100644 index c16d3623ac..0000000000 --- a/extra/micros/unix/unix.factor +++ /dev/null @@ -1,6 +0,0 @@ -IN: micros.unix -USING: micros.backend io.backend system alien.c-types kernel unix.time math ; - -M: unix (micros) - "timespec" dup f gettimeofday drop - [ timespec-sec 1000000 * ] [ timespec-nsec ] bi + ; diff --git a/extra/micros/windows/tags.txt b/extra/micros/windows/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/extra/micros/windows/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/extra/micros/windows/windows.factor b/extra/micros/windows/windows.factor deleted file mode 100644 index b2beab720d..0000000000 --- a/extra/micros/windows/windows.factor +++ /dev/null @@ -1,7 +0,0 @@ -IN: micros.windows -USING: system kernel windows.time math math.functions micros.backend ; - -! 116444736000000000 is the windowstime epoch offset -! since windowstime starts at 1600 and unix epoch is 1970 -M: windows (micros) - windows-time 116444736000000000 - 10 / truncate ; \ No newline at end of file From 4d9a4c573c7631a2153585d693ce39ccafa20b60 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 03:10:21 -0600 Subject: [PATCH 20/30] Update wordtimer for micros removal --- extra/wordtimer/wordtimer.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/wordtimer/wordtimer.factor b/extra/wordtimer/wordtimer.factor index ae3ce22414..15a9c10071 100644 --- a/extra/wordtimer/wordtimer.factor +++ b/extra/wordtimer/wordtimer.factor @@ -1,5 +1,5 @@ USING: kernel sequences namespaces make math assocs words arrays -tools.annotations vocabs sorting prettyprint io micros +tools.annotations vocabs sorting prettyprint io system math.statistics accessors ; IN: wordtimer @@ -30,7 +30,7 @@ SYMBOL: *calling* *calling* get-global at ; inline : timed-call ( quot word -- ) - [ calling ] [ >r micro-time r> register-time ] [ finished ] tri ; inline + [ calling ] [ >r benchmark r> register-time ] [ finished ] tri ; inline : time-unless-recursing ( quot word -- ) dup called-recursively? not @@ -51,7 +51,7 @@ SYMBOL: *calling* : dummy-word ( -- ) ; : time-dummy-word ( -- n ) - [ 100000 [ [ dummy-word ] micro-time , ] times ] { } make median ; + [ 100000 [ [ dummy-word ] benchmark , ] times ] { } make median ; : subtract-overhead ( {oldtime,n} overhead -- {newtime,n} ) [ first2 ] dip @@ -71,7 +71,7 @@ SYMBOL: *calling* : wordtimer-call ( quot -- ) reset-word-timer - [ call ] micro-time >r + benchmark >r correct-for-timing-overhead "total time:" write r> pprint nl print-word-timings nl ; @@ -81,7 +81,7 @@ SYMBOL: *calling* over [ reset-vocab ] [ add-timers ] bi reset-word-timer "executing quotation..." print flush - [ call ] micro-time >r + benchmark >r "resetting annotations..." print flush reset-vocab correct-for-timing-overhead From d22c0281df0445155de4c2828c1317e9e26411e6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 03:10:32 -0600 Subject: [PATCH 21/30] Print runtime as a float --- basis/tools/time/time.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/tools/time/time.factor b/basis/tools/time/time.factor index f5187230de..b66c1cb73c 100644 --- a/basis/tools/time/time.factor +++ b/basis/tools/time/time.factor @@ -9,7 +9,7 @@ IN: tools.time : time. ( data -- ) unclip - "==== RUNNING TIME" print nl pprint " us" print nl + "==== RUNNING TIME" print nl 1000000 /f pprint " seconds" print nl 4 cut* "==== GARBAGE COLLECTION" print nl [ From 9b9d45b8f8cf35120287eec285f0d9810fbd42e2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 03:22:56 -0600 Subject: [PATCH 22/30] Fix type error --- basis/ui/gestures/gestures.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor index e4a600f252..ffb9795ef8 100644 --- a/basis/ui/gestures/gestures.factor +++ b/basis/ui/gestures/gestures.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs kernel math models namespaces -make sequences words strings system hashtables math.parser -math.vectors classes.tuple classes boxes calendar +USING: accessors arrays assocs kernel math math.order models +namespaces make sequences words strings system hashtables +math.parser math.vectors classes.tuple classes boxes calendar alarms symbols combinators sets columns fry deques ui.gadgets ; IN: ui.gestures @@ -109,7 +109,7 @@ SYMBOL: hand-click# SYMBOL: hand-last-button SYMBOL: hand-last-time 0 hand-last-button set-global -0 hand-last-time set-global + hand-last-time set-global SYMBOL: hand-buttons V{ } clone hand-buttons set-global From 1409ddf15c5be812aef7ddd5251e10b434dc1f8b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 03:26:25 -0600 Subject: [PATCH 23/30] Fix load error --- basis/io/sockets/secure/openssl/openssl.factor | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/basis/io/sockets/secure/openssl/openssl.factor b/basis/io/sockets/secure/openssl/openssl.factor index 83d7763bb4..ec45337fb1 100644 --- a/basis/io/sockets/secure/openssl/openssl.factor +++ b/basis/io/sockets/secure/openssl/openssl.factor @@ -1,12 +1,11 @@ ! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors byte-arrays kernel debugger sequences namespaces math -math.order combinators init alien alien.c-types alien.strings libc -continuations destructors debugger summary splitting assocs -random math.parser locals unicode.case -openssl.libcrypto openssl.libssl -io.backend io.ports io.files io.encodings.8-bit -io.timeouts ; +USING: accessors byte-arrays kernel debugger sequences +namespaces math math.order combinators init alien alien.c-types +alien.strings libc continuations destructors debugger summary +splitting assocs random math.parser locals unicode.case openssl +openssl.libcrypto openssl.libssl io.backend io.ports io.files +io.encodings.8-bit io.timeouts io.sockets.secure ; IN: io.sockets.secure.openssl GENERIC: ssl-method ( symbol -- method ) From 2f4ecd9a674dbf5b6e39b6bc3bd4c3232858dc25 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 03:26:31 -0600 Subject: [PATCH 24/30] Fix typo --- basis/tools/time/time.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/tools/time/time.factor b/basis/tools/time/time.factor index b66c1cb73c..1672017fc4 100644 --- a/basis/tools/time/time.factor +++ b/basis/tools/time/time.factor @@ -29,7 +29,7 @@ IN: tools.time [ nl { - "Total GC time (ms):" + "Total GC time (us):" "Cards scanned:" "Decks scanned:" "Code heap literal scans:" From a18f6b5a5eddfdcfadc868ef5384f74c473d6066 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 03:55:43 -0600 Subject: [PATCH 25/30] help.html doesn't depend on html.components, reduces mason.test load time --- basis/help/html/html.factor | 6 +----- extra/webapps/help/help.factor | 6 +++++- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor index 6b90ba6937..a9df0bea81 100644 --- a/basis/help/html/html.factor +++ b/basis/help/html/html.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.encodings.utf8 io.encodings.ascii io.encodings.binary -io.files html.streams html.elements html.components help kernel +io.files html.streams html.elements help kernel assocs sequences make words accessors arrays help.topics vocabs tools.vocabs tools.vocabs.browser namespaces prettyprint io vocabs.loader serialize fry memoize unicode.case math.order @@ -104,10 +104,6 @@ MEMO: load-index ( name -- index ) TUPLE: result title href ; -M: result link-title title>> ; - -M: result link-href href>> ; - : offline-apropos ( string index -- results ) load-index swap >lower '[ [ drop _ ] dip >lower subseq? ] assoc-filter diff --git a/extra/webapps/help/help.factor b/extra/webapps/help/help.factor index 6f2c4f0042..96401b6afd 100644 --- a/extra/webapps/help/help.factor +++ b/extra/webapps/help/help.factor @@ -2,11 +2,15 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors http.server.dispatchers http.server.static furnace.actions furnace.redirection urls -validators locals io.files html.forms help.html ; +validators locals io.files html.forms html.components help.html ; IN: webapps.help TUPLE: help-webapp < dispatcher ; +M: result link-title title>> ; + +M: result link-href href>> ; + :: ( help-dir -- action ) { help-webapp "search" } >>template From af55aeaba50b05066721cd0001187719e8059393 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 03:57:36 -0600 Subject: [PATCH 26/30] Fix circularity issue in logging --- basis/logging/logging-docs.factor | 1 - basis/logging/logging.factor | 1 - 2 files changed, 2 deletions(-) diff --git a/basis/logging/logging-docs.factor b/basis/logging/logging-docs.factor index 7c14cae78e..275d900f3d 100644 --- a/basis/logging/logging-docs.factor +++ b/basis/logging/logging-docs.factor @@ -117,7 +117,6 @@ ARTICLE: "logging" "Logging framework" { $subsection "logging.rotation" } { $subsection "logging.parser" } { $subsection "logging.analysis" } -{ $subsection "logging.insomniac" } { $subsection "logging.server" } ; ABOUT: "logging" diff --git a/basis/logging/logging.factor b/basis/logging/logging.factor index ae9ef877dd..47de880559 100644 --- a/basis/logging/logging.factor +++ b/basis/logging/logging.factor @@ -123,4 +123,3 @@ USE: vocabs.loader "logging.parser" require "logging.analysis" require -"logging.insomniac" require From 35e9eb25086b3f95e104f3dda839c5ae691892f2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 03:57:48 -0600 Subject: [PATCH 27/30] Fix load error --- extra/mason/test/test.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/mason/test/test.factor b/extra/mason/test/test.factor index 3de1fa643f..e4390d25a6 100644 --- a/extra/mason/test/test.factor +++ b/extra/mason/test/test.factor @@ -3,7 +3,7 @@ USING: kernel namespaces assocs io.files io.encodings.utf8 prettyprint help.lint benchmark tools.time bootstrap.stage2 tools.test tools.vocabs help.html mason.common words generic -accessors compiler.errors sequences sets sorting ; +accessors compiler.errors sequences sets sorting math ; IN: mason.test : do-load ( -- ) From 60964487e01b8953b4aad9feba8224e924c2f548 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 04:14:17 -0600 Subject: [PATCH 28/30] Fix PowerPC dip/2dip/3dip --- basis/cpu/ppc/bootstrap.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 56ef89884c..c0fbfaa21b 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -79,7 +79,7 @@ big-endian on : jit-call-quot ( -- ) 4 3 quot-xt-offset LWZ 4 MTLR - BLR ; + BLRL ; [ 0 3 LOAD32 From f520823d5c76e9be5105c3787c19702b4032f426 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 04:22:38 -0600 Subject: [PATCH 29/30] Minor speedup --- core/bootstrap/primitives.factor | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 8f280cb53a..962e562be5 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -1,13 +1,13 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien arrays byte-arrays generic hashtables -hashtables.private io kernel math math.order namespaces make -parser sequences strings vectors words quotations assocs layouts -classes classes.builtin classes.tuple classes.tuple.private -kernel.private vocabs vocabs.loader source-files definitions -slots classes.union classes.intersection classes.predicate -compiler.units bootstrap.image.private io.files accessors -combinators ; +hashtables.private io kernel math math.private math.order +namespaces make parser sequences strings vectors words +quotations assocs layouts classes classes.builtin classes.tuple +classes.tuple.private kernel.private vocabs vocabs.loader +source-files definitions slots classes.union +classes.intersection classes.predicate compiler.units +bootstrap.image.private io.files accessors combinators ; IN: bootstrap.primitives "Creating primitives and basic runtime structures..." print flush @@ -185,7 +185,11 @@ define-union-class ! A predicate class used for declarations "array-capacity" "sequences.private" create "fixnum" "math" lookup -0 bootstrap-max-array-capacity [ between? ] 2curry +[ + [ dup 0 fixnum>= ] % + bootstrap-max-array-capacity [ fixnum<= ] curry , + [ [ drop f ] if ] % +] [ ] make define-predicate-class ! Catch-all class for providing a default method. From 65b89eea9e479da3e202b36f87b324745462be43 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 04:46:15 -0600 Subject: [PATCH 30/30] Fix compile error --- vm/os-windows.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/os-windows.c b/vm/os-windows.c index 0aeb77741b..ee2c721111 100755 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -168,5 +168,5 @@ long getpagesize(void) void sleep_micros(DWORD usec) { - Sleep(msec / 1000); + Sleep(usec); }