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;