Merge branch 'new_walker' of git://factorcode.org/git/factor

db4
Slava Pestov 2008-02-19 23:23:22 -06:00
commit 614d78ae98
5 changed files with 51 additions and 68 deletions

View File

@ -199,6 +199,3 @@ $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." } ;
HELP: break
{ $description "Suspends execution of the current thread and starts the single stepper by calling " { $link break-hook } "." } ;

View File

@ -91,14 +91,8 @@ C: <continuation> continuation
PRIVATE>
: set-walker-hook ( quot -- ) 3 setenv ; inline
: walker-hook ( -- quot ) 3 getenv f set-walker-hook ; inline
: continue-with ( obj continuation -- )
[
walker-hook [ >r 2array r> ] when* (continue-with)
] 2 (throw) ;
[ (continue-with) ] 2 (throw) ;
: continue ( continuation -- )
f swap continue-with ;
@ -185,20 +179,3 @@ M: condition compute-restarts
"kernel-error" 6 setenv ;
PRIVATE>
! Debugging support
: with-walker-hook ( continuation -- )
[ swap set-walker-hook (continue) ] curry callcc1 ;
SYMBOL: break-hook
: break ( -- )
continuation callstack
over set-continuation-call
walker-hook [ (continue-with) ] [ break-hook get call ] if* ;
GENERIC: (step-into) ( obj -- )
M: wrapper (step-into) wrapped break ;
M: object (step-into) break ;
M: callable (step-into) \ break add* break ;

View File

@ -95,42 +95,42 @@ SYMBOL: ->
"word-style" set-word-prop
! This code is ugly and could probably be simplified
: remove-step-into
building get dup empty? [
drop \ (step-into) ,
] [
pop dup wrapper? [
wrapped dup \ break eq?
[ drop ] [ , ] if
] [
,
] if
] if ;
: (remove-breakpoints) ( quot -- newquot )
[
[
{
{ break [ ] }
{ (step-into) [ remove-step-into ] }
[ , ]
} case
] each
] [ ] make ;
: remove-breakpoints ( quot pos -- quot' )
over quotation? [
1+ cut [ (remove-breakpoints) ] 2apply
[ -> ] swap 3append
] [
drop
] if ;
! : remove-step-into
! building get dup empty? [
! drop \ (step-into) ,
! ] [
! pop dup wrapper? [
! wrapped dup \ break eq?
! [ drop ] [ , ] if
! ] [
! ,
! ] if
! ] if ;
!
! : (remove-breakpoints) ( quot -- newquot )
! [
! [
! dup {
! { break [ drop ] }
! { (step-into) [ remove-step-into ] }
! [ , ]
! } case
! ] each
! ] [ ] make ;
!
! : remove-breakpoints ( quot pos -- quot' )
! over quotation? [
! 1+ cut [ (remove-breakpoints) ] 2apply
! [ -> ] swap 3append
! ] [
! drop
! ] if ;
PRIVATE>
: callstack. ( callstack -- )
callstack>array 2 <groups> [
remove-breakpoints
! remove-breakpoints
2 nesting-limit [ . ] with-variable
] assoc-each ;

View File

@ -29,14 +29,14 @@ MATCH-VARS: ?from ?tag ?id ?value ;
SYMBOL: no-channel
: channel-process ( -- )
receive [
[
{
{ { to ?id ?value }
[ ?value ?id get-channel dup [ to f ] [ 2drop no-channel ] if ] }
{ { from ?id }
[ ?id get-channel [ from ] [ no-channel ] if* ] }
} match-cond
] keep reply-synchronous ;
] handle-synchronous ;
PRIVATE>

View File

@ -97,7 +97,7 @@ M: thread send ( message thread -- )
mailbox mailbox-get? ?linked ; inline
: rethrow-linked ( error process supervisor -- )
>r <linked> r> send ;
pick thread-death? [ 3drop ] [ >r <linked> r> send ] if ;
: spawn-linked-to ( quot name mailbox -- thread )
[ >r <linked> r> mailbox-put ] curry <thread>
@ -117,17 +117,26 @@ TUPLE: reply data tag ;
synchronous-tag \ reply construct-boa ;
: send-synchronous ( message thread -- reply )
>r <synchronous> dup r> send [
over reply? [
>r reply-tag r> synchronous-tag =
] [
2drop f
] if
] curry receive-if reply-data ;
dup self eq? [
"Cannot synchronous send to myself" throw
] [
>r <synchronous> dup r> send [
over reply? [
>r reply-tag r> synchronous-tag =
] [
2drop f
] if
] curry receive-if reply-data
] if ;
: reply-synchronous ( message synchronous -- )
[ <reply> ] keep synchronous-sender send ;
: handle-synchronous ( quot -- )
receive [
synchronous-data swap call
] keep reply-synchronous ; inline
<PRIVATE
: remote-processes ( -- hash )