steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Errors remember the original thread

db4
Slava Pestov 2008-02-27 19:23:22 -06:00
parent a5503782d7
commit ed4506c0b0
12 changed files with 133 additions and 119 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/alien/compiler/compiler.factor
View File

@ -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

13
core/bootstrap/stage1.factor
View File

@ -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

104
core/bootstrap/stage2.factor
View File

@ -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

3
core/continuations/continuations-docs.factor
View File

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

17
core/continuations/continuations.factor
View File

@ -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>

8
core/debugger/debugger-docs.factor
View File

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

62
core/debugger/debugger.factor
View File

@ -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

7
core/init/init-tests.factor Normal file
View File

@ -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

2
core/init/init.factor
View File

@ -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 ;

2
core/libc/libc.factor
View File

@ -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 ;

4
core/sequences/sequences-docs.factor
View File

@ -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 )" } } }

28
core/threads/threads.factor
View File

@ -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
boxes ;
dlists assocs system combinators init 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>