On 27/02/2012 08:49, Paolo Bonzini wrote:
On 02/26/2012 08:07 PM, Gwenaël Casaccio wrote:
classFor: anObject [
^ ##(MirrorPrimitive class>> privateClass) valueWithReceiver:
anObject withArguments: #()
]
##() is interesting because the compiled method (thus the primitive call)
will be "injected" as a literal thus I don't need to do a lookup all the
time (for getting the compiled method). Now I can execute the primitive
on the object.
What about for even faster execution:
classFor: anObject [
<primitive VMpr_MirrorPrimitive_executePrimitive>
^##(VMpr_Object_class)
]
Paolo
I've made a MirrorPrimitive and two pragmas; the first pragma calls the
primitive
but the second has an extra argument an error block (i.e. vmPrimitive
for: ... at: ifFailed: [])
Thus no exceptions are raised (and thus no possible leaked vmPrimitves
objects).
The primitive number is added at the end by the pragma. I've added the
compiled
method as an extra parameter to the execute_primitive function.
classFor: anObject [
<mirrorPrimtive: VMpr_Object_Class>
]
for: anObject at: anIndex ifFailed: aBlock [
<mirrorPrimtiveWithBlock: VMpr_Object_basicAt>
^aBlock value
]
Cheers,
Gwen
diff --git a/kernel/Class.st b/kernel/Class.st
index 18918e2..9bcc603 100644
--- a/kernel/Class.st
+++ b/kernel/Class.st
@@ -271,7 +271,21 @@ the class category.'>
[:method :ann |
method rewriteAsAsyncCCall: (ann arguments at: 1)
args: (ann arguments at: 2)]
- forPragma: #asyncCCall:args:
+ forPragma: #asyncCCall:args:.
+ self registerHandler:
+ [:method :ann |
+ method makeReadOnly: false.
+ method header: ((((method numArgs bitOr: (method numTemps bitShift: 11)) bitOr: (method stackDepth bitShift: 5)) bitOr: ((VMpr_MirrorPrimitive_executePrimitiveFailBlock bitShift: 17))) bitOr: (4 bitShift: 27)) literals: (method literals copyWith: (ann arguments at: 1)).
+ method makeReadOnly: true.
+ nil ]
+ forPragma: #mirrorPrimitive:.
+ self registerHandler:
+ [:method :ann |
+ method makeReadOnly: false.
+ method header: ((((method numArgs bitOr: (method numTemps bitShift: 11)) bitOr: (method stackDepth bitShift: 5)) bitOr: ((VMpr_MirrorPrimitive_executePrimitiveFailBlock bitShift: 17))) bitOr: (4 bitShift: 27)) literals: (method literals copyWith: (ann arguments at: 1)).
+ method makeReadOnly: true.
+ nil ]
+ forPragma: #mirrorPrimitiveWithBlock:
]
initialize [
diff --git a/libgst/genpr-parse.y b/libgst/genpr-parse.y
index 6d373ca..6e7c452 100644
--- a/libgst/genpr-parse.y
+++ b/libgst/genpr-parse.y
@@ -279,7 +279,8 @@ gen_proto (const char *s)
filprintf (proto_fil,
"static intptr_t\n"
"%s (int id ATTRIBUTE_UNUSED,\n"
- "%*svolatile int numArgs ATTRIBUTE_UNUSED);\n\n",
+ "%*svolatile int numArgs ATTRIBUTE_UNUSED,"
+ "OOP compiledMethod);\n\n",
s, 2 + strlen(s), "");
}
@@ -289,7 +290,8 @@ gen_prim_decl (const char *s)
filprintf (stmt_fil,
"intptr_t\n"
"%s (int id,\n"
- "%*svolatile int numArgs)\n",
+ "%*svolatile int numArgs,"
+ "OOP compiledMethod)\n",
s, 2 + strlen(s), "");
}
@@ -371,7 +373,8 @@ output()
"%s\n"
"intptr_t\n"
"VMpr_HOLE (int id,\n"
- " volatile int numArgs)\n"
+ " volatile int numArgs,\n"
+ " OOP compiledMethod)\n"
"{\n"
" _gst_primitives_executed++;\n"
" _gst_errorf (\"Unhandled primitive operation %%d\", id);\n"
diff --git a/libgst/interp-bc.inl b/libgst/interp-bc.inl
index 8819481..1157c5b 100644
--- a/libgst/interp-bc.inl
+++ b/libgst/interp-bc.inl
@@ -273,15 +273,19 @@ _gst_send_message_internal (OOP sendSelector,
}
case MTH_PRIMITIVE:
- if COMMON (!execute_primitive_operation(header.primitiveIndex,
- sendArgs))
- /* primitive succeeded. Continue with the parent context */
- return;
-
- /* primitive failed. Invoke the normal method. */
- last_primitive = 0;
- break;
-
+ {
+ if COMMON (!execute_primitive_operation(header.primitiveIndex,
+ sendArgs,
+ methodOOP))
+ {
+ /* primitive succeeded. Continue with the parent context */
+ return;
+ }
+
+ /* primitive failed. Invoke the normal method. */
+ last_primitive = 0;
+ break;
+ }
case MTH_USER_DEFINED:
{
OOP argsArrayOOP = create_args_array (sendArgs);
@@ -361,15 +365,17 @@ _gst_send_method (OOP methodOOP)
}
case MTH_PRIMITIVE:
- if COMMON (!execute_primitive_operation(header.primitiveIndex,
- sendArgs))
- /* primitive succeeded. Continue with the parent context */
- return;
-
- /* primitive failed. Invoke the normal method. */
- last_primitive = 0;
- break;
-
+ {
+ if COMMON (!execute_primitive_operation(header.primitiveIndex,
+ sendArgs,
+ methodOOP))
+ /* primitive succeeded. Continue with the parent context */
+ return;
+
+ /* primitive failed. Invoke the normal method. */
+ last_primitive = 0;
+ break;
+ }
case MTH_USER_DEFINED:
{
OOP argsArrayOOP = create_args_array (sendArgs);
diff --git a/libgst/interp.c b/libgst/interp.c
index 6e3a1dd..92872fa 100644
--- a/libgst/interp.c
+++ b/libgst/interp.c
@@ -269,7 +269,8 @@ static int verbose_exec_tracing = false;
correct id and the same NUMARGS and METHODOOP with which it was
invoked. */
static inline intptr_t execute_primitive_operation (int primitive,
- volatile int numArgs);
+ volatile int numArgs,
+ OOP compiledMethod);
/* Execute a #at: primitive, with arguments REC and IDX, knowing that
the receiver's class has an instance specification SPEC. */
@@ -2738,11 +2739,11 @@ cached_index_oop_put_primitive (OOP rec, OOP idx, OOP val, intptr_t spec)
}
static inline intptr_t
-execute_primitive_operation (int primitive, volatile int numArgs)
+execute_primitive_operation (int primitive, volatile int numArgs, OOP compiledMethod)
{
prim_table_entry *pte = &_gst_primitive_table[primitive];
- intptr_t result = pte->func (pte->id, numArgs);
+ intptr_t result = pte->func (pte->id, numArgs, compiledMethod);
last_primitive = primitive;
return result;
}
diff --git a/libgst/interp.h b/libgst/interp.h
index e286e47..03a8fc7 100644
--- a/libgst/interp.h
+++ b/libgst/interp.h
@@ -582,7 +582,8 @@ extern OOP _gst_make_block_closure (OOP blockOOP)
aided in the choice of which by the user-defined parameter ID,
popping NUMARGS methods off the stack if they succeed. */
typedef intptr_t (*primitive_func) (int primitive,
- volatile int numArgs);
+ volatile int numArgs,
+ OOP compiledMethod);
/* Table of primitives, including a primitive and its attributes. */
typedef struct prim_table_entry
diff --git a/libgst/prims.def b/libgst/prims.def
index 131dc8c..f247b81 100644
--- a/libgst/prims.def
+++ b/libgst/prims.def
@@ -88,10 +88,6 @@
oop2 = POP_OOP(); \
oop1 = POP_OOP(); \
if COMMON (RECEIVER_IS_INT(oop1) && IS_INT(oop2)) {\
- intptr_t iarg1, iarg2; \
- iarg1 = TO_INT(oop1); \
- iarg2 = TO_INT(oop2); \
- \
oop1 = op; \
if COMMON (noOverflow || !overflow) { \
PUSH_OOP(oop1); \
@@ -2675,12 +2671,10 @@ primitive VMpr_BlockClosure_valueAndResumeOnUnwind [fail,reload_ip]
/* BlockClosure valueWithArguments: */
primitive VMpr_BlockClosure_valueWithArguments [fail,reload_ip]
{
- OOP oop1;
OOP oop2;
_gst_primitives_executed++;
oop2 = POP_OOP ();
- oop1 = STACKTOP ();
if (IS_CLASS (oop2, _gst_array_class))
{
int i;
@@ -3458,12 +3452,10 @@ primitive VMpr_Object_bootstrapException :
primitive VMpr_Character_create [succeed,fail]
{
- OOP oop1;
OOP oop2;
_gst_primitives_executed++;
oop2 = POP_OOP ();
- oop1 = STACKTOP ();
if (IS_INT (oop2))
{
intptr_t arg2;
@@ -3482,12 +3474,10 @@ primitive VMpr_Character_create [succeed,fail]
primitive VMpr_UnicodeCharacter_create [succeed,fail]
{
- OOP oop1;
OOP oop2;
_gst_primitives_executed++;
oop2 = POP_OOP ();
- oop1 = STACKTOP ();
if (IS_INT (oop2))
{
intptr_t arg2;
@@ -3555,12 +3545,11 @@ primitive VMpr_Dictionary_new [succeed]
/* Memory addressOfOOP: oop */
primitive VMpr_Memory_addressOfOOP [succeed,fail]
{
- OOP oop1;
OOP oop2;
_gst_primitives_executed++;
oop2 = POP_OOP ();
- oop1 = POP_OOP ();
+ POP_OOP ();
if (IS_OOP (oop2))
{
PUSH_OOP (FROM_C_ULONG ((uintptr_t) oop2));
@@ -3573,12 +3562,11 @@ primitive VMpr_Memory_addressOfOOP [succeed,fail]
/* Memory addressOf: oop */
primitive VMpr_Memory_addressOf [succeed,fail]
{
- OOP oop1;
OOP oop2;
_gst_primitives_executed++;
oop2 = POP_OOP ();
- oop1 = POP_OOP ();
+ POP_OOP ();
if (IS_OOP (oop2))
{
PUSH_OOP (FROM_C_ULONG ((uintptr_t) OOP_TO_OBJ (oop2)));
@@ -3657,14 +3645,13 @@ primitive VMpr_SystemDictionary_setTraceFlag [succeed,fail]
/* Memory type: aType at: anAddress */
primitive VMpr_Memory_at [succeed,fail]
{
- OOP oop1;
OOP oop2;
OOP oop3;
_gst_primitives_executed++;
oop3 = POP_OOP ();
oop2 = POP_OOP ();
- oop1 = POP_OOP ();
+ POP_OOP ();
if (IS_C_LONG (oop3) && IS_INT (oop2))
{
intptr_t arg1, arg2;
@@ -5070,14 +5057,12 @@ primitive VMpr_ByteArray_fromCData_size [succeed,fail]
/* String class fromCdata: aCObject size: anInteger */
primitive VMpr_String_fromCData_size [succeed,fail]
{
- OOP oop1;
OOP oop2;
OOP oop3;
_gst_primitives_executed++;
oop3 = POP_OOP ();
oop2 = POP_OOP ();
- oop1 = STACKTOP ();
if (IS_INT (oop3))
{
intptr_t arg3 = TO_INT (oop3);
@@ -5885,7 +5870,6 @@ primitive VMpr_FileDescriptor_socketOp [succeed,fail]
case PRIM_CLOSE_FILE: /* FileDescriptor close */
{
- int result;
_gst_remove_fd_polling_handlers (fd);
rc = close (fd);
if (rc == 0)
@@ -6229,5 +6213,51 @@ primitive VMpr_Random_next [succeed]
PRIM_FAILED;
}
+primitive VMpr_MirrorPrimitive_privateExecutePrimitive :
+ prim_id VMpr_MirrorPrimitive_executePrimitive [fail,succeed],
+ prim_id VMpr_MirrorPrimitive_executePrimitiveFailBlock [fail,succeed]
+{
+ OOP blockOOP;
+ gst_compiled_method _method = (gst_compiled_method) OOP_TO_OBJ (compiledMethod);
+ int primitiveIndex;
+ _gst_primitives_executed++;
+
+ if (!IS_INT (ARRAY_OOP_AT (OOP_TO_OBJ (_method->literals), NUM_INDEXABLE_FIELDS (_method->literals))))
+ PRIM_FAILED;
+
+ primitiveIndex = TO_INT (ARRAY_OOP_AT (OOP_TO_OBJ (_method->literals), NUM_INDEXABLE_FIELDS (_method->literals)));
+
+ /* Pop the error block */
+ if (id == prim_id (VMpr_MirrorPrimitive_executePrimitiveFailBlock))
+ {
+ blockOOP = POP_OOP ();
+ numArgs--;
+ }
+
+ /* Pop the selector */
+ numArgs--;
+
+ if COMMON (!execute_primitive_operation(primitiveIndex, numArgs, compiledMethod))
+ {
+ OOP res = STACKTOP ();
+
+ POP_OOP (); // object
+ SET_STACKTOP (res); // replace self
+
+ PRIM_SUCCEEDED;
+ }
+
+ numArgs++;
+
+ /* Push the error block */
+ if (id == prim_id (VMpr_MirrorPrimitive_executePrimitiveFailBlock))
+ {
+ PUSH_OOP (blockOOP);
+ numArgs++;
+ }
+
+ PRIM_FAILED;
+}
+
#undef INT_BIN_OP
#undef BOOL_BIN_OP
diff --git a/libgst/vm.def b/libgst/vm.def
index fb0b61b..bb4527f 100644
--- a/libgst/vm.def
+++ b/libgst/vm.def
@@ -325,7 +325,7 @@ operation DIVIDE_SPECIAL ( op1 op2 -- op ) {
EXPORT_REGS();
if (COMMON (ARE_INTS (op1, op2)))
{
- if (!VMpr_SmallInteger_divide (10, 1))
+ if (!VMpr_SmallInteger_divide (10, 1, NULL))
{
IMPORT_REGS ();
NEXT_BC;
@@ -341,7 +341,7 @@ operation REMAINDER_SPECIAL ( op1 op2 -- op ) {
PREPARE_STACK ();
EXPORT_REGS();
if (IS_INT (op1) && IS_INT (op2)
- && !VMpr_SmallInteger_modulo (11, 1))
+ && !VMpr_SmallInteger_modulo (11, 1, NULL))
{
IMPORT_REGS ();
NEXT_BC;
@@ -403,7 +403,7 @@ operation INTEGER_DIVIDE_SPECIAL ( op1 op2 -- op1 op2 ) {
PREPARE_STACK ();
EXPORT_REGS();
if (IS_INT (op1) && IS_INT (op2)
- && !VMpr_SmallInteger_intDiv (12, 1))
+ && !VMpr_SmallInteger_intDiv (12, 1, NULL))
{
IMPORT_REGS ();
NEXT_BC;
@@ -518,7 +518,7 @@ operation SIZE_SPECIAL ( rec -- val ) {
}
if COMMON (size_cache_class == (classOOP = OOP_CLASS (rec))
- && !execute_primitive_operation (size_cache_prim, 0))
+ && !execute_primitive_operation (size_cache_prim, 0, NULL))
{
IMPORT_REGS ();
NEXT_BC;
@@ -551,7 +551,7 @@ operation CLASS_SPECIAL ( rec -- val ) {
}
if COMMON (class_cache_class == (classOOP = OOP_CLASS (rec))
- && !execute_primitive_operation (class_cache_prim, 1))
+ && !execute_primitive_operation (class_cache_prim, 1, NULL))
{
IMPORT_REGS ();
NEXT_BC;
_______________________________________________
help-smalltalk mailing list
[email protected]
https://lists.gnu.org/mailman/listinfo/help-smalltalk
