Errors remember the original thread

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

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

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
+default-image-name "output-image" set-global
-    "" "exclude" 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
+"-no-crossref" cli-args member? [ do-crossref ] unless
-    wince? [ "windows.ce" require ] when
-    winnt? [ "windows.nt" require ] when
 
-    "deploy-vocab" get [
+! Set dll paths
-        "stage2: deployment mode" print
+wince? [ "windows.ce" require ] when
-    ] [
+winnt? [ "windows.nt" require ] when
-        "listener" require
-        "none" require
-    ] if
 
-    [
+"deploy-vocab" get [
-        load-components
+    "stage2: deployment mode" print
-
-        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
 ] [
-    :c
+    "listener" require
-    print-error restarts.
+    "none" require
-    "listener" vocab-main execute
+] if
-    1 exit
+
-] recover
+[
+    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

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." } ;

core/continuations/continuations.factor

@@ -6,6 +6,7 @@ IN: continuations
 
 SYMBOL: error
 SYMBOL: error-continuation
+SYMBOL: error-thread
 SYMBOL: restarts
 
 <PRIVATE
@@ -24,6 +25,8 @@ SYMBOL: restarts
     #! with a declaration.
     f { object } declare ;
 
+: init-catchstack V{ } clone 1 setenv ;
+
 PRIVATE>
 
 : catchstack ( -- catchstack ) catchstack* clone ; inline
@@ -169,17 +172,3 @@ M: condition compute-restarts
     condition-continuation
     [ <restart> ] curry { } assoc>map
     append ;
-
-<PRIVATE
-
-: init-error-handler ( -- )
-    V{ } clone set-catchstack
-    ! VM calls on error
-    [
-        continuation error-continuation set-global rethrow
-    ] 5 setenv
-    ! VM adds this to kernel errors, so that user-space
-    ! can identify them
-    "kernel-error" 6 setenv ;
-
-PRIVATE>

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." } ;

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 ;
+
+<PRIVATE
+
+: init-debugger ( -- )
+    V{ } clone set-catchstack
+    ! VM calls on error
+    [
+        self error-thread set-global
+        continuation error-continuation set-global
+        rethrow
+    ] 5 setenv
+    ! VM adds this to kernel errors, so that user-space
+    ! can identify them
+    "kernel-error" 6 setenv ;
+
+PRIVATE>
+
+[ init-debugger ] "debugger" add-init-hook

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

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 ;
 

core/libc/libc.factor

@@ -46,7 +46,7 @@ M: realloc-error summary drop "Memory reallocation failed" ;
 
 <PRIVATE
 
-[ H{ } clone mallocs set-global ] "mallocs" add-init-hook
+[ H{ } clone mallocs set-global ] "libc" add-init-hook
 
 : add-malloc ( alien -- )
     dup mallocs get-global set-at ;

core/sequences/sequences-docs.factor

@@ -429,7 +429,7 @@ HELP: collect
 
 HELP: each
 { $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } }
-{ $description "Applies the quotation to each element of the sequence in turn." } ;
+{ $description "Applies the quotation to each element of the sequence in order." } ;
 
 HELP: reduce
 { $values { "seq" sequence } { "identity" object } { "quot" "a quotation with stack effect " { $snippet "( prev elt -- next )" } } { "result" "the final result" } }
@@ -447,7 +447,7 @@ HELP: accumulate
 
 HELP: map
 { $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } { "newseq" "a new sequence" } }
-{ $description "Applies the quotation to each element yielding a new element. The new elements are collected into a sequence of the same class as the input sequence." } ;
+{ $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as the input sequence." } ;
 
 HELP: change-nth
 { $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- newelt )" } } }

core/threads/threads.factor

@@ -4,13 +4,12 @@
 IN: threads
 USING: arrays hashtables heaps kernel kernel.private math
 namespaces sequences vectors continuations continuations.private
-dlists assocs system combinators debugger prettyprint io init
+dlists assocs system combinators init boxes ;
-boxes ;
 
 SYMBOL: initial-thread
 
 TUPLE: thread
-name quot error-handler exit-handler
+name quot exit-handler
 id
 continuation state
 mailbox variables sleep-entry ;
@@ -60,11 +59,10 @@ threads global [ H{ } assoc-like ] change-at
 
 PRIVATE>
 
-: <thread> ( quot name error-handler -- thread )
+: <thread> ( quot name -- thread )
     \ thread counter <box> [ ] {
         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 ] <thread> [ (spawn) ] keep ;
+    <thread> [ (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 -- )
+
 <PRIVATE
 
 : init-threads ( -- )
@@ -209,13 +197,13 @@ M: real sleep
     <dlist> 42 setenv
     <min-heap> 43 setenv
     initial-thread global
-    [ drop f "Initial" [ die ] <thread> ] cache
+    [ drop f "Initial" <thread> ] cache
     <box> 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>