On 04/05/2011 08:57 AM, Paolo Bonzini wrote: Hey,
thanks for your review! > suspended := self isReady not. > block := [self evaluate: [anException signal] > ifNotTerminated: [suspended ifTrue: [self suspend]]. > suspendedContext := block asContext: suspendedContext. > self resume] The issue with the 'self suspend' is that if I use a Delay.. or Socket>>#next my process is suspended so even if I 'break' the execution of this I will suspend the process and it will not be woken up. From a VM safety point of view, is it okay to just continue executing in the unwinded context? My understanding is that when resuming the process the suspendContext (our signal) will be executed and we just return from there then. > > Untested---but if you have testcases I'll gladly merge it! In > particular, I'd have said the last part could be written as > > ^[self ensure: [sem signal]] > on: TimeoutNotification do: [:e | > e block = self > ifTrue: [^aBlock value] > ifFalse: [e pass] ] > > but I suspect you found out it's not. It depends of which semantic is nice. I somehow want to have all ensures be handled before I dispatch the timeout. With the above the timeout would be before the individual ensures. My test case is testing the order and you could print the events Collection to see the change. I have attached my current patch and test case and look forward for another review of this change.
>From 8669e7987e7d6bca564c658ca234b2994edd0984 Mon Sep 17 00:00:00 2001 From: Holger Hans Peter Freyther <[email protected]> Date: Tue, 5 Apr 2011 20:51:37 +0200 Subject: [PATCH] timeout: Add code for timeout handling on BlockClosures Make it possible to terminate the execution of a BlockClosure after a given amount of time. This adds BlockClosure>>#timeout:do. --- configure.ac | 1 + packages/timeout/ChangeLog | 5 ++ packages/timeout/Timeout.st | 124 +++++++++++++++++++++++++++++++++++++++ packages/timeout/TimeoutTest.st | 63 ++++++++++++++++++++ packages/timeout/package.xml | 12 ++++ tests/testsuite.at | 1 + 6 files changed, 206 insertions(+), 0 deletions(-) create mode 100644 packages/timeout/ChangeLog create mode 100644 packages/timeout/Timeout.st create mode 100644 packages/timeout/TimeoutTest.st create mode 100644 packages/timeout/package.xml diff --git a/configure.ac b/configure.ac index a6aa1b5..93f4b89 100644 --- a/configure.ac +++ b/configure.ac @@ -588,6 +588,7 @@ GST_PACKAGE_ENABLE([Sport], [sport]) GST_PACKAGE_ENABLE([SUnit], [sunit]) GST_PACKAGE_ENABLE([Swazoo], [swazoo-httpd]) GST_PACKAGE_ENABLE([Sockets], [sockets], [], [gst_cv_sockets]) +GST_PACKAGE_ENABLE([Timeout], [timeout]) GST_PACKAGE_ENABLE([VFSAddOns], [vfs], [], [], [Makefile]) GST_PACKAGE_ENABLE([VisualGST], [visualgst]) GST_PACKAGE_ENABLE([XML-XMLNodeBuilder], [xml/builder]) diff --git a/packages/timeout/ChangeLog b/packages/timeout/ChangeLog new file mode 100644 index 0000000..b0f4ee9 --- /dev/null +++ b/packages/timeout/ChangeLog @@ -0,0 +1,5 @@ +2011-04-05 Holger Hans Peter Freyther <[email protected]> + + * package.xml: Add initial version. + * Timeout.st: Add initial version. + * TimeoutTest.st: Add initial version. diff --git a/packages/timeout/Timeout.st b/packages/timeout/Timeout.st new file mode 100644 index 0000000..91d856e --- /dev/null +++ b/packages/timeout/Timeout.st @@ -0,0 +1,124 @@ +"====================================================================== +| +| BlockClosure Extensions for Timeouts +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2011 +| Free Software Foundation, Inc. +| Written by Holger Hans Peter Freyther. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + +Namespace current: Smalltalk [ +Notification subclass: TimeoutNotification [ + | blk | + <category: 'Language-Implementation'> + <comment: 'I get send by the timeout handling of BlockClosures +and I am the indication that the time is up and that one should come +to and end.'> + + TimeoutNotification class >> on: aBlk [ + <category: 'creation'> + ^ self new + block: aBlk; yourself + ] + + block: aBlock [ + <category: 'private'> + blk := aBlock + ] + + block [ + <category: 'private'> + ^ blk + ] + + isResumable [ + <category: 'private'> + ^ false + ] +] +] + +Process extend [ + signalInterrupt: anException [ + <category: '*timeout-private'> + self interruptLock critical: + [| block | + self isActive + ifTrue: + [anException signal. + ^self]. + block := [self evaluate: [anException signal] + ifNotTerminated: [self resume]]. + suspendedContext := block asContext: suspendedContext. + self resume] + ] +] + +BlockClosure extend [ + timeout: seconds do: aBlock [ + <category: '*timeout-private'> + "I will execute myself for up to seconds and if a timeout + occurs I will invoke the aBlock. If the timeout occurs early + not much of the block is executed yet. I also have some issues + with Delays and not breaking these properly. + " + | delay sem proc value timeout | + + "Use the semaphore to signal that we executed everything" + sem := Semaphore new. + + "Remember the current process" + proc := Processor activeProcess. + + timeout := false. + + "Start the waiting." + [[ + + "Start a process to wait in and then signal" + [| delay | + delay := Delay forSeconds: seconds. + + "Wait and see if it is timed out. If so send a signal." + (delay timedWaitOn: sem) ifTrue: [ + proc signalInterrupt: (TimeoutNotification on: self). + ]. + ] fork. + + value := self value. + ] ensure: [sem signal] + ] on: TimeoutNotification do: [:e | + e block = self + ifTrue: [timeout := true] + ifFalse: [e pass]. + ]. + + "Make sure we call the ensure's first." + ^ timeout + ifTrue: [^aBlock value] + ifFalse: [^value]. + ] +] diff --git a/packages/timeout/TimeoutTest.st b/packages/timeout/TimeoutTest.st new file mode 100644 index 0000000..a73a25c --- /dev/null +++ b/packages/timeout/TimeoutTest.st @@ -0,0 +1,63 @@ +"====================================================================== +| +| BlockClosure Extensions for Timeouts Tests +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2011 +| Free Software Foundation, Inc. +| Written by Holger Hans Peter Freyther. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + +TestCase subclass: TimeoutTest [ + testSingleDelay [ + | events | + events := OrderedCollection new. + + "Make sure things are timing out" + [ + [(Delay forSeconds: 1000000) wait.] ensure: [events add: 'ensure']. + ] timeout: 1 do: [events add: 'timeout']. + + self assert: events asArray = #('ensure' 'timeout') + ] + + testNestedTimeouts [ + | events | + + events := OrderedCollection new. + + [ + [ + [ + [ + [(Delay forSeconds: 100000) wait. ] ensure: [events add: 'ensure-in']. + ] timeout: 1000000 do: [events add: 'timeout-inner']. + ] ensure: [events add: 'ensure-mid']. + ] timeout: 1 do: [events add: 'timeout']. + ] ensure: [events add: 'ensure-out']. + + self assert: events asArray = #('ensure-in' 'ensure-mid' 'timeout' 'ensure-out'). + ] +] diff --git a/packages/timeout/package.xml b/packages/timeout/package.xml new file mode 100644 index 0000000..247b720 --- /dev/null +++ b/packages/timeout/package.xml @@ -0,0 +1,12 @@ +<package> + <name>Timeout</name> + <namespace>Timeout</namespace> + + <filein>Timeout.st</filein> + + <test> + <sunit>Timeout.TimeoutTest</sunit> + <filein>TimeoutTest.st</filein> + </test> +</package> + diff --git a/tests/testsuite.at b/tests/testsuite.at index ffa3919..bb839b2 100644 --- a/tests/testsuite.at +++ b/tests/testsuite.at @@ -163,6 +163,7 @@ AT_OPTIONAL_PACKAGE_TEST([Seaside-Core]) AT_OPTIONAL_PACKAGE_TEST([Sockets], [AT_XFAIL_IF(:)]) AT_PACKAGE_TEST([Sport]) AT_PACKAGE_TEST([Swazoo]) +AT_PACKAGE_TEST([Timeout]) AT_OPTIONAL_PACKAGE_TEST([XML-XMLParser]) AT_OPTIONAL_PACKAGE_TEST([XML-Expat]) AT_OPTIONAL_PACKAGE_TEST([ZLib]) -- 1.7.4
_______________________________________________ help-smalltalk mailing list [email protected] http://lists.gnu.org/mailman/listinfo/help-smalltalk
