From a5503782d775f2c296c065c43dfe95d8deb81b39 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 27 Feb 2008 17:15:52 -0600 Subject: [PATCH 1/4] Fix hang when clicking presentations in the walker; improve traceback widget --- extra/concurrency/flags/flags-docs.factor | 7 +++- extra/concurrency/flags/flags.factor | 7 +++- extra/ui/tools/interactor/interactor.factor | 20 ++++++----- extra/ui/tools/listener/listener.factor | 14 ++++++-- extra/ui/tools/tools.factor | 4 ++- extra/ui/tools/traceback/traceback.factor | 37 ++++++++++++++++----- extra/ui/tools/walker/walker-docs.factor | 1 - extra/ui/tools/walker/walker.factor | 10 +----- 8 files changed, 67 insertions(+), 33 deletions(-) diff --git a/extra/concurrency/flags/flags-docs.factor b/extra/concurrency/flags/flags-docs.factor index 11c85240b9..1b2c1b754e 100644 --- a/extra/concurrency/flags/flags-docs.factor +++ b/extra/concurrency/flags/flags-docs.factor @@ -14,6 +14,10 @@ HELP: raise-flag { $values { "flag" flag } } { $description "Raises a flag, notifying any threads waiting on it. Does nothing if the flag has already been raised." } ; +HELP: wait-for-flag +{ $values { "flag" flag } } +{ $description "Waits for a flag to be raised. If the flag has already been raised, returns immediately." } ; + HELP: lower-flag { $values { "flag" flag } } { $description "Attempts to lower a flag. If the flag has been raised previously, returns immediately, otherwise waits for it to be raised first." } ; @@ -26,8 +30,9 @@ $nl "Essentially, a flag can be thought of as a counting semaphore where the count never goes above one." { $subsection flag } { $subsection flag? } -"Raising and lowering flags:" +"Waiting for a flag to be raised:" { $subsection raise-flag } +{ $subsection wait-for-flag } { $subsection lower-flag } ; ABOUT: "concurrency.flags" diff --git a/extra/concurrency/flags/flags.factor b/extra/concurrency/flags/flags.factor index d4e60d63ee..888b617b85 100644 --- a/extra/concurrency/flags/flags.factor +++ b/extra/concurrency/flags/flags.factor @@ -13,9 +13,14 @@ TUPLE: flag value? thread ; [ resume ] [ drop t over set-flag-value? ] if ] unless drop ; +: wait-for-flag ( flag -- ) + dup flag-value? [ drop ] [ + [ flag-thread >box ] curry "flag" suspend drop + ] if ; + : lower-flag ( flag -- ) dup flag-value? [ f swap set-flag-value? ] [ - [ flag-thread >box ] curry "flag" suspend drop + wait-for-flag ] if ; diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor index 3c9809f343..9e43460aa9 100755 --- a/extra/ui/tools/interactor/interactor.factor +++ b/extra/ui/tools/interactor/interactor.factor @@ -1,18 +1,15 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs combinators continuations documents -ui.tools.workspace hashtables io io.styles kernel math + hashtables io io.styles kernel math math.vectors models namespaces parser prettyprint quotations sequences sequences.lib strings threads listener tuples ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds ui.gestures -definitions boxes calendar ; +definitions boxes calendar concurrency.flags ui.tools.workspace ; IN: ui.tools.interactor -TUPLE: interactor -history output -thread quot -help ; +TUPLE: interactor history output flag thread help ; : interactor-continuation ( interactor -- continuation ) interactor-thread box-value @@ -35,12 +32,16 @@ help ; : init-interactor-history ( interactor -- ) V{ } clone swap set-interactor-history ; +: init-interactor-state ( interactor -- ) + over set-interactor-flag + swap set-interactor-thread ; + : ( output -- gadget ) interactor construct-editor tuck set-interactor-output - over set-interactor-thread dup init-interactor-history + dup init-interactor-state dup init-caret-help ; M: interactor graft* @@ -97,7 +98,10 @@ M: interactor model-changed ] unless drop ; : interactor-yield ( interactor -- obj ) - [ interactor-thread >box ] curry "input" suspend ; + [ + [ interactor-thread >box ] keep + interactor-flag raise-flag + ] curry "input" suspend ; M: interactor stream-readln [ interactor-yield ] keep interactor-finish ?first ; diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor index 7617b0f32d..0577ae38bd 100755 --- a/extra/ui/tools/listener/listener.factor +++ b/extra/ui/tools/listener/listener.factor @@ -6,7 +6,7 @@ kernel models namespaces parser quotations sequences ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.labelled ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.operations vocabs words -prettyprint listener debugger threads boxes ; +prettyprint listener debugger threads boxes concurrency.flags ; IN: ui.tools.listener TUPLE: listener-gadget input output stack ; @@ -131,10 +131,18 @@ M: stack-display tool-scroller listener ] with-stream* ; +: start-listener-thread ( listener -- ) + [ listener-thread ] curry "Listener" spawn drop ; + +: wait-for-listener ( listener -- ) + #! Wait for the listener to start. + listener-gadget-input interactor-flag wait-for-flag ; + : restart-listener ( listener -- ) + #! Returns when listener is ready to receive input. dup com-end dup clear-output - [ listener-thread ] curry - "Listener" spawn drop ; + dup start-listener-thread + wait-for-listener ; : init-listener ( listener -- ) f swap set-listener-gadget-stack ; diff --git a/extra/ui/tools/tools.factor b/extra/ui/tools/tools.factor index 2b3c652352..0156fe80ea 100755 --- a/extra/ui/tools/tools.factor +++ b/extra/ui/tools/tools.factor @@ -83,5 +83,7 @@ workspace "workflow" f { } define-command-map [ - "Factor workspace" open-status-window + + dup "Factor workspace" open-status-window + workspace-listener wait-for-listener ] workspace-window-hook set-global diff --git a/extra/ui/tools/traceback/traceback.factor b/extra/ui/tools/traceback/traceback.factor index a3aa182683..d4a0544f0a 100755 --- a/extra/ui/tools/traceback/traceback.factor +++ b/extra/ui/tools/traceback/traceback.factor @@ -1,8 +1,10 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: continuations kernel models namespaces prettyprint ui ui.commands ui.gadgets ui.gadgets.labelled assocs -ui.gadgets.tracks ui.gestures sequences hashtables inspector ; +ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.panes +ui.gadgets.status-bar ui.gadgets.scrollers +ui.gestures sequences hashtables inspector ; IN: ui.tools.traceback : ( model -- gadget ) @@ -17,10 +19,6 @@ IN: ui.tools.traceback [ [ continuation-retain stack. ] when* ] t "Retain stack" ; -: ( model -- gadget ) - [ [ continuation-name namestack. ] when* ] - f "Dynamic variables" ; - TUPLE: traceback-gadget ; M: traceback-gadget pref-dim* drop { 550 600 } ; @@ -31,11 +29,32 @@ M: traceback-gadget pref-dim* drop { 550 600 } ; [ g gadget-model 1/2 track, g gadget-model 1/2 track, - ] { 1 0 } make-track 1/5 track, - g gadget-model 2/5 track, - g gadget-model 2/5 track, + ] { 1 0 } make-track 1/3 track, + g gadget-model 2/3 track, + toolbar, ] with-gadget ] keep ; +: ( model -- gadget ) + [ [ continuation-name namestack. ] when* ] + ; + +TUPLE: variables-gadget ; + +: ( model -- gadget ) + + variables-gadget construct-empty + [ set-gadget-delegate ] keep ; + +M: variables-gadget pref-dim* drop { 400 400 } ; + +: variables ( traceback -- ) + gadget-model + "Dynamic variables" open-status-window ; + : traceback-window ( continuation -- ) "Traceback" open-window ; + +traceback-gadget "toolbar" f { + { T{ key-down f f "v" } variables } +} define-command-map diff --git a/extra/ui/tools/walker/walker-docs.factor b/extra/ui/tools/walker/walker-docs.factor index 38b4e2a837..54caf8be12 100755 --- a/extra/ui/tools/walker/walker-docs.factor +++ b/extra/ui/tools/walker/walker-docs.factor @@ -7,5 +7,4 @@ ARTICLE: "ui-walker" "UI walker" $nl "The walker can travel backwards through time, and restore stacks. This does not undo side effects and therefore can only be used reliably on referentially transparent code." { $command-map walker-gadget "toolbar" } -{ $command-map walker-gadget "other" } "Walkers are instances of " { $link walker-gadget } "." ; diff --git a/extra/ui/tools/walker/walker.factor b/extra/ui/tools/walker/walker.factor index 17ca7552ce..ea38b9c8db 100755 --- a/extra/ui/tools/walker/walker.factor +++ b/extra/ui/tools/walker/walker.factor @@ -26,10 +26,6 @@ TUPLE: walker-gadget status continuation thread ; : com-abandon ( walker -- ) abandon walker-command ; -: com-inspect ( walker -- ) - walker-continuation model-value - [ inspect ] curry call-listener ; - M: walker-gadget ungraft* dup delegate ungraft* detach walker-command ; @@ -69,12 +65,8 @@ walker-gadget "toolbar" f { { T{ key-down f f "b" } com-back } { T{ key-down f f "c" } com-continue } { T{ key-down f f "a" } com-abandon } - { T{ key-down f f "F1" } walker-help } -} define-command-map - -walker-gadget "other" f { - { T{ key-down f f "n" } com-inspect } { T{ key-down f f "d" } close-window } + { T{ key-down f f "F1" } walker-help } } define-command-map : walker-window ( -- ) From ed4506c0b04d7a878ddb9b09fe1fc553b7e15360 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 27 Feb 2008 19:23:22 -0600 Subject: [PATCH 2/4] Errors remember the original thread --- core/alien/compiler/compiler.factor | 2 +- core/bootstrap/stage1.factor | 13 ++- core/bootstrap/stage2.factor | 104 +++++++++---------- core/continuations/continuations-docs.factor | 3 - core/continuations/continuations.factor | 17 +-- core/debugger/debugger-docs.factor | 8 +- core/debugger/debugger.factor | 62 ++++++++--- core/init/init-tests.factor | 7 ++ core/init/init.factor | 2 +- core/libc/libc.factor | 2 +- core/sequences/sequences-docs.factor | 4 +- core/threads/threads.factor | 28 ++--- 12 files changed, 133 insertions(+), 119 deletions(-) create mode 100644 core/init/init-tests.factor diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 48e8d7e307..baab72036d 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -367,7 +367,7 @@ TUPLE: callback-context ; ] if ; : do-callback ( quot token -- ) - init-error-handler + init-catchstack dup 2 setenv slip wait-to-return ; inline diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index 7c7a03f575..0e038d0a10 100755 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -1,11 +1,11 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: bootstrap.stage1 USING: arrays debugger generic hashtables io assocs kernel.private kernel math memory namespaces parser prettyprint sequences vectors words system splitting init io.files bootstrap.image bootstrap.image.private vocabs -vocabs.loader system ; +vocabs.loader system debugger continuations ; { "resource:core" } vocab-roots set @@ -40,7 +40,14 @@ vocabs.loader system ; [ "resource:core/bootstrap/stage2.factor" dup resource-exists? [ - run-file + [ run-file ] + [ + :c + dup print-error flush + "listener" vocab + [ restarts. vocab-main execute ] + [ die ] if* + ] recover ] [ "Cannot find " write write "." print "Please move " write image write " to the same directory as the Factor sources," print diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 3b5918a4f8..63b5726ad7 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -51,66 +51,60 @@ SYMBOL: bootstrap-time ! Wrap everything in a catch which starts a listener so ! you can see what went wrong, instead of dealing with a ! fep -[ - ! We time bootstrap - millis >r - default-image-name "output-image" set-global +! We time bootstrap +millis >r - "math help handbook compiler tools ui ui.tools io" "include" set-global - "" "exclude" set-global +default-image-name "output-image" set-global - parse-command-line +"math help handbook compiler tools ui ui.tools io" "include" set-global +"" "exclude" set-global - "-no-crossref" cli-args member? [ do-crossref ] unless +parse-command-line - ! Set dll paths - wince? [ "windows.ce" require ] when - winnt? [ "windows.nt" require ] when +"-no-crossref" cli-args member? [ do-crossref ] unless - "deploy-vocab" get [ - "stage2: deployment mode" print - ] [ - "listener" require - "none" require - ] if +! Set dll paths +wince? [ "windows.ce" require ] when +winnt? [ "windows.nt" require ] when - [ - load-components - - run-bootstrap-init - - "bootstrap.compiler" vocab [ - compile-remaining - ] when - ] with-compiler-errors - :errors - - f error set-global - f error-continuation set-global - - "deploy-vocab" get [ - "tools.deploy.shaker" run - ] [ - [ - boot - do-init-hooks - [ - parse-command-line - run-user-init - "run" get run - stdio get [ stream-flush ] when* - ] [ print-error 1 exit ] recover - ] set-boot-quot - - millis r> - dup bootstrap-time set-global - print-report - - "output-image" get resource-path save-image-and-exit - ] if +"deploy-vocab" get [ + "stage2: deployment mode" print ] [ - :c - print-error restarts. - "listener" vocab-main execute - 1 exit -] recover + "listener" require + "none" require +] if + +[ + load-components + + run-bootstrap-init + + "bootstrap.compiler" vocab [ + compile-remaining + ] when +] with-compiler-errors +:errors + +f error set-global +f error-continuation set-global + +"deploy-vocab" get [ + "tools.deploy.shaker" run +] [ + [ + boot + do-init-hooks + [ + parse-command-line + run-user-init + "run" get run + stdio get [ stream-flush ] when* + ] [ print-error 1 exit ] recover + ] set-boot-quot + + millis r> - dup bootstrap-time set-global + print-report + + "output-image" get resource-path save-image-and-exit +] if diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 5fc86e25d4..9a26dbc67e 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -193,6 +193,3 @@ HELP: save-error { $values { "error" "an error" } } { $description "Called by the error handler to set the " { $link error } " and " { $link restarts } " global variables after an error was thrown." } $low-level-note ; - -HELP: init-error-handler -{ $description "Called on startup to initialize the catch stack and set a pair of hooks which allow the Factor VM to signal errors to library code." } ; diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index d68b5b2433..13b31cfde6 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -6,6 +6,7 @@ IN: continuations SYMBOL: error SYMBOL: error-continuation +SYMBOL: error-thread SYMBOL: restarts : catchstack ( -- catchstack ) catchstack* clone ; inline @@ -169,17 +172,3 @@ M: condition compute-restarts condition-continuation [ ] curry { } assoc>map append ; - - diff --git a/core/debugger/debugger-docs.factor b/core/debugger/debugger-docs.factor index b754856ee4..5e8b6df34a 100755 --- a/core/debugger/debugger-docs.factor +++ b/core/debugger/debugger-docs.factor @@ -1,6 +1,6 @@ USING: alien arrays generic generic.math help.markup help.syntax kernel math memory strings sbufs vectors io io.files classes -help generic.standard continuations system ; +help generic.standard continuations system debugger.private ; IN: debugger ARTICLE: "errors-assert" "Assertions" @@ -80,9 +80,6 @@ HELP: print-error HELP: restarts. { $description "Print a list of restarts for the most recently thrown error to the " { $link stdio } " stream." } ; -HELP: debug-help -{ $description "Print a synopsis of useful debugger words." } ; - HELP: error-hook { $var-description "A quotation with stack effect " { $snippet "( error -- )" } " which is used by " { $link try } " to report the error to the user." } { $examples "The default value prints the error with " { $link print-error } ", followed by a list of restarts and a help message. The graphical listener sets this variable to display a popup instead." } ; @@ -169,3 +166,6 @@ HELP: depth HELP: assert-depth { $values { "quot" "a quotation" } } { $description "Runs a quotation. Throws an error if the total number of elements on the stack is not the same before and after the quotation runs." } ; + +HELP: init-debugger +{ $description "Called on startup to set a pair of hooks which allow the " { $link throw } " word to function." } ; diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index 95470dcbcd..378491e141 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -5,7 +5,8 @@ math namespaces prettyprint sequences assocs sequences.private strings io.styles vectors words system splitting math.parser tuples continuations continuations.private combinators generic.math io.streams.duplex classes compiler.units -generic.standard vocabs ; +generic.standard vocabs threads threads.private init +kernel.private ; IN: debugger GENERIC: error. ( error -- ) @@ -57,27 +58,30 @@ M: string error. print ; dup length [ restart. ] 2each ] if ; -: debug-help ( -- ) - nl - "Debugger commands:" print - nl - ":help - documentation for this error" print - ":s - data stack at exception time" print - ":r - retain stack at exception time" print - ":c - call stack at exception time" print - ":edit - jump to source location (parse errors only)" print - - ":get ( var -- value ) accesses variables at time of the error" print - flush ; - : print-error ( error -- ) [ error. flush ] curry [ global [ "Error in print-error!" print drop ] bind ] recover ; +: error-in-thread. ( -- ) + error-thread get-global + "Error in thread " write + [ + dup thread-id # + " (" % dup thread-name % + ", " % dup thread-quot unparse-short % ")" % + ] "" make + swap write-object ":" print nl ; + SYMBOL: error-hook -[ print-error restarts. debug-help ] error-hook set-global +[ + error-in-thread. + print-error + restarts. + nl + "Type :help for debugging help." print flush +] error-hook set-global : try ( quot -- ) [ error-hook get call ] recover ; @@ -260,3 +264,31 @@ M: no-compilation-unit error. M: no-vocab summary drop "Vocabulary does not exist" ; + +! Hooks +M: thread error-in-thread ( error thread -- ) + initial-thread get-global eq? [ + die drop + ] [ + global [ + error-in-thread. print-error flush + ] bind + ] if ; + + + +[ init-debugger ] "debugger" add-init-hook diff --git a/core/init/init-tests.factor b/core/init/init-tests.factor new file mode 100644 index 0000000000..aa7cd0ea58 --- /dev/null +++ b/core/init/init-tests.factor @@ -0,0 +1,7 @@ +IN: temporary +USING: init namespaces sequences math tools.test kernel ; + +[ t ] [ + init-hooks get [ first "libc" = ] find drop + init-hooks get [ first "io.backend" = ] find drop < +] unit-test diff --git a/core/init/init.factor b/core/init/init.factor index 770655d990..6ee11c76fc 100755 --- a/core/init/init.factor +++ b/core/init/init.factor @@ -15,7 +15,7 @@ init-hooks global [ drop V{ } clone ] cache drop dup init-hooks get at [ over call ] unless init-hooks get set-at ; -: boot ( -- ) init-namespaces init-error-handler ; +: boot ( -- ) init-namespaces init-catchstack ; : boot-quot ( -- quot ) 20 getenv ; diff --git a/core/libc/libc.factor b/core/libc/libc.factor index 2006850839..a28c5c0a98 100644 --- a/core/libc/libc.factor +++ b/core/libc/libc.factor @@ -46,7 +46,7 @@ M: realloc-error summary drop "Memory reallocation failed" ; -: ( quot name error-handler -- thread ) +: ( quot name -- thread ) \ thread counter [ ] { set-thread-quot set-thread-name - set-thread-error-handler set-thread-id set-thread-continuation set-thread-exit-handler @@ -179,20 +177,8 @@ M: real sleep ] 1 (throw) ] "spawn" suspend 2drop ; -: default-thread-error-handler ( error thread -- ) - global [ - "Error in thread " write - dup thread-id pprint - " (" write - dup thread-name pprint ")" print - "spawned to call " write - thread-quot short. - nl - print-error flush - ] bind ; - : spawn ( quot name -- thread ) - [ default-thread-error-handler ] [ (spawn) ] keep ; + [ (spawn) ] keep ; : spawn-server ( quot name -- thread ) >r [ [ ] [ ] while ] curry r> spawn ; @@ -202,6 +188,8 @@ M: real sleep [ >r set-namestack set-datastack r> call ] 3curry "Thread" spawn drop ; +GENERIC: error-in-thread ( error thread -- ) + 42 setenv 43 setenv initial-thread global - [ drop f "Initial" [ die ] ] cache + [ drop f "Initial" ] cache over set-thread-continuation f over set-thread-state dup register-thread set-self ; -[ self dup thread-error-handler call stop ] +[ self error-in-thread stop ] thread-error-hook set-global PRIVATE> From cfa7c3771cca1c9305c8e11598c4acd1b4fd9273 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 27 Feb 2008 19:24:24 -0600 Subject: [PATCH 3/4] Fixes for linked error change --- .../combinators/combinators-tests.factor | 2 +- extra/concurrency/locks/locks-tests.factor | 2 +- extra/concurrency/mailboxes/mailboxes.factor | 21 ++++++++++++++----- .../messaging/messaging-tests.factor | 2 +- 4 files changed, 19 insertions(+), 8 deletions(-) diff --git a/extra/concurrency/combinators/combinators-tests.factor b/extra/concurrency/combinators/combinators-tests.factor index 831dad6b56..e06b97489b 100755 --- a/extra/concurrency/combinators/combinators-tests.factor +++ b/extra/concurrency/combinators/combinators-tests.factor @@ -11,7 +11,7 @@ concurrency.mailboxes threads sequences ; [ { 1 4 9 } ] [ { 1 2 3 } [ 1000 random sleep sq ] parallel-map ] unit-test [ { 1 2 3 } [ dup 2 mod 0 = [ "Even" throw ] when ] parallel-map ] -[ linked-error "Even" = ] must-fail-with +[ delegate "Even" = ] must-fail-with [ V{ 0 3 6 9 } ] [ 10 [ 3 mod zero? ] parallel-subset ] unit-test diff --git a/extra/concurrency/locks/locks-tests.factor b/extra/concurrency/locks/locks-tests.factor index 1280339231..92f1a9f103 100755 --- a/extra/concurrency/locks/locks-tests.factor +++ b/extra/concurrency/locks/locks-tests.factor @@ -174,5 +174,5 @@ threads sequences calendar ; ] ; [ lock-timeout-test ] [ - linked-thread thread-name "Lock timeout-er" = + linked-error-thread thread-name "Lock timeout-er" = ] must-fail-with diff --git a/extra/concurrency/mailboxes/mailboxes.factor b/extra/concurrency/mailboxes/mailboxes.factor index adfb5bac0a..28b2fb7221 100755 --- a/extra/concurrency/mailboxes/mailboxes.factor +++ b/extra/concurrency/mailboxes/mailboxes.factor @@ -65,12 +65,23 @@ TUPLE: mailbox threads data ; : mailbox-get? ( pred mailbox -- obj ) f mailbox-get-timeout? ; inline -TUPLE: linked error thread ; +TUPLE: linked-error thread ; -C: linked +: ( error thread -- linked ) + { set-delegate set-linked-error-thread } + linked-error construct ; -: ?linked dup linked? [ rethrow ] when ; +: ?linked dup linked-error? [ rethrow ] when ; + +TUPLE: linked-thread supervisor ; + +M: linked-thread error-in-thread + [ ] keep + linked-thread-supervisor mailbox-put ; + +: ( quot name mailbox -- thread' ) + >r linked-thread construct-delegate r> + over set-linked-thread-supervisor ; : spawn-linked-to ( quot name mailbox -- thread ) - [ >r r> mailbox-put ] curry - [ (spawn) ] keep ; + [ (spawn) ] keep ; diff --git a/extra/concurrency/messaging/messaging-tests.factor b/extra/concurrency/messaging/messaging-tests.factor index 5f241b77e3..3f6e4e3ed8 100755 --- a/extra/concurrency/messaging/messaging-tests.factor +++ b/extra/concurrency/messaging/messaging-tests.factor @@ -29,7 +29,7 @@ IN: temporary "crash" throw ] "Linked test" spawn-linked drop receive -] [ linked-error "crash" = ] must-fail-with +] [ delegate "crash" = ] must-fail-with MATCH-VARS: ?from ?to ?value ; SYMBOL: increment From 27c9b31288f42363d19445feec21db2d6246aa41 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 27 Feb 2008 19:24:50 -0600 Subject: [PATCH 4/4] New benchmarks and UI improvements --- extra/benchmark/crc32/crc32.factor | 10 ++++++++ extra/benchmark/md5/md5.factor | 7 +++++ extra/benchmark/random/random.factor | 14 ++++++++++ extra/benchmark/sort/sort.factor | 5 ++-- extra/benchmark/sum-file/sum-file.factor | 5 ++-- extra/help/handbook/handbook.factor | 1 + extra/help/help.factor | 17 ++++++++++-- extra/opengl/gl/extensions/extensions.factor | 2 +- extra/tools/threads/threads-docs.factor | 17 ++++++++++++ extra/ui/gadgets/buttons/buttons.factor | 1 - extra/ui/tools/listener/listener.factor | 13 +++++----- extra/ui/tools/tools.factor | 27 ++++++++++++-------- extra/ui/tools/traceback/traceback.factor | 4 --- extra/ui/tools/walker/walker.factor | 9 ++++--- 14 files changed, 100 insertions(+), 32 deletions(-) create mode 100644 extra/benchmark/crc32/crc32.factor create mode 100644 extra/benchmark/md5/md5.factor create mode 100644 extra/benchmark/random/random.factor create mode 100644 extra/tools/threads/threads-docs.factor diff --git a/extra/benchmark/crc32/crc32.factor b/extra/benchmark/crc32/crc32.factor new file mode 100644 index 0000000000..7dad272296 --- /dev/null +++ b/extra/benchmark/crc32/crc32.factor @@ -0,0 +1,10 @@ +USING: io.crc32 io.files kernel math ; +IN: benchmark.crc32 + +: crc32-primes-list ( -- ) + 10 [ + "extra/math/primes/list/list.factor" resource-path + file-contents crc32 drop + ] times ; + +MAIN: crc32-primes-list diff --git a/extra/benchmark/md5/md5.factor b/extra/benchmark/md5/md5.factor new file mode 100644 index 0000000000..3043725acd --- /dev/null +++ b/extra/benchmark/md5/md5.factor @@ -0,0 +1,7 @@ +USING: crypto.md5 io.files kernel ; +IN: benchmark.md5 + +: md5-primes-list ( -- ) + "extra/math/primes/list/list.factor" resource-path file>md5 drop ; + +MAIN: md5-primes-list diff --git a/extra/benchmark/random/random.factor b/extra/benchmark/random/random.factor new file mode 100644 index 0000000000..95c797cddd --- /dev/null +++ b/extra/benchmark/random/random.factor @@ -0,0 +1,14 @@ +USING: io.files random math.parser io math ; +IN: benchmark.random + +: random-numbers-path "random-numbers.txt" temp-file ; + +: write-random-numbers ( n -- ) + random-numbers-path [ + [ 200 random 100 - number>string print ] times + ] with-file-writer ; + +: random-main ( -- ) + 1000000 write-random-numbers ; + +MAIN: random-main diff --git a/extra/benchmark/sort/sort.factor b/extra/benchmark/sort/sort.factor index 0a31bf0ca4..a54480692a 100644 --- a/extra/benchmark/sort/sort.factor +++ b/extra/benchmark/sort/sort.factor @@ -1,7 +1,8 @@ -USING: kernel sequences sorting random ; +USING: kernel sequences sorting benchmark.random math.parser +io.files ; IN: benchmark.sort : sort-benchmark - 100000 [ drop 100000 random ] map natural-sort drop ; + random-numbers-path file-lines [ string>number ] map natural-sort drop ; MAIN: sort-benchmark diff --git a/extra/benchmark/sum-file/sum-file.factor b/extra/benchmark/sum-file/sum-file.factor index e17765d542..1d52beebfc 100644 --- a/extra/benchmark/sum-file/sum-file.factor +++ b/extra/benchmark/sum-file/sum-file.factor @@ -1,4 +1,5 @@ -USING: io io.files math math.parser kernel prettyprint ; +USING: io io.files math math.parser kernel prettyprint +benchmark.random ; IN: benchmark.sum-file : sum-file-loop ( n -- n' ) @@ -8,6 +9,6 @@ IN: benchmark.sum-file [ 0 sum-file-loop ] with-file-reader . ; : sum-file-main ( -- ) - home "sum-file-in.txt" path+ sum-file ; + random-numbers-path sum-file ; MAIN: sum-file-main diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 6660ddf218..178b7a5d35 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -199,6 +199,7 @@ ARTICLE: "tools" "Developer tools" "Debugging tools:" { $subsection "tools.annotations" } { $subsection "tools.test" } +{ $subsection "tools.threads" } "Performance tools:" { $subsection "tools.memory" } { $subsection "profiling" } diff --git a/extra/help/help.factor b/extra/help/help.factor index 77b9f699aa..490374a384 100755 --- a/extra/help/help.factor +++ b/extra/help/help.factor @@ -122,18 +122,31 @@ M: word set-article-parent swap "help-parent" set-word-prop ; : (:help-multi) "This error has multiple delegates:" print - ($index) nl ; + ($index) nl + "Use \\ ... help to get help about a specific delegate." print ; : (:help-none) drop "No help for this error. " print ; +: (:help-debugger) + nl + "Debugger commands:" print + nl + ":help - documentation for this error" print + ":s - data stack at exception time" print + ":r - retain stack at exception time" print + ":c - call stack at exception time" print + ":edit - jump to source location (parse errors only)" print + + ":get ( var -- value ) accesses variables at time of the error" print ; + : :help ( -- ) error get delegates [ error-help ] map [ ] subset { { [ dup empty? ] [ (:help-none) ] } { [ dup length 1 = ] [ first help ] } { [ t ] [ (:help-multi) ] } - } cond ; + } cond (:help-debugger) ; : remove-article ( name -- ) dup articles get key? [ diff --git a/extra/opengl/gl/extensions/extensions.factor b/extra/opengl/gl/extensions/extensions.factor index e05e3a1af5..01725ee9a9 100644 --- a/extra/opengl/gl/extensions/extensions.factor +++ b/extra/opengl/gl/extensions/extensions.factor @@ -17,7 +17,7 @@ SYMBOL: +gl-function-pointers+ : reset-gl-function-pointers ( -- ) 100 +gl-function-pointers+ set-global ; -[ reset-gl-function-pointers ] "opengl.gl init hook" add-init-hook +[ reset-gl-function-pointers ] "opengl.gl" add-init-hook reset-gl-function-pointers reset-gl-function-number-counter diff --git a/extra/tools/threads/threads-docs.factor b/extra/tools/threads/threads-docs.factor new file mode 100644 index 0000000000..d4c5be9c17 --- /dev/null +++ b/extra/tools/threads/threads-docs.factor @@ -0,0 +1,17 @@ +IN: tools.threads +USING: help.markup help.syntax threads ; + +HELP: threads. +{ $description "Prints a list of running threads and their state. The ``Waiting on'' column displays one of the following:" + { $list + "``running'' if the thread is the current thread" + "``yield'' if the thread is waiting to run" + { "the string given to " { $link suspend } " if the thread is suspended" } + } +} ; + +ARTICLE: "tools.threads" "Listing threads" +"Printing a list of running threads:" +{ $subsection threads. } ; + +ABOUT: "tools.threads" diff --git a/extra/ui/gadgets/buttons/buttons.factor b/extra/ui/gadgets/buttons/buttons.factor index cf6d1a9ed9..defd5aa38a 100755 --- a/extra/ui/gadgets/buttons/buttons.factor +++ b/extra/ui/gadgets/buttons/buttons.factor @@ -88,7 +88,6 @@ TUPLE: repeat-button ; repeat-button H{ { T{ drag } [ button-clicked ] } - { T{ button-down } [ button-clicked ] } } set-gestures : ( label quot -- button ) diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor index 0577ae38bd..c4c366bb7d 100755 --- a/extra/ui/tools/listener/listener.factor +++ b/extra/ui/tools/listener/listener.factor @@ -40,9 +40,14 @@ M: listener-gadget call-tool* ( input listener -- ) M: listener-gadget tool-scroller listener-gadget-output find-scroller ; +: wait-for-listener ( listener -- ) + #! Wait for the listener to start. + listener-gadget-input interactor-flag wait-for-flag ; + : workspace-busy? ( workspace -- ? ) - workspace-listener listener-gadget-input - interactor-busy? ; + workspace-listener + dup wait-for-listener + listener-gadget-input interactor-busy? ; : get-listener ( -- listener ) [ workspace-busy? not ] get-workspace* workspace-listener ; @@ -134,10 +139,6 @@ M: stack-display tool-scroller : start-listener-thread ( listener -- ) [ listener-thread ] curry "Listener" spawn drop ; -: wait-for-listener ( listener -- ) - #! Wait for the listener to start. - listener-gadget-input interactor-flag wait-for-flag ; - : restart-listener ( listener -- ) #! Returns when listener is ready to receive input. dup com-end dup clear-output diff --git a/extra/ui/tools/tools.factor b/extra/ui/tools/tools.factor index 0156fe80ea..b3b24cf749 100755 --- a/extra/ui/tools/tools.factor +++ b/extra/ui/tools/tools.factor @@ -1,15 +1,14 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs debugger ui.tools.workspace -ui.tools.operations ui.tools.browser ui.tools.inspector -ui.tools.listener ui.tools.profiler +ui.tools.operations ui.tools.traceback ui.tools.browser +ui.tools.inspector ui.tools.listener ui.tools.profiler ui.tools.operations inspector io kernel math models namespaces prettyprint quotations sequences ui ui.commands ui.gadgets -ui.gadgets.books ui.gadgets.buttons -ui.gadgets.labelled ui.gadgets.scrollers ui.gadgets.tracks -ui.gadgets.worlds ui.gadgets.presentations ui.gestures words -vocabs.loader tools.test ui.gadgets.buttons -ui.gadgets.status-bar mirrors ; +ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled +ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds +ui.gadgets.presentations ui.gestures words vocabs.loader +tools.test ui.gadgets.buttons ui.gadgets.status-bar mirrors ; IN: ui.tools : ( -- tabs ) @@ -83,7 +82,13 @@ workspace "workflow" f { } define-command-map [ - - dup "Factor workspace" open-status-window - workspace-listener wait-for-listener + "Factor workspace" open-status-window ] workspace-window-hook set-global + +: inspect-continuation ( traceback -- ) + control-value [ inspect ] curry call-listener ; + +traceback-gadget "toolbar" f { + { T{ key-down f f "v" } variables } + { T{ key-down f f "n" } inspect-continuation } +} define-command-map diff --git a/extra/ui/tools/traceback/traceback.factor b/extra/ui/tools/traceback/traceback.factor index d4a0544f0a..3c3ff9da44 100755 --- a/extra/ui/tools/traceback/traceback.factor +++ b/extra/ui/tools/traceback/traceback.factor @@ -54,7 +54,3 @@ M: variables-gadget pref-dim* drop { 400 400 } ; : traceback-window ( continuation -- ) "Traceback" open-window ; - -traceback-gadget "toolbar" f { - { T{ key-down f f "v" } variables } -} define-command-map diff --git a/extra/ui/tools/walker/walker.factor b/extra/ui/tools/walker/walker.factor index ea38b9c8db..bc038cd244 100755 --- a/extra/ui/tools/walker/walker.factor +++ b/extra/ui/tools/walker/walker.factor @@ -7,7 +7,7 @@ ui.tools.workspace ui.gestures ui.gadgets.labels ui threads namespaces tools.walker assocs ; IN: ui.tools.walker -TUPLE: walker-gadget status continuation thread ; +TUPLE: walker-gadget status continuation thread traceback ; : walker-command ( walker msg -- ) over walker-gadget-thread thread-registered? @@ -29,6 +29,9 @@ TUPLE: walker-gadget status continuation thread ; M: walker-gadget ungraft* dup delegate ungraft* detach walker-command ; +M: walker-gadget focusable-child* + walker-gadget-traceback ; + : walker-state-string ( status thread -- string ) [ "Thread: " % @@ -48,10 +51,10 @@ M: walker-gadget ungraft* [ walker-state-string ] curry ; : ( status continuation thread -- gadget ) - walker-gadget construct-boa [ + over walker-gadget construct-boa [ toolbar, g walker-gadget-status self f track, - g walker-gadget-continuation 1 track, + g walker-gadget-traceback 1 track, ] { 0 1 } build-track ; : walker-help "ui-walker" help-window ;