Hi
here are two clean patches for GST
- ifNil is inlined : no messages are send and no closure are created;
- Mirror primitives.
Hope you find them better
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..c3629d1 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,\n"
+ "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,\n"
+ "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..c6c0a14 100644
--- a/libgst/interp-bc.inl
+++ b/libgst/interp-bc.inl
@@ -274,7 +274,8 @@ _gst_send_message_internal (OOP sendSelector,
case MTH_PRIMITIVE:
if COMMON (!execute_primitive_operation(header.primitiveIndex,
- sendArgs))
+ sendArgs,
+ methodOOP))
/* primitive succeeded. Continue with the parent context */
return;
@@ -362,7 +363,8 @@ _gst_send_method (OOP methodOOP)
case MTH_PRIMITIVE:
if COMMON (!execute_primitive_operation(header.primitiveIndex,
- sendArgs))
+ sendArgs,
+ methodOOP))
/* primitive succeeded. Continue with the parent context */
return;
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..2ad9b79 100644
--- a/libgst/prims.def
+++ b/libgst/prims.def
@@ -6229,5 +6229,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..167e21c 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;
diff --git a/libgst/comp.c b/libgst/comp.c
index 9cc5986..71f2e12 100644
--- a/libgst/comp.c
+++ b/libgst/comp.c
@@ -171,6 +171,9 @@ static mst_Boolean compile_and_or_statement (OOP selector,
static mst_Boolean compile_if_true_false_statement (OOP selector,
tree_node expr);
+static mst_Boolean compile_if_nil_statement (OOP selector,
+ tree_node expr);
+
/* Special case compilation of an infinite loop, given by the parse
node in RECEIVER. Returns true if byte codes were emitted, false
if not. If the last argument to the message is not a block
@@ -252,6 +255,10 @@ static bc_vector compile_sub_expression (tree_node expr);
static bc_vector compile_sub_expression_and_jump (tree_node expr,
int branchLen);
+/* Like compile_sub_expression, POP the value on the stack. */
+static bc_vector compile_pop_sub_expression_and_jump (tree_node expr);
+
+
/* Compile a send with the given RECEIVER (used to check for sends to
super), SELECTOR and number of arguments NUMARGS. */
static void compile_send (tree_node receiver,
@@ -1287,7 +1294,12 @@ compile_keyword_expr (tree_node expr,
compile_expression (expr->v_expr.receiver);
- if (selector == _gst_if_true_symbol
+ if (selector == _gst_if_nil_symbol)
+ {
+ if (compile_if_nil_statement (selector, expr->v_expr.expression))
+ return;
+ }
+ else if (selector == _gst_if_true_symbol
|| selector == _gst_if_false_symbol)
{
if (compile_if_statement (selector, expr->v_expr.expression))
@@ -1689,6 +1701,47 @@ compile_if_true_false_statement (OOP selector,
return (true);
}
+bc_vector
+compile_pop_sub_expression_and_jump (tree_node expr)
+{
+ bc_vector current_bytecodes, subExprByteCodes;
+
+ current_bytecodes = _gst_save_bytecode_array ();
+
+ _gst_compile_byte (POP_STACK_TOP, 0);
+
+ compile_statements (expr->v_block.statements, false);
+
+ subExprByteCodes = _gst_get_bytecodes ();
+ _gst_restore_bytecode_array (current_bytecodes);
+
+ return (subExprByteCodes);
+}
+
+
+mst_Boolean
+compile_if_nil_statement (OOP selector,
+ tree_node expr)
+{
+ bc_vector nilByteCodes;
+ struct builtin_selector *bs = _gst_lookup_builtin_selector ("isNil", 5);
+
+ if (expr->v_list.value->nodeType != TREE_BLOCK_NODE
+ || HAS_PARAMS_OR_TEMPS (expr->v_list.value))
+ return (false);
+
+ _gst_compile_byte (DUP_STACK_TOP, 0);
+ INCR_STACK_DEPTH ();
+
+ _gst_compile_byte (bs->bytecode, 0);
+
+ nilByteCodes = compile_pop_sub_expression_and_jump (expr->v_list.value);
+ compile_jump (_gst_bytecode_length (nilByteCodes), false);
+ _gst_compile_and_free_bytecodes (nilByteCodes);
+
+ return (true);
+}
+
mst_Boolean
compile_if_statement (OOP selector,
tree_node expr)
diff --git a/libgst/sym.c b/libgst/sym.c
index 6c8d1f4..7e323c6 100644
--- a/libgst/sym.c
+++ b/libgst/sym.c
@@ -126,6 +126,7 @@ OOP _gst_if_false_if_true_symbol = NULL;
OOP _gst_if_false_symbol = NULL;
OOP _gst_if_true_if_false_symbol = NULL;
OOP _gst_if_true_symbol = NULL;
+OOP _gst_if_nil_symbol = NULL;
OOP _gst_int_symbol = NULL;
OOP _gst_long_double_symbol = NULL;
OOP _gst_long_symbol = NULL;
@@ -284,6 +285,7 @@ static const symbol_info sym_info[] = {
{&_gst_if_false_symbol, "ifFalse:"},
{&_gst_if_true_if_false_symbol, "ifTrue:ifFalse:"},
{&_gst_if_true_symbol, "ifTrue:"},
+ {&_gst_if_nil_symbol, "ifNil:"},
{&_gst_int_symbol, "int"},
{&_gst_uint_symbol, "uInt"},
{&_gst_long_double_symbol, "longDouble"},
diff --git a/libgst/sym.h b/libgst/sym.h
index 87c1f1c..c1b5ef8 100644
--- a/libgst/sym.h
+++ b/libgst/sym.h
@@ -115,6 +115,7 @@ extern OOP _gst_if_false_if_true_symbol ATTRIBUTE_HIDDEN;
extern OOP _gst_if_false_symbol ATTRIBUTE_HIDDEN;
extern OOP _gst_if_true_if_false_symbol ATTRIBUTE_HIDDEN;
extern OOP _gst_if_true_symbol ATTRIBUTE_HIDDEN;
+extern OOP _gst_if_nil_symbol ATTRIBUTE_HIDDEN;
extern OOP _gst_int_symbol ATTRIBUTE_HIDDEN;
extern OOP _gst_long_double_symbol ATTRIBUTE_HIDDEN;
extern OOP _gst_long_symbol ATTRIBUTE_HIDDEN;
_______________________________________________
help-smalltalk mailing list
[email protected]
https://lists.gnu.org/mailman/listinfo/help-smalltalk
