From f2e9b80784095caab0d312f7b1b638c670d8aecb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 19 Feb 2008 23:17:59 -0600 Subject: [PATCH] New single stepper work in progress --- core/continuations/continuations-docs.factor | 3 - core/continuations/continuations.factor | 25 +------- core/prettyprint/prettyprint.factor | 62 ++++++++++---------- extra/channels/remote/remote.factor | 4 +- extra/concurrency/messaging/messaging.factor | 25 +++++--- 5 files changed, 51 insertions(+), 68 deletions(-) diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 7cf15394ef..124366c876 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -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 } "." } ; diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 19802da7df..4589ac90c4 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -91,14 +91,8 @@ C: 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 ; diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index d578738c56..3b598adcce 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -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 [ - remove-breakpoints + ! remove-breakpoints 2 nesting-limit [ . ] with-variable ] assoc-each ; diff --git a/extra/channels/remote/remote.factor b/extra/channels/remote/remote.factor index 437a668a73..2d8d003b8d 100755 --- a/extra/channels/remote/remote.factor +++ b/extra/channels/remote/remote.factor @@ -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> diff --git a/extra/concurrency/messaging/messaging.factor b/extra/concurrency/messaging/messaging.factor index 22a7282364..6977047062 100755 --- a/extra/concurrency/messaging/messaging.factor +++ b/extra/concurrency/messaging/messaging.factor @@ -97,7 +97,7 @@ M: thread send ( message thread -- ) mailbox mailbox-get? ?linked ; inline : rethrow-linked ( error process supervisor -- ) - >r r> send ; + pick thread-death? [ 3drop ] [ >r r> send ] if ; : spawn-linked-to ( quot name mailbox -- thread ) [ >r r> mailbox-put ] curry @@ -117,17 +117,26 @@ TUPLE: reply data tag ; synchronous-tag \ reply construct-boa ; : send-synchronous ( message thread -- reply ) - >r 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 dup r> send [ + over reply? [ + >r reply-tag r> synchronous-tag = + ] [ + 2drop f + ] if + ] curry receive-if reply-data + ] if ; : reply-synchronous ( message synchronous -- ) [ ] keep synchronous-sender send ; +: handle-synchronous ( quot -- ) + receive [ + synchronous-data swap call + ] keep reply-synchronous ; inline +