[PATCH] Add BlockClosure>>#cull: and friends

View: New views

1 Messages — Rating Filter: Alert me

[PATCH] Add BlockClosure>>#cull: and friends

by Paolo Bonzini-2 :: Rate this Message:

Reply to Author | View Threaded | Show Only this Message

These are a bit cleverly named, but that's what the VW guys adopted.
It's extended versions of #valueWithPossibleArgument: (which never
entered GNU Smalltalk because of the ugly name, but is there in Squeak).

I chose to implement it in the VM for speed and because the needed code
is possibly less than with a pure Smalltalk implementation.

Paolo

2008-05-12 Paolo Bonzini <bonzini@...>

* kernel/BlkClosure.st: Add #cull:, #cull:cull:, #cull:cull:cull:.
* kernel/ExcHandling.st: Use it for the exception handlers.
* kernel/Object.st: Use it for #ifNotNil:.
* tests/blocks.st: New tests.
* tests/blocks.ok: Regenerate.

libgst:
2008-05-12 Paolo Bonzini <bonzini@...>

* libgst/interp.c: Adjust send_block_value prototype.
* libgst/interp-bc.inl: Support block argument culling.
* libgst/interp-jit.inl: Support block argument culling.
* libgst/prims.def: Add primitives for block argument culling.
* libgst/vm.def: Adjust calls to send_block_value.

diff --git a/NEWS b/NEWS
index 3a968e9..634e68b 100644
--- a/NEWS
+++ b/NEWS
@@ -2,6 +2,11 @@ List of user-visible changes in GNU Smalltalk

NEWS FROM 3.0.2 TO 3.0a

+o BlockClosure methods #cull:, #cull:cull:, #cull:cull:cull:
+ evaluate blocks removing parameters that are not accepted by
+ the block. Thanks to this new functionality, the parameter to
+ #on:do: and #ifNotNil: can be omitted.
+
o CObjects can be backed with garbage-collected (as opposed to
heap-allocated) storage. Using this is not always possible, for
example for CObjects stored by external libraries or passed to
diff --git a/examples/Case.st b/examples/Case.st
index 3dd6054..1ec28d0 100644
--- a/examples/Case.st
+++ b/examples/Case.st
@@ -59,12 +59,12 @@ test: anObject
!Case methodsFor: 'testing'!

test: anObject
- test _ anObject.
- found _ false.
+ test := anObject.
+ found := false.
!

reset
- found _ false
+ found := false
!

else: aBlock
@@ -94,10 +94,8 @@ when: aBlock do: aBlock2
!Case methodsFor: 'private'!

do: aBlock
- found _ true.
- ^result := (aBlock numArgs = 0
- ifTrue: [ aBlock value ]
- ifFalse: [ aBlock value: test ])
+ found := true.
+ ^result := (aBlock cull: test)
! !

diff --git a/kernel/BlkClosure.st b/kernel/BlkClosure.st
index 0b45506..63c9446 100644
--- a/kernel/BlkClosure.st
+++ b/kernel/BlkClosure.st
@@ -410,14 +410,11 @@ creation of Processes from blocks.'>

forkWithoutPreemption [
"Evaluate the receiver in a process that cannot be preempted.
- If the receiver expect a parameter, pass the current process
- (can be useful for queuing interrupts from within the
- uninterruptible process)."
+ If the receiver expect a parameter, pass the current process."

<category: 'multiple process'>
| closure args process result |
- closure := [self valueWithArguments: args].
- args := self numArgs = 0 ifTrue: [#()] ifFalse: [{Processor activeProcess}].
+ closure := [self cull: Processor activeProcess].
^Process
on: closure
at: Processor unpreemptedPriority
@@ -590,6 +587,33 @@ creation of Processes from blocks.'>
SystemExceptions.WrongArgumentCount signal
]

+ cull: arg1 [
+ "Evaluate the receiver, passing arg1 as the only parameter if
+ the receiver has parameters."
+
+ <category: 'built ins'>
+ <primitive: VMpr_BlockClosure_cull>
+ SystemExceptions.WrongArgumentCount signal
+ ]
+
+ cull: arg1 cull: arg2 [
+ "Evaluate the receiver, passing arg1 and arg2 as parameters if
+ the receiver accepts them."
+
+ <category: 'built ins'>
+ <primitive: VMpr_BlockClosure_cull>
+ SystemExceptions.WrongArgumentCount signal
+ ]
+
+ cull: arg1 cull: arg2 cull: arg3 [
+ "Evaluate the receiver, passing arg1, arg2 and arg3 as parameters if
+ the receiver accepts them."
+
+ <category: 'built ins'>
+ <primitive: VMpr_BlockClosure_cull>
+ SystemExceptions.WrongArgumentCount signal
+ ]
+
valueWithArguments: argumentsArray [
"Evaluate the receiver passing argArray's elements as the parameters"

diff --git a/kernel/ExcHandling.st b/kernel/ExcHandling.st
index 31b4b23..4e8eb7d 100644
--- a/kernel/ExcHandling.st
+++ b/kernel/ExcHandling.st
@@ -684,7 +684,7 @@ with a lower priority.'>
[:object |
self resetHandler.
^object].
- result := handlerBlock value: self.
+ result := handlerBlock cull: self.
resumeBoolean
ifTrue:
[self resetHandler.
diff --git a/kernel/Object.st b/kernel/Object.st
index 90e0bff..733bbd9 100644
--- a/kernel/Object.st
+++ b/kernel/Object.st
@@ -143,7 +143,7 @@ All classes in the system are subclasses of me.'>
notNilBlock, passing the receiver."

<category: 'testing functionality'>
- ^notNilBlock value: self
+ ^notNilBlock cull: self
]

ifNotNil: notNilBlock [
@@ -151,7 +151,7 @@ All classes in the system are subclasses of me.'>
Else answer nil."

<category: 'testing functionality'>
- ^notNilBlock value: self
+ ^notNilBlock cull: self
]

ifNotNil: notNilBlock ifNil: nilBlock [
@@ -159,7 +159,7 @@ All classes in the system are subclasses of me.'>
notNilBlock, passing the receiver."

<category: 'testing functionality'>
- ^notNilBlock value: self
+ ^notNilBlock cull: self
]

isCObject [
diff --git a/libgst/interp-bc.inl b/libgst/interp-bc.inl
index cafa13b..093940f 100644
--- a/libgst/interp-bc.inl
+++ b/libgst/interp-bc.inl
@@ -396,7 +396,7 @@ _gst_send_method (OOP methodOOP)

static mst_Boolean
-send_block_value (int numArgs)
+send_block_value (int numArgs, int cull_up_to)
{
OOP closureOOP;
block_header header;
@@ -406,10 +406,15 @@ send_block_value (int numArgs)
closureOOP = STACK_AT (numArgs);
closure = (gst_block_closure) OOP_TO_OBJ (closureOOP);
header = ((gst_compiled_block) OOP_TO_OBJ (closure->block))->header;
+
+ /* Check numArgs. Remove up to CULL_UP_TO extra arguments if needed. */
if UNCOMMON (numArgs != header.numArgs)
{
- /* check numArgs asap */
- return (true);
+ if (numArgs < header.numArgs || numArgs > header.numArgs + cull_up_to)
+ return (true);
+
+ POP_N_OOPS (numArgs - header.numArgs);
+ numArgs = header.numArgs;
}

/* prepare the new state, loading data from the closure */
diff --git a/libgst/interp-jit.inl b/libgst/interp-jit.inl
index 297a8f6..8f7c291 100644
--- a/libgst/interp-jit.inl
+++ b/libgst/interp-jit.inl
@@ -286,7 +286,7 @@ _gst_send_method (OOP methodOOP)
}

static mst_Boolean
-send_block_value (int numArgs)
+send_block_value (int numArgs, int cull_up_to)
{
OOP closureOOP;
OOP receiverClass;
@@ -296,10 +296,15 @@ send_block_value (int numArgs)
closureOOP = STACK_AT (numArgs);
closure = (gst_block_closure) OOP_TO_OBJ (closureOOP);
header = ((gst_compiled_block) OOP_TO_OBJ (closure->block))->header;
+
+ /* Check numArgs. Remove up to CULL_UP_TO extra arguments if needed. */
if UNCOMMON (numArgs != header.numArgs)
{
- /* check numArgs asap */
- return (true);
+ if (numArgs < header.numArgs || numArgs > header.numArgs + cull_up_to)
+ return (true);
+
+ POP_N_OOPS (numArgs - header.numArgs);
+ numArgs = header.numArgs;
}

receiverClass = IS_INT (closure->receiver)
diff --git a/libgst/interp.c b/libgst/interp.c
index 18d2573..18c661f 100644
--- a/libgst/interp.c
+++ b/libgst/interp.c
@@ -424,9 +424,10 @@ static inline OOP create_args_array (int numArgs);
the arguments in the block context, which have been copied out of
the caller's context.

- On failure return true, on success (i.e. if NUMARGS matches what
- the BlockClosure says) return false. */
-static mst_Boolean send_block_value (int numArgs);
+ The block should accept between NUMARGS - CULL_UP_TO and
+ NUMARGS arguments. If this is not true (failure) return true;
+ on success return false. */
+static mst_Boolean send_block_value (int numArgs, int cull_up_to);

/* This is a kind of simplified _gst_send_message_internal that,
instead of setting up a context for a particular receiver, stores
diff --git a/libgst/prims.def b/libgst/prims.def
index 5f242cc..6237fd8 100644
--- a/libgst/prims.def
+++ b/libgst/prims.def
@@ -2581,7 +2581,19 @@ primitive VMpr_Continuation_resume [fail,reload_ip]
primitive VMpr_BlockClosure_value [fail,reload_ip,cache_new_ip]
{
_gst_primitives_executed++;
- if UNCOMMON (send_block_value (numArgs))
+ if UNCOMMON (send_block_value (numArgs, 0))
+ PRIM_FAILED;
+ else
+ PRIM_SUCCEEDED_RELOAD_IP;
+}
+
+/* BlockClosure cull:
+ BlockClosure cull:cull:
+ BlockClosure cull:cull:cull: */
+primitive VMpr_BlockClosure_cull [fail,reload_ip]
+{
+ _gst_primitives_executed++;
+ if UNCOMMON (send_block_value (numArgs, numArgs))
PRIM_FAILED;
else
PRIM_SUCCEEDED_RELOAD_IP;
@@ -2598,7 +2610,7 @@ primitive VMpr_BlockClosure_valueAndResumeOnUnwind [fail,reload_ip]

context = (gst_method_context) OOP_TO_OBJ (_gst_this_context_oop);
context->flags |= MCF_IS_UNWIND_CONTEXT;
- if UNCOMMON (send_block_value (numArgs))
+ if UNCOMMON (send_block_value (numArgs, 0))
PRIM_FAILED;
else
PRIM_SUCCEEDED_RELOAD_IP;
@@ -2621,7 +2633,7 @@ primitive VMpr_BlockClosure_valueWithArguments [fail,reload_ip]
for (i = 1; i <= numArgs; i++)
PUSH_OOP (ARRAY_AT (oop2, i));

- if UNCOMMON (send_block_value (numArgs))
+ if UNCOMMON (send_block_value (numArgs, 0))
{
POP_N_OOPS (numArgs);
PUSH_OOP (oop2);
@@ -5026,7 +5038,7 @@ primitive VMpr_Behavior_primCompileIfError [fail,succeed,reload_ip]
xfree (_gst_first_error_str);
_gst_first_error_str = _gst_first_error_file = NULL;
_gst_report_errors = oldReportErrors;
- if (send_block_value (3))
+ if (send_block_value (3, 3))
PRIM_FAILED;
else
PRIM_SUCCEEDED_RELOAD_IP;
diff --git a/libgst/vm.def b/libgst/vm.def
index bd00206..f85ef29 100644
--- a/libgst/vm.def
+++ b/libgst/vm.def
@@ -632,7 +632,7 @@ operation VALUE_SPECIAL ( rec -- rec ) {
EXPORT_REGS ();
if (UNCOMMON (IS_INT (rec))
|| UNCOMMON (OOP_CLASS (rec) != _gst_block_closure_class)
- || UNCOMMON (send_block_value (0)))
+ || UNCOMMON (send_block_value (0, 0)))
SEND_MESSAGE (_gst_builtin_selectors[VALUE_SPECIAL].symbol, 0);

IMPORT_REGS ();
@@ -644,7 +644,7 @@ operation VALUE_COLON_SPECIAL ( rec blk_arg -- rec blk_arg ) {
EXPORT_REGS ();
if (UNCOMMON (IS_INT (rec))
|| UNCOMMON (OOP_CLASS (rec) != _gst_block_closure_class)
- || UNCOMMON (send_block_value (1)))
+ || UNCOMMON (send_block_value (1, 0)))
SEND_MESSAGE (_gst_builtin_selectors[VALUE_COLON_SPECIAL].symbol, 1);

IMPORT_REGS ();
diff --git a/tests/blocks.ok b/tests/blocks.ok
index 37f1d8d..6952443 100644
--- a/tests/blocks.ok
+++ b/tests/blocks.ok
@@ -72,3 +72,50 @@ returned value is 55
Execution begins...
error: return from a dead method context
returned value is nil
+
+Execution begins...
+returned value is nil
+
+Execution begins...
+returned value is nil
+
+Execution begins...
+returned value is nil
+
+Execution begins...
+returned value is 1
+
+Execution begins...
+returned value is 1
+
+Execution begins...
+returned value is 1
+
+Execution begins...
+ error: wrong number of arguments
+returned value is nil
+
+Execution begins...
+returned value is 1
+
+Execution begins...
+returned value is 1
+
+Execution begins...
+returned value is 2
+
+Execution begins...
+returned value is 2
+
+Execution begins...
+ error: wrong number of arguments
+returned value is nil
+
+Execution begins...
+returned value is 1
+
+Execution begins...
+returned value is 2
+
+Execution begins...
+returned value is 3
diff --git a/tests/blocks.st b/tests/blocks.st
index c9641e8..8be78fc 100644
--- a/tests/blocks.st
+++ b/tests/blocks.st
@@ -153,3 +153,22 @@ Eval [
Eval [ (nil blockTest11: 3) value ] "should be invalid; we're returning to non-
existent parent"

+"Various tests on #cull:cull:cull: and friends."
+Eval [ [] cull: 1 ]
+Eval [ [] cull: 1 cull: 2 ]
+Eval [ [] cull: 1 cull: 2 cull: 3 ]
+
+Eval [ [:a |a] cull: 1 ]
+Eval [ [:a |a] cull: 1 cull: 2 ]
+Eval [ [:a |a] cull: 1 cull: 2 cull: 3 ]
+
+Eval [ [:a :b |a] cull: 1 ]
+Eval [ [:a :b |a] cull: 1 cull: 2 ]
+Eval [ [:a :b |a] cull: 1 cull: 2 cull: 3 ]
+Eval [ [:a :b |b] cull: 1 cull: 2 ]
+Eval [ [:a :b |b] cull: 1 cull: 2 cull: 3 ]
+
+Eval [ [:a :b :c |a] cull: 1 cull: 2 ]
+Eval [ [:a :b :c |a] cull: 1 cull: 2 cull: 3 ]
+Eval [ [:a :b :c |b] cull: 1 cull: 2 cull: 3 ]
+Eval [ [:a :b :c |c] cull: 1 cull: 2 cull: 3 ]

_______________________________________________
help-smalltalk mailing list
help-smalltalk@...
http://lists.gnu.org/mailman/listinfo/help-smalltalk