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)