2010-02-19 Paolo Bonzini * kernel/CallinProcess.st: Add #detach and #returnContext. * kernel/Process.st: Add #suspendedContext:. * kernel/ExcHandling.st: Move #instantiateNextHandler:from: to Signal and rename it. Extract #instantiateDefaultHandler. * kernel/AnsiExcept.st: Use #instantiateNextHandlerFrom:. Override #instantiateDefaultHandler for UnhandledException. * kernel/AnsiExcept.st: Add InvalidState. libgst: 2010-02-19 Paolo Bonzini * libgst/vm.def: Make EXIT_INTERPRETER safer since we now can fork CallinProcesses to Processes. * libgst/comp.c: Compile the termination method with an infinite loop to avoid falling off the last context. diff --git a/kernel/AnsiExcept.st b/kernel/AnsiExcept.st index adb4bef..308f36c 100644 --- a/kernel/AnsiExcept.st +++ b/kernel/AnsiExcept.st @@ -212,7 +212,7 @@ CoreException, so the two mechanisms are actually interchangeable.'> "Raise the exceptional event represented by the receiver" - self exception instantiateNextHandler: self from: thisContext. + self instantiateNextHandlerFrom: thisContext. ^self activateHandler: (onDoBlock isNil and: [ self isResumable ]) ] @@ -687,6 +687,29 @@ Error subclass: InvalidValue [ Namespace current: SystemExceptions [ +InvalidValue subclass: InvalidState [ + | value | + + + + + messageText [ + "Answer an exception's message text." + + + ^'%1 is in an invalid state: %2' % + {self value. + self basicMessageText} + ] +] + +] + + + +Namespace current: SystemExceptions [ + InvalidValue subclass: NotIndexable [ @@ -1535,6 +1558,29 @@ current process.'> thisContext environment continue: nil ] + instantiateDefaultHandler [ + "Private - Fill the receiver with information on its default handler." + + + | signalingContext resumeContext | + + "This exception is kind of special, as we forcedly have to find + a place to resume---even if the exception was not resumable! + This typically will happens when the user steps out of the + exception handling gobbledegook in the debugger." + signalingContext := thisContext. + [resumeContext := signalingContext parentContext. + resumeContext isEnvironment not + and: [resumeContext isInternalExceptionHandlingContext]] + whileTrue: [signalingContext := resumeContext]. + + self + onDoBlock: nil + handlerBlock: self exception actualDefaultHandler + onDoContext: signalingContext + previousState: nil + ] + originalException [ "Answer the uncaught exception." diff --git a/kernel/CallinProcess.st b/kernel/CallinProcess.st index 60aa482..d43826a 100644 --- a/kernel/CallinProcess.st +++ b/kernel/CallinProcess.st @@ -39,5 +39,38 @@ Process subclass: CallinProcess [ execution, so I must store the returned value once my computation terminates and I must not survive across image saves (since those who invoked me no longer exist). I am otherwise equivalent to a Process.'> + + returnContext [ + "Return the base context in the process, i.e. the one that is + responsible for passing the return value to C." + + | context | + context := self context. + [ context parentContext isNil ] whileFalse: [ + context := context parentContext ]. + ^context + ] + + detach [ + "Continue running the receiver as a normal Process, and return + nil from the callin." + | p | + self isActive ifFalse: [ + ^SystemExceptions.InvalidState signalOn: self + reason: 'process not active' ]. + + p := Process basicNew. + Link instSize + 1 to: Process instSize do: [ :i | + p instVarAt: i put: (self instVarAt: i) ]. + + "Start executing the detached process from here." + p suspendedContext: thisContext copy. + + Processor activeProcess == self ifTrue: [ + "This only runs in the CallinProcess." + thisContext parentContext: self returnContext. + p resume. + ^nil ] + ] ] diff --git a/kernel/ExcHandling.st b/kernel/ExcHandling.st index f30cbb3..6a8b51b 100644 --- a/kernel/ExcHandling.st +++ b/kernel/ExcHandling.st @@ -230,7 +230,7 @@ hold on to a CoreException via a class-instance variable.'> signal := (signalClass new) initArguments: #(); initException: self. - self instantiateNextHandler: signal from: thisContext. + signal instantiateNextHandlerFrom: thisContext. ^signal activateHandler: false ] @@ -244,7 +244,7 @@ hold on to a CoreException via a class-instance variable.'> signal := (signalClass new) initArguments: {arg}; initException: self. - self instantiateNextHandler: signal from: thisContext. + signal instantiateNextHandlerFrom: thisContext. ^signal activateHandler: false ] @@ -261,7 +261,7 @@ hold on to a CoreException via a class-instance variable.'> {arg. arg2}; initException: self. - self instantiateNextHandler: signal from: thisContext. + signal instantiateNextHandlerFrom: thisContext. ^signal activateHandler: false ] @@ -276,7 +276,7 @@ hold on to a CoreException via a class-instance variable.'> signal := (signalClass new) initArguments: args; initException: self. - self instantiateNextHandler: signal from: thisContext. + signal instantiateNextHandlerFrom: thisContext. ^signal activateHandler: false ] @@ -330,26 +330,6 @@ hold on to a CoreException via a class-instance variable.'> depth := anInteger ] - instantiateNextHandler: aSignal from: aContext [ - "Private - Tell aSignal what it needs on the next handler for the receiver. - If none is found, look for an handler for our parent, until one - is found or ExAll if reached and there is no handler. In this case, answer - the default handler for anException." - - - aContext parentContext scanBacktraceForAttribute: #exceptionHandlerSearch:reset: - do: - [:context :attr | - | status | - status := (attr arguments at: 1) value: context value: aSignal. - status == #found ifTrue: [^self]]. - aSignal - onDoBlock: nil - handlerBlock: self actualDefaultHandler - onDoContext: nil - previousState: nil - ] - actualDefaultHandler [ "Private - Answer the default handler for the receiver. It differs from #defaultHandler because if the default handler of the parent has to be @@ -556,6 +536,32 @@ with a lower priority.'> ^self exception isResumable ] + instantiateNextHandlerFrom: aContext [ + "Private - Fill the receiver with information on the next handler for + it, possibly a handler for a parent or the default handler." + + + aContext parentContext scanBacktraceForAttribute: #exceptionHandlerSearch:reset: + do: + [:context :attr | + | status | + status := (attr arguments at: 1) value: context value: self. + status == #found ifTrue: [^self]]. + + self instantiateDefaultHandler. + ] + + instantiateDefaultHandler [ + "Private - Fill the receiver with information on its default handler." + + + self + onDoBlock: nil + handlerBlock: self exception actualDefaultHandler + onDoContext: nil + previousState: nil + ] + outer [ "Raise the exception that instantiated the receiver, passing the same parameters. @@ -570,7 +576,7 @@ with a lower priority.'> | signal | signal := self copy. signal isNested: true. - self exception instantiateNextHandler: signal from: self context. + signal instantiateNextHandlerFrom: self context. ^signal activateHandler: true ] @@ -584,7 +590,7 @@ with a lower priority.'> | signal | signal := self copy. signal isNested: true. - self exception instantiateNextHandler: signal from: self context. + signal instantiateNextHandlerFrom: self context. ^self return: (signal activateHandler: true) ] @@ -641,8 +647,7 @@ with a lower priority.'> Kernel.CoreException resetAllHandlers. - replacementException exception - instantiateNextHandler: replacementException from: thisContext. + replacementException instantiateNextHandlerFrom: thisContext. ^replacementException return: (replacementException activateHandler: true) ] @@ -746,7 +751,7 @@ with a lower priority.'> "Mark the handler that the receiver is using as not active." - context isNil + onDoBlock isNil ifFalse: [context at: context numArgs + 1 put: previousState] ] diff --git a/kernel/Process.st b/kernel/Process.st index d948d35..3f76f92 100644 --- a/kernel/Process.st +++ b/kernel/Process.st @@ -223,6 +223,14 @@ can suspend themselves and resume themselves however they wish.'> ^suspendedContext ] + suspendedContext: aContext [ + "Modify the context that the process was executing at the time it was + suspended." + + + suspendedContext := aContext + ] + name [ "Answer the user-friendly name of the process." diff --git a/libgst/comp.c b/libgst/comp.c index 44083c7..5761ea5 100644 --- a/libgst/comp.c +++ b/libgst/comp.c @@ -451,7 +451,7 @@ _gst_install_initial_methods (void) _gst_set_compilation_category (_gst_string_new ("private")); _gst_alloc_bytecodes (); _gst_compile_byte (EXIT_INTERPRETER, 0); - _gst_compile_byte (RETURN_CONTEXT_STACK_TOP, 0); + _gst_compile_byte (JUMP_BACK, 4); /* The zeros are primitive, # of args, # of temps, stack depth */ termination_method = _gst_make_new_method (0, 0, 0, 0, _gst_nil_oop, diff --git a/libgst/vm.def b/libgst/vm.def index 7a6760f..618f6b8 100644 --- a/libgst/vm.def +++ b/libgst/vm.def @@ -925,7 +925,8 @@ operation EXIT_INTERPRETER ( val -- val ) { if (IS_NIL (activeProcessOOP)) abort (); - process->returnedValue = val; + if (process->objClass == _gst_callin_process_class) + process->returnedValue = val; _gst_terminate_process (activeProcessOOP); if (processOOP == activeProcessOOP) SET_EXCEPT_FLAG (true); diff --git a/packages/visualgst/Debugger/GtkDebugger.st b/packages/visualgst/Debugger/GtkDebugger.st index 6966583..87f6418 100644 --- a/packages/visualgst/Debugger/GtkDebugger.st +++ b/packages/visualgst/Debugger/GtkDebugger.st @@ -12,6 +12,13 @@ GtkMainWindow subclass: GtkDebugger [ GtkDebugger class >> open: aString [ + Processor activeProcess class == CallinProcess ifTrue: [ + "The current process might be processing an event. Gtk will + block inside g_main_loop_dispatch and won't deliver any + other events until this one is processed. So, fork into a + new process and return nil without executing #ensure: blocks." + Processor activeProcess detach ]. + [ :debugger | Processor activeProcess name: 'Notifier/Debugger'. (self openSized: address@hidden)